[Fortran] PR37336 - FIINAL patch [1/n]: Implement the finalization wrapper subroutine

Mikael Morin mikael.morin@sfr.fr
Sat Aug 25 13:48:00 GMT 2012


On 19/08/2012 19:50, Tobias Burnus wrote:
> Dear all,
> 
> attached is a slightly updated patch:
> 
> * Call finalizers of nonallocatable, nonpointer components
> * Generate FINAL wrapper for abstract types which have a finalizer. (The
> allocatable components are deallocated in the first type (abstract or
> not) which has a finalizer, i.e. abstract + finalizer or first
> nonabstract type.)
> 
> I had to disable some resolve warning; I did so by introducing an
> attr.artificial. I used it to also fix PR 51632, where we errored out
> for __def_init and __copy where there were coarray components.
> 
> Build and regtested on x86-64-linux.
> OK for the trunk?
> 
> Tobias

Hello,

some general comment:

the patch mixes deallocation and finalization, which are treated
separately in the standard.  I don' know at this point whether it will
make our life really tougher or not, but I think it makes the code
slightly more difficult to read.

I have a mixed general feeling about the patch that
 1. some weird cases are not correctly covered (polymorphic components,
multiple level of finalizable and/or non-finalizable components, of
inheritance, ...)
 2. some of the above "incorrectnesses" may actually cancel each other;
the patch is implemented differently than how I thought it would be. I
may be missing the point after all.

I would like to point out that forcing the wrapper's array argument to
be contiguous will lead to poor code as repacking will be needed with
inherited types to call the parent's wrapper (and the parent's parent's,
etc...).

More specific comments below.

Mikael


> 2012-08-19  Alessandro Fanfarillo  <fanfarillo.gcc@gmail.com>
>             Tobias Burnus  <burnus@net-b.de>
> 
> 	PR fortran/37336
> 	* gfortran.h (symbol_attribute): Add artifical and final_comp.
> 	* parse.c (parse_derived): Set final_comp.
> 	* module.c (mio_symbol_attribute): Handle final.comp.
> 	* class.c (gfc_build_class_symbol): Defer creation of the vtab
> 	if the DT has finalizers, mark generated symbols as
> 	attr.artificial.
> 	(finalize_component, finalization_scalarizer,
> 	generate_finalization_wrapper): New static functions.
> 	(gfc_find_derived_vtab): Add _final component and call
> 	generate_finalization_wrapper.
>         * dump-parse-tree.c (show_f2k_derived): Use resolved
> 	proc_tree->n.sym rather than unresolved proc_sym.
> 	* resolve.c (gfc_resolve_finalizers): Remove not-implemented
> 	error and ensure that the vtab exists.
> 	(resolve_fl_derived): Resolve finalizers before
> 	generating the vtab.
> 	(resolve_symbol): Also allow assumed-rank arrays with CONTIGUOUS;
> 	skip artificial symbols.
> 	(resolve_fl_derived0): Skip artificial symbols.
> 
> 2012-08-19  Alessandro Fanfarillo  <fanfarillo.gcc@gmail.com>
>             Tobias Burnus  <burnus@net-b.de>
> 
> 	PR fortran/51632
> 	* gfortran.dg/coarray_class_1.f90: New.
> 
> 	PR fortran/37336
> 	* gfortran.dg/coarray_poly_3.f90: Update dg-error.
>  	* gfortran.dg/auto_dealloc_2.f90: Update scan-tree-dump-times.
> 	* gfortran.dg/class_19.f03: Ditto.
> 	* gfortran.dg/finalize_4.f03: Remove dg-excess-errors
> 	for not implemented.
> 	* gfortran.dg/finalize_5.f03: Ditto.
> 	* gfortran.dg/finalize_7.f03: Ditto.
> 
> diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
> index 21a91ba..122cc43 100644
> --- a/gcc/fortran/class.c
> +++ b/gcc/fortran/class.c
> @@ -689,6 +694,672 @@ copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype)
>  }
>  
>  
> +/* Call DEALLOCATE for the passed component if it is allocatable, if it is
> +   neither allocatable nor a pointer but has a finalizer, call it. If it
> +   is a nonpointer component with allocatable or finalizes components, walk
> +   them. Either of the is required; other nonallocatables and pointers aren't
> +   handled gracefully.
> +   Note: The DEALLOCATE handling takes care of finalizers, coarray
> +   deregistering and allocatable components of the allocatable.  */
> +
> +void
> +finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
> +		    gfc_expr *stat, gfc_code **code)
> +{
> +  gfc_expr *e;
> +  e = gfc_copy_expr (expr);
> +  e->ref = gfc_get_ref ();
You should walk to the end of the reference chain.  Otherwise you are
overwriting it here.  Unless you avoid recursing, in which case you can
assert it was NULL.

> +  e->ref->type = REF_COMPONENT;
> +  e->ref->u.c.sym = derived;
> +  e->ref->u.c.component = comp;
> +  e->ts = comp->ts;
> +
> +  if (comp->attr.dimension
> +      || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
> +	  && CLASS_DATA (comp)->attr.dimension))
> +    {
> +      e->ref->next = gfc_get_ref ();
> +      e->ref->next->type = REF_ARRAY;
> +      e->ref->next->u.ar.type = AR_FULL;
> +      e->ref->next->u.ar.dimen = 0;
> +      e->ref->next->u.ar.as = comp->ts.type == BT_CLASS ? CLASS_DATA (comp)->as
> +							: comp->as;
> +      e->rank = e->ref->next->u.ar.as->rank;
> +    }
> +
> +  if (comp->attr.allocatable
> +      || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
> +	  && CLASS_DATA (comp)->attr.allocatable))
> +    {
> +      /* Call DEALLOCATE (comp, stat=ignore).  */
> +      gfc_code *dealloc;
> +
> +      dealloc = XCNEW (gfc_code);
> +      dealloc->op = EXEC_DEALLOCATE;
> +      dealloc->loc = gfc_current_locus;
> +
> +      dealloc->ext.alloc.list = gfc_get_alloc ();
> +      dealloc->ext.alloc.list->expr = e;
> +
> +      dealloc->expr1 = stat;
> +      if (*code)
> +	{
> +	  (*code)->next = dealloc;
> +	  (*code) = (*code)->next;
> +	}
> +      else
> +	(*code) = dealloc;
> +    }
> +  else if (comp->ts.type == BT_DERIVED
> +	    && comp->ts.u.derived->f2k_derived
> +	    && comp->ts.u.derived->f2k_derived->finalizers)
What about polymorphic components?
What if only comp's subcomponents are finalizable, the finalization
wrapper should still be called, shouldn't it?

> +    {
> +      /* Call FINAL_WRAPPER (comp);  */
> +      gfc_code *final_wrap;
> +      gfc_symbol *vtab;
> +      gfc_component *c;
> +
> +      vtab = gfc_find_derived_vtab (comp->ts.u.derived);
> +      for (c = vtab->ts.u.derived->components; c; c = c->next)
> +	if (c->name[0] == '_' && c->name[1] == 'f')
> +           break;
> +
> +      gcc_assert (c);
> +      final_wrap = XCNEW (gfc_code);
> +      final_wrap->op = EXEC_CALL;
> +      final_wrap->loc = gfc_current_locus;
> +      final_wrap->next->loc = gfc_current_locus;
> +      final_wrap->next->symtree = c->initializer->symtree;
> +      final_wrap->next->resolved_sym = c->initializer->symtree->n.sym;
> +      final_wrap->next->ext.actual = gfc_get_actual_arglist ();
> +      final_wrap->next->ext.actual->expr = e;
> +
> +      if (*code)
> +	{
> +	  (*code)->next = final_wrap;
> +	  (*code) = (*code)->next;
> +	}
> +      else
> +	(*code) = final_wrap;
> +    }


> +  else
> +    {
> +      gfc_component *c;
> +
> +      gcc_assert ((comp->attr.alloc_comp || comp->attr.final_comp)
> +		  && comp->ts.type != BT_CLASS);
> +      for (c = comp->ts.u.derived->components; c; c = c->next)
> +	if ((comp->ts.type != BT_CLASS && !comp->attr.pointer
> +	     && (comp->attr.alloc_comp || comp->attr.allocatable
> +		 || comp->attr.final_comp))
> +	    || ((comp->ts.type == BT_CLASS && CLASS_DATA (comp)
> +		 && CLASS_DATA (comp)->attr.allocatable)))
> +	  finalize_component (e, comp->ts.u.derived, comp, stat, code);
> +    }
This doesn't work, you use comp instead of c.

If there is a polymorphic component whose declared type is not
finalizable, but whose actual type is, the finalization wrapper should
still be called. So basically one can't just look at the components.

If comp has finalizable subcomponents, it has a finalization wrapper,
which is (or should be) caught above, so this branch is (or should be)
unreachable.

> +}
> +
> +
> +/* Generate code equivalent to
> +   CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
> +		     + idx * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE., c_ptr),
> +		     ptr).  */
> +
> +static gfc_code *
> +finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr,
> +			 gfc_namespace *sub_ns)
> +{
> +  gfc_code *block;
> +  gfc_expr *expr, *expr2, *expr3;
> +
> +  /* C_F_POINTER().  */
> +  block = XCNEW (gfc_code);
> +  block->op = EXEC_CALL;
> +  block->loc = gfc_current_locus;


> +  block->symtree = gfc_find_symtree (sub_ns->sym_root, "c_f_pointer");
This is useless...
> +  gfc_get_sym_tree ("c_f_pointer", sub_ns, &block->symtree, true);
... if followed by this. Or maybe you want to assert that symtree is
NULL in between?

[...]

> +
> +
> +/* Generate the wrapper finalization/polymorphic freeing subroutine for the
> +   derived type "derived". The function first calls the approriate FINAL
> +   subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
> +   components (but not the inherited ones). Last, it calls the wrapper
> +   subroutine of the parent. The generated wrapper procedure takes as argument
> +   an assumed-rank array.
> +   If neither allocatable components nor FINAL subroutines exists, the vtab
> +   will contain a NULL pointer.  */
> +
> +static void
> +generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
> +			       const char *tname, gfc_component *vtab_final)
> +{
> +  gfc_symbol *final, *array, *nelem;
> +  gfc_symbol *ptr = NULL, *idx = NULL;
> +  gfc_component *comp;
> +  gfc_namespace *sub_ns;
> +  gfc_code *last_code;
> +  char name[GFC_MAX_SYMBOL_LEN+1];
> +  bool alloc_comp = false;
This is misnamed, it should be final_comp or something.

> +  gfc_expr *ancestor_wrapper = NULL;
> +
> +  /* Search for the ancestor's finalizers. */
> +  if (derived->attr.extension && derived->components
> +      && (!derived->components->ts.u.derived->attr.abstract
> +	  || derived->components->attr.final_comp))
> +    {
> +      gfc_symbol *vtab;
> +      gfc_component *comp;
> +
> +      vtab = gfc_find_derived_vtab (derived->components->ts.u.derived);
> +      for (comp = vtab->ts.u.derived->components; comp; comp = comp->next)
> +	if (comp->name[0] == '_' && comp->name[1] == 'f')
I have no strong opinion about it, but slightly prefer strcmp (...,
"_final") with regard to readability, and solidity against future vtab
extensions with methods starting with "_f".

> +	  {
> +	    ancestor_wrapper = comp->initializer;
> +	    break;
> +	  }
> +    }
> +
> +  /* No wrapper of the ancestor and no own FINAL subroutines and
> +     allocatable components: Return a NULL() expression.  */
> +  if ((!ancestor_wrapper || ancestor_wrapper->expr_type == EXPR_NULL)
> +      && !derived->attr.alloc_comp
shouldn't there be `&& !derived->attr.final_comp' also?

> +      && (!derived->f2k_derived || !derived->f2k_derived->finalizers))
> +    {
> +      vtab_final->initializer = gfc_get_null_expr (NULL);
> +      return;
> +    }
> +
> +  /* Check whether there are new allocatable components.  */
> +  for (comp = derived->components; comp; comp = comp->next)
> +    {
> +      if (comp == derived->components && derived->attr.extension
> +	  && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
> +	continue;
> +
> +      if (comp->ts.type != BT_CLASS && !comp->attr.pointer
> +	  && (comp->attr.alloc_comp || comp->attr.allocatable
> +	      || comp->attr.final_comp))
> +	alloc_comp = true;

> +      else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
> +	       && CLASS_DATA (comp)->attr.allocatable)
> +	alloc_comp = true;
Shouldn't one assume without condition that there are allocatable or
finalizable subcomponents when there is a polymorphic component?
Same further below.

> +    }
> +
> +  /* If there is no new finalizer and no new allocatable, return with
> +     an expr to the ancestor's one.  */
> +  if ((!derived->f2k_derived || !derived->f2k_derived->finalizers)
> +      && !alloc_comp)
> +    {
> +      vtab_final->initializer = gfc_copy_expr (ancestor_wrapper);
> +      return;
> +    }
> +
> +  /* We now create a wrapper, which does the following:
> +     1. It calls the suitable finalization subroutine for this type
> +     2. In a loop over all noninherited allocatable components and noninherited
> +	components with allocatable components and DEALLOCATE those; this will
> +	take care of finalizers, coarray deregistering and allocatable
> +	nested components.
> +     3. Call the ancestor's finalizer.  */
> +
> +  /* Declare the wrapper function; it takes an assumed-rank array
> +     as argument. */
> +
> +  /* Set up the namespace.  */
> +  sub_ns = gfc_get_namespace (ns, 0);
> +  sub_ns->sibling = ns->contained;
> +  ns->contained = sub_ns;
> +  sub_ns->resolved = 1;
> +
> +  /* Set up the procedure symbol.  */
> +  sprintf (name, "__final_%s", tname);
> +  gfc_get_symbol (name, sub_ns, &final);
> +  sub_ns->proc_name = final;
> +  final->attr.flavor = FL_PROCEDURE;
> +  final->attr.subroutine = 1;
> +  final->attr.pure = 1;
> +  final->attr.artificial = 1;
> +  final->attr.if_source = IFSRC_DECL;
> +  if (ns->proc_name->attr.flavor == FL_MODULE)
> +    final->module = ns->proc_name->name;
> +  gfc_set_sym_referenced (final);
> +
> +  /* Set up formal argument.  */
> +  gfc_get_symbol ("array", sub_ns, &array);
> +  array->ts.type = BT_DERIVED;
> +  array->ts.u.derived = derived;
> +  array->attr.flavor = FL_VARIABLE;
> +  array->attr.dummy = 1;
> +  array->attr.contiguous = 1;
> +  array->attr.dimension = 1;
> +  array->attr.artificial = 1;
> +  array->as = gfc_get_array_spec();
> +  array->as->type = AS_ASSUMED_RANK;
> +  array->as->rank = -1;
> +  array->attr.intent = INTENT_INOUT;
> +  gfc_set_sym_referenced (array);
> +  final->formal = gfc_get_formal_arglist ();
> +  final->formal->sym = array;
> +  gfc_commit_symbol (array);
> +
> +  /* Obtain the size (number of elements) of "array" MINUS ONE,
> +     which is used in the scalarization.  */
> +  gfc_get_symbol ("nelem", sub_ns, &nelem);
> +  nelem->ts.type = BT_INTEGER;
> +  nelem->ts.kind = gfc_index_integer_kind;
> +  nelem->attr.flavor = FL_VARIABLE;
> +  nelem->attr.artificial = 1;
> +  gfc_set_sym_referenced (nelem);
> +  gfc_commit_symbol (nelem);
> +
> +  /* Generate: nelem = SIZE (array) - 1.  */
> +  last_code = XCNEW (gfc_code);
> +  last_code->op = EXEC_ASSIGN;
> +  last_code->loc = gfc_current_locus;
> +
> +  last_code->expr1 = gfc_lval_expr_from_sym (nelem);
> +
> +  last_code->expr2 = gfc_get_expr ();
> +  last_code->expr2->expr_type = EXPR_OP;
> +  last_code->expr2->value.op.op = INTRINSIC_MINUS;
> +  last_code->expr2->value.op.op2
> +	= gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
> +  last_code->expr2->ts = last_code->expr2->value.op.op2->ts;
> +
> +  last_code->expr2->value.op.op1 = gfc_get_expr ();
> +  last_code->expr2->value.op.op1->expr_type = EXPR_FUNCTION;
> +  last_code->expr2->value.op.op1->value.function.isym
> +	= gfc_intrinsic_function_by_id (GFC_ISYM_SIZE);
> +  last_code->expr2->value.op.op1->symtree
> +	= gfc_find_symtree (sub_ns->sym_root, "size");
> +  gfc_get_sym_tree ("size", sub_ns, &last_code->expr2->value.op.op1->symtree,
> +		    false);
> +  last_code->expr2->value.op.op1->symtree->n.sym->attr.flavor = FL_PROCEDURE;
> +  last_code->expr2->value.op.op1->symtree->n.sym->attr.intrinsic = 1;
> +  gfc_commit_symbol (last_code->expr2->value.op.op1->symtree->n.sym);
> +  last_code->expr2->value.op.op1->value.function.actual
> +	= gfc_get_actual_arglist ();
> +  last_code->expr2->value.op.op1->value.function.actual->expr
> +	= gfc_lval_expr_from_sym (array);
> +  /* dim=NULL. */
> +  last_code->expr2->value.op.op1->value.function.actual->next
> +	= gfc_get_actual_arglist ();
> +  /* kind=c_intptr_t. */
> +  last_code->expr2->value.op.op1->value.function.actual->next->next
> +	= gfc_get_actual_arglist ();
> +  last_code->expr2->value.op.op1->value.function.actual->next->next->expr
> +	= gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
> +  last_code->expr2->value.op.op1->ts
> +	= last_code->expr2->value.op.op1->value.function.isym->ts;
> +
> +  sub_ns->code = last_code;
> +
> +  /* Call final subroutines. We now generate code like:
> +     use iso_c_binding
> +     integer, pointer :: ptr
> +     type(c_ptr) :: cptr
> +     integer(c_intptr_t) :: i, addr
> +
> +     select case (rank (array))
> +       case (3)
> +         call final_rank3 (array)
> +       case default:
> +	 do i = 0, size (array)-1
> +	   addr = transfer (c_loc (array), addr) + i * STORAGE_SIZE (array)
> +	   call c_f_pointer (transfer (addr, cptr), ptr)
> +	   call elemental_final (ptr)
> +	 end do
> +     end select */
> +
> +  if (derived->f2k_derived && derived->f2k_derived->finalizers)
> +    {
> +      gfc_finalizer *fini, *fini_elem = NULL;
> +      gfc_code *block = NULL;
> +
> +      /* SELECT CASE (RANK (array)).  */
> +      last_code->next = XCNEW (gfc_code);
> +      last_code = last_code->next;
> +      last_code->op = EXEC_SELECT;
> +      last_code->loc = gfc_current_locus;
> +
> +      last_code->expr1 = gfc_get_expr ();
> +      last_code->expr1->expr_type = EXPR_FUNCTION;
> +      last_code->expr1->value.function.isym
> +	    = gfc_intrinsic_function_by_id (GFC_ISYM_RANK);
> +      last_code->expr1->symtree = gfc_find_symtree (sub_ns->sym_root, "rank");
> +      gfc_get_sym_tree ("rank", sub_ns, &last_code->expr1->symtree,
> +			false);
> +      last_code->expr1->symtree->n.sym->attr.flavor = FL_PROCEDURE;
> +      last_code->expr1->symtree->n.sym->attr.intrinsic = 1;
> +      gfc_commit_symbol (last_code->expr1->symtree->n.sym);
> +      last_code->expr1->value.function.actual = gfc_get_actual_arglist ();
> +      last_code->expr1->value.function.actual->expr
> +	    = gfc_lval_expr_from_sym (array);
> +      last_code->expr1->ts = last_code->expr1->value.function.isym->ts;
> +
> +      for (fini = derived->f2k_derived->finalizers; fini; fini = fini->next)
> +	{
> +	  if (fini->proc_tree->n.sym->attr.elemental)
> +	    {
> +	      fini_elem = fini;
> +	      continue;
> +            }
> +
> +	  /* CASE (fini_rank).  */
> +	  if (block)
> +	    {
> +	      block->block = XCNEW (gfc_code);
> +	      block = block->block;
> +	    }
> +          else
> +	    {
> +	      block = XCNEW (gfc_code);
> +	      last_code->block = block;
> +	    }
> +	  block->loc = gfc_current_locus;
> +	  block->op = EXEC_SELECT;
> +	  block->ext.block.case_list = gfc_get_case ();
> +          block->ext.block.case_list->where = gfc_current_locus;
> +	  if (fini->proc_tree->n.sym->formal->sym->attr.dimension)
> +	    block->ext.block.case_list->low
> +	     = gfc_get_int_expr (gfc_default_integer_kind, NULL,
> +				 fini->proc_tree->n.sym->formal->sym->as->rank);
> +	  else
> +	    block->ext.block.case_list->low
> +		= gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
> +	  block->ext.block.case_list->high
> +		= block->ext.block.case_list->low;
> +
> +          /* CALL fini_rank (array).  */
> +	  block->next = XCNEW (gfc_code);
> +	  block->next->op = EXEC_CALL;
> +	  block->next->loc = gfc_current_locus;
> +	  block->next->symtree = fini->proc_tree;
> +	  block->next->resolved_sym = fini->proc_tree->n.sym;
> +	  block->next->ext.actual = gfc_get_actual_arglist ();
> +	  block->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
> +	}
> +
> +      /* Elemental call - scalarized.  */
> +      if (fini_elem)
> +	{
> +	  gfc_iterator *iter;
> +
> +	  /* CASE DEFAULT.  */
> +	  if (block)
> +	    {
> +	      block->block = XCNEW (gfc_code);
> +	      block = block->block;
> +	    }
> +	  else
> +	    {
> +	      block = XCNEW (gfc_code);
> +	      last_code->block = block;
> +	    }
> +	  block->loc = gfc_current_locus;
> +	  block->op = EXEC_SELECT;
> +	  block->ext.block.case_list = gfc_get_case ();
> +
> +	  gfc_get_symbol ("idx", sub_ns, &idx);
> +	  idx->ts.type = BT_INTEGER;
> +	  idx->ts.kind = gfc_index_integer_kind;
> +	  idx->attr.flavor = FL_VARIABLE;
> +	  idx->attr.artificial = 1;
> +	  gfc_set_sym_referenced (idx);
> +	  gfc_commit_symbol (idx);
> +
> +	  gfc_get_symbol ("ptr", sub_ns, &ptr);
> +	  ptr->ts.type = BT_DERIVED;
> +	  ptr->ts.u.derived = derived;
> +	  ptr->attr.flavor = FL_VARIABLE;
> +	  ptr->attr.pointer = 1;
> +	  ptr->attr.artificial = 1;
> +	  gfc_set_sym_referenced (ptr);
> +	  gfc_commit_symbol (ptr);
> +
> +	  /* Create loop.  */
> +	  iter = gfc_get_iterator ();
> +	  iter->var = gfc_lval_expr_from_sym (idx);
> +	  iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
> +	  iter->end = gfc_lval_expr_from_sym (nelem);
> +	  iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
> +	  block->next = XCNEW (gfc_code);
> +	  block = block->next;
> +	  block->op = EXEC_DO;
> +	  block->loc = gfc_current_locus;
> +	  block->ext.iterator = iter;
> +	  block->block = gfc_get_code ();
> +	  block->block->op = EXEC_DO;
> +
> +          /* Create code for
> +	     CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
> +			   + idx * STORAGE_SIZE (array), c_ptr), ptr).  */
> +	  block->block->next = finalization_scalarizer (idx, array, ptr, sub_ns);
> +	  block = block->block->next;
> +
> +	  /* CALL final_elemental (array).  */
> +	  block->next = XCNEW (gfc_code);
> +	  block = block->next;
> +	  block->op = EXEC_CALL;
> +	  block->loc = gfc_current_locus;
> +	  block->symtree = fini_elem->proc_tree;
> +	  block->resolved_sym = fini_elem->proc_sym;
> +	  block->ext.actual = gfc_get_actual_arglist ();
> +	  block->ext.actual->expr = gfc_lval_expr_from_sym (ptr);
> +	}
> +    }
> +
> +  /* Finalize and deallocate allocatable components. The same manual
> +     scalarization is used as above.  */
> +
> +  if (alloc_comp)
> +    {
> +      gfc_symbol *stat;
> +      gfc_code *block = NULL;
> +      gfc_iterator *iter;
> +
> +      if (!idx)
> +	{
> +	  gfc_get_symbol ("idx", sub_ns, &idx);
> +	  idx->ts.type = BT_INTEGER;
> +	  idx->ts.kind = gfc_index_integer_kind;
> +	  idx->attr.flavor = FL_VARIABLE;
> +	  idx->attr.artificial = 1;
> +	  gfc_set_sym_referenced (idx);
> +	  gfc_commit_symbol (idx);
> +	}
> +
> +      if (!ptr)
> +	{
> +	  gfc_get_symbol ("ptr", sub_ns, &ptr);
> +	  ptr->ts.type = BT_DERIVED;
> +	  ptr->ts.u.derived = derived;
> +	  ptr->attr.flavor = FL_VARIABLE;
> +	  ptr->attr.pointer = 1;
> +	  ptr->attr.artificial = 1;
> +	  gfc_set_sym_referenced (ptr);
> +	  gfc_commit_symbol (ptr);
> +	}
> +
> +      gfc_get_symbol ("ignore", sub_ns, &stat);
> +      stat->attr.flavor = FL_VARIABLE;
> +      stat->attr.artificial = 1;
> +      stat->ts.type = BT_INTEGER;
> +      stat->ts.kind = gfc_default_integer_kind;
> +      gfc_set_sym_referenced (stat);
> +      gfc_commit_symbol (stat);
> +
> +      /* Create loop.  */
> +      iter = gfc_get_iterator ();
> +      iter->var = gfc_lval_expr_from_sym (idx);
> +      iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
> +      iter->end = gfc_lval_expr_from_sym (nelem);
> +      iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
> +      last_code->next = XCNEW (gfc_code);
> +      last_code = last_code->next;
> +      last_code->op = EXEC_DO;
> +      last_code->loc = gfc_current_locus;
> +      last_code->ext.iterator = iter;
> +      last_code->block = gfc_get_code ();
> +      last_code->block->op = EXEC_DO;
> +
> +      /* Create code for
> +	 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
> +			   + idx * STORAGE_SIZE (array), c_ptr), ptr).  */
> +      last_code->block->next = finalization_scalarizer (idx, array, ptr, sub_ns);
> +      block = last_code->block->next;
> +
> +      for (comp = derived->components; comp; comp = comp->next)
> +	{
> +	  if (comp == derived->components && derived->attr.extension
> +	      && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
> +	    continue;
> +
> +	  if ((comp->ts.type != BT_CLASS && !comp->attr.pointer
> +	       && (comp->attr.alloc_comp || comp->attr.allocatable
> +		   || comp->attr.final_comp))
> +	      || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
> +		  && CLASS_DATA (comp)->attr.allocatable))
> +	    {
> +	      finalize_component (gfc_lval_expr_from_sym (ptr), derived, comp,
> +				  gfc_lval_expr_from_sym (stat), &block);
> +	      if (!last_code->block->next)
> +		last_code->block->next = block;
> +	    }
> +	}
> +    }
> +
> +  /* Call the finalizer of the ancestor.  */
> +  if (ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
> +    {
> +      last_code->next = XCNEW (gfc_code);
> +      last_code = last_code->next;
> +      last_code->op = EXEC_CALL;
> +      last_code->loc = gfc_current_locus;
> +      last_code->symtree = ancestor_wrapper->symtree;
> +      last_code->resolved_sym = ancestor_wrapper->symtree->n.sym;
> +
> +      last_code->ext.actual = gfc_get_actual_arglist ();
> +      last_code->ext.actual->expr = gfc_lval_expr_from_sym (array);
I think a reference to the parent component is missing.

> +    }
> +
> +  gfc_commit_symbol (final);
> +  vtab_final->initializer = gfc_lval_expr_from_sym (final);
> +  vtab_final->ts.interface = final;
> +}
> +
> +
>  /* Add procedure pointers for all type-bound procedures to a vtab.  */
>  
>  static void

> diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
> index 44b1900..4cafefe 100644
> --- a/gcc/fortran/parse.c
> +++ b/gcc/fortran/parse.c
> @@ -2250,6 +2250,16 @@ endType:
>  	  sym->attr.lock_comp = 1;
>  	}
>  
> +      /* Look for finalizers.  */
> +      if (c->attr.final_comp
c->attr.final_comp is never set.

I would like to avoid if possible yet another symbol attribute set in
three different functions in three different files and used all over the
place.  What about using a function "calculating" the predicate this time?

> +	  || (c->ts.type == BT_CLASS && c->attr.class_ok
> +	      && CLASS_DATA (c)->ts.u.derived->f2k_derived
> +	      && CLASS_DATA (c)->ts.u.derived->f2k_derived->finalizers)
> +	  || (c->ts.type == BT_DERIVED
> +	      && c->ts.u.derived->f2k_derived
> +	      && c->ts.u.derived->f2k_derived->finalizers))
> +	sym->attr.final_comp = 1;
> +
>        /* Check for F2008, C1302 - and recall that pointers may not be coarrays
>  	 (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
>  	 unless there are nondirect [allocatable or pointer] components



More information about the Gcc-patches mailing list