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

login
register
mail settings
Submitter Tobias Burnus
Date Aug. 19, 2012, 5:50 p.m.
Message ID <50312777.9090007@net-b.de>
Download mbox | patch
Permalink /patch/178576/
State New
Headers show

Comments

Tobias Burnus - Aug. 19, 2012, 5:50 p.m.
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
Tobias Burnus - Aug. 23, 2012, 5:52 a.m.
* PING *

On August 19, 2012, 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
Alessandro Fanfarillo - Aug. 24, 2012, 3:01 p.m.
Dear Tobias,

there are some problems with the final-wrapper-v2.diff patch; I get
the following error

final2.f90:71.15:

end module test
               1
Internal Error at (1):
gfc_code2string(): Bad code

for every test case that I use; in attachment final2.f90.

Regards

Alessandro

2012/8/19 Tobias Burnus <burnus@net-b.de>:
> 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



--
Mikael Morin - Aug. 25, 2012, 1:45 p.m.
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
Tobias Burnus - Aug. 25, 2012, 3:21 p.m.
Dear Mikael, dear all,

Mikael Morin wrote:
> the patch mixes deallocation and finalization, which are treated
> separately in the standard.

First, I want to remark that the standard - in many cases - does not 
require memory freeing ("deallocation"), it "merely" makes it possible 
that one does not leak memory with allocatables. The actually freeing of 
the memory is just a matter of the qualify of the implementation.

Secondly, for a polymorphic type, one does not know at compile time 
whether it has allocatable components or not - nor whether it has a 
finalizer or not. Hence, I do not see another possibility to have a 
common _free/_final entry point in the vtable. As there has to be a 
common entry point, I think it makes sense to have a single finalization 
wrapper which handles both. (I had also initially thought, that one 
could handle those two cases separately, but now I don't see it anymore.)

>   1. some weird cases are not correctly covered (polymorphic components,
> multiple level of finalizable and/or non-finalizable components, of
> inheritance, ...)

I do believe that polymorphic components are correctly handled: If they 
are a POINTER, they are untouched but if they are ALLOCATABLE, one calls 
DEALLOCATE for the component, which should handle the 
finalization/deallocation correctly. (And nonallocatble, nonpointer 
components do not exist.)

> 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...).

I think that's unavoidable with the current array descriptor, which 
assumes that the stride is always a multiple of the size of the type. I 
concur that with the new array descriptor, one restrict the 
copy-in/copy-out to calling explict-shape/assumed-size finalizers, which 
probably do not occur in practice.


> >+finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
> >+  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.

I will do this.

>> >+  if (comp->attr.allocatable
>> >+      || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
>> >+	  && CLASS_DATA (comp)->attr.allocatable))
>> >+    {
>>
>> >+    }
>> >+  else if (comp->ts.type == BT_DERIVED
>> >+	    && comp->ts.u.derived->f2k_derived
>> >+	    && comp->ts.u.derived->f2k_derived->finalizers)
> What about polymorphic components?

I have to admit that the code is a bit implicit: polymorphic components 
are either ALLOCATABLE - and hence handled in the "if" block, or they 
are pointers - in which case this function is not called at all.

> What if only comp's subcomponents are finalizable, the finalization
> wrapper should still be called, shouldn't it?

Well, that's handled in the "else" branch. There, I walk all 
subcomponents. I do not need to walk them in case there is a finalizer 
as the called finalization wrapper will handle them.

>> >+  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.

I hate copy-and-paste bugs. Thanks.

> If there is a polymorphic component whose declared type is not
> finalizable, but whose actual type is, the finalization wrapper should
> still be called.

But it will, as written above, polymorphic components are allocatable 
(or they are pointers and won't get finalized).

> 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.

I probably miss something, but I don't see why this branch should be 
unreachable. One has:

if (component is allocatable)
   call DEALLOCATE(comp) ! which might invoke finalizers
else if (component itself has a finalizer)
   call FINAL_WRAPPER
else
    for all nonpointer subcomponents which are allocatables, have 
finalizers or have allocatable/finalizable components, call 
finalize_component.
end if


>> >+  block->symtree = gfc_find_symtree (sub_ns->sym_root, "c_f_pointer");
> This is useless...

I concur.

>> >+  bool alloc_comp = false;
> This is misnamed, it should be final_comp or something.

I concur, its use became extended during the development of the patch.

>
>> >+      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".

Maybe. "_" && "f" should be faster and I don't see us adding more vtable 
functions. on the other hand, strcmp is safer and clearer. I also don't 
have a strong opinion about that.


>
>> >+	  {
>> >+	    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?

I concur; I forgot that line when I retrofitted the case that there is a 
finalizer but no allocatable componet.


>> >+      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?

Well, we do not deallocate/finalize polymorphic POINTER components.

>> >+  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.

Actually, for a scalar it does not matter and for nonscalars, I still 
need to write the pack/unpack support. For the latter, I am not yet sure 
how to handle it best. As the Fortran standard doesn't allow 
"assumed_rank%comp", this case has to be handled in some special way.

>> >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?

Maybe, however, one has then to call the function a lot of times: In 
generate_finalization_wrapper for the whole type, then for the new added 
components, and then for each component in finalize_component. With the 
current code, the latter has a complexity of approx. O(n lg n), but one 
might be able to improve it a bit by restructuring the code. (On the 
other hand, "n" is probably not excessively large.)

Tobias
Mikael Morin - Aug. 25, 2012, 7:17 p.m.
On 25/08/2012 17:21, Tobias Burnus wrote:
> (And nonallocatble, nonpointer
> components do not exist.)
I missed that indeed.

>> What if only comp's subcomponents are finalizable, the finalization
>> wrapper should still be called, shouldn't it?
> 
> Well, that's handled in the "else" branch. There, I walk all
> subcomponents. I do not need to walk them in case there is a finalizer
> as the called finalization wrapper will handle them.
Actually, I don't understand why you walk twice over the subcomponents:
in the else branch here and in the finalizer.

>> 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.
> 
> I probably miss something, but I don't see why this branch should be
> unreachable. One has:
> 
> if (component is allocatable)
>   call DEALLOCATE(comp) ! which might invoke finalizers
> else if (component itself has a finalizer)
>   call FINAL_WRAPPER
> else
>    for all nonpointer subcomponents which are allocatables, have
> finalizers or have allocatable/finalizable components, call
> finalize_component.
> end if

I expected something like:
if (allocatable)
  call deallocate (comp)
else if (finalizer or subcomponents have a finalizer)
  call FINAL_WRAPPER

As said above, I don't understand why you would walk over the components
twice

>>> >+      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?
> 
> Well, we do not deallocate/finalize polymorphic POINTER components.
Indeed, then I prefer having !CLASS_DATA(comp)->attr.pointer.


>>> >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?
> 
> Maybe, however, one has then to call the function a lot of times: In
> generate_finalization_wrapper for the whole type, then for the new added
> components, and then for each component in finalize_component. With the
> current code, the latter has a complexity of approx. O(n lg n), but one
> might be able to improve it a bit by restructuring the code. (On the
> other hand, "n" is probably not excessively large.)
> 
If performance is a problem, the function could use the flag as a
backend.  As long as the field is used and set in a single place, I
don't mind.  I don't have a strong opinion either, there is already a
full bag of flags; one more wouldn't make things dramatically worse.

Mikael
Tobias Burnus - Aug. 25, 2012, 8:06 p.m.
Mikael Morin wrote:
>>> What if only comp's subcomponents are finalizable, the finalization
>>> wrapper should still be called, shouldn't it?
>> Well, that's handled in the "else" branch. There, I walk all
>> subcomponents. I do not need to walk them in case there is a finalizer
>> as the called finalization wrapper will handle them.
> Actually, I don't understand why you walk twice over the subcomponents:
> in the else branch here and in the finalizer.

Well, I only walk once per component. However, I could unconditionally 
call this function – and move some of the checks from the main program here.

>>> 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.
>> I probably miss something, but I don't see why this branch should be
>> unreachable. One has:
>>
>> if (component is allocatable)
>>    call DEALLOCATE(comp) ! which might invoke finalizers
>> else if (component itself has a finalizer)
>>    call FINAL_WRAPPER
>> else
>>     for all nonpointer subcomponents which are allocatables, have
>> finalizers or have allocatable/finalizable components, call
>> finalize_component.
>> end if
> I expected something like:
> if (allocatable)
>    call deallocate (comp)
> else if (finalizer or subcomponents have a finalizer)
>    call FINAL_WRAPPER

Well, the question is whether one wants to call a finalize wrapper for a 
simple "comp%alloctable_int(10)" or not. In the current scheme, I tried 
to avoid calling a finalizer wrapper for simple allocatable components.

Thus, one has the choice:
a) Directly call DEALLOCATE for alloctable components of subcomponents
b) Always call the finalizer wrapper – also for nonalloctable TYPEs 
(with finalizable/allocatable components)

(a) is more direct and possibly a bit faster while (b) makes the wrapper 
function a tad smaller.


> As said above, I don't understand why you would walk over the components
> twice

I don't. I touch every ((sub)sub)component only once; I only do a deep 
walk until there is either no component or a pointer or an allocatable 
or a finalizable component. I do acknowledge that I repeat some of the 
logic by handling the outer component in the wrapper and the inner 
(sub)subcomponents in the final_components.

>>>>> +      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?
>> Well, we do not deallocate/finalize polymorphic POINTER components.
> Indeed, then I prefer having !CLASS_DATA(comp)->attr.pointer.

Okay, that's equivalent; though, I have to admit that I prefer the 
current version, which I regard as cleaner.

  * * *

Regarding the flag or nonflag final_comp, I have to admit that I still 
do not completely understand how you would implement it.

One option would be something like the following

bool has_final_comp(derived) {
   for (comp = derived->components; comp; comp = comp->next)
   {
    if (comp->attr.pointer)
      continue;
     if (comp->f2k_derived->finalizers || comp->ts.type == BT_CLASS)
       return true;
     if (comp->ts.type == BT_DERIVED
         && has_final_comp(comp->ts.u.derived))
      return true;
   }
   return false
}

in class.c

Another is the version which gets set in parse.c.

However, I do not understand what you mean by:

> If performance is a problem, the function could use the flag as a
> backend.  As long as the field is used and set in a single place, I
> don't mind.  I don't have a strong opinion either, there is already a
> full bag of flags; one more wouldn't make things dramatically worse.


Tobias
Mikael Morin - Aug. 25, 2012, 8:42 p.m.
On 25/08/2012 22:06, Tobias Burnus wrote:
>>>> 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.
>>> I probably miss something, but I don't see why this branch should
>>> be unreachable. One has:
>>> 
>>> if (component is allocatable) call DEALLOCATE(comp) ! which might
>>> invoke finalizers else if (component itself has a finalizer) call
>>> FINAL_WRAPPER else for all nonpointer subcomponents which are
>>> allocatables, have finalizers or have allocatable/finalizable
>>> components, call finalize_component. end if
>> I expected something like: if (allocatable) call deallocate (comp) 
>> else if (finalizer or subcomponents have a finalizer) call
>> FINAL_WRAPPER
> 
> Well, the question is whether one wants to call a finalize wrapper
> for a simple "comp%alloctable_int(10)" or not. In the current scheme,
> I tried to avoid calling a finalizer wrapper for simple allocatable
> components.
> 
> Thus, one has the choice: a) Directly call DEALLOCATE for alloctable
> components of subcomponents b) Always call the finalizer wrapper –
> also for nonalloctable TYPEs (with finalizable/allocatable
> components)
> 
> (a) is more direct and possibly a bit faster while (b) makes the
> wrapper function a tad smaller.
OK, this is a deliberate choice of implementation to avoid call
overhead. I slightly prefer (b), but we can keep (a).
I'm fine with (a) if the code walking the components is shared - which
avoids c vs. comp issues by the way ;-) .

> * * *
> 
> Regarding the flag or nonflag final_comp, I have to admit that I
> still do not completely understand how you would implement it.
> 
> One option would be something like the following
> 
> bool has_final_comp(derived) { for (comp = derived->components; comp;
> comp = comp->next) { if (comp->attr.pointer) continue; if
> (comp->f2k_derived->finalizers || comp->ts.type == BT_CLASS) return
> true; if (comp->ts.type == BT_DERIVED &&
> has_final_comp(comp->ts.u.derived)) return true; } return false }
This was my initial proposition. The benefit is it is very clear how it
works compared to manual setting the flag here and there.
As you raised a performance issue, I proposed something like this:

bool has_final_comp(derived) {
  bool retval = false;

  if (derived->cache.final_comp_set)
    return derived->cache.final_comp;

  for (comp = derived->components; comp; comp = comp->next)
  {
   if (comp->attr.pointer)
     continue;
    if (comp->f2k_derived->finalizers || comp->ts.type == BT_CLASS)
      {
        retval = true;
        break;
      }
    if (comp->ts.type == BT_DERIVED
        && has_final_comp(comp->ts.u.derived))
      {
        retval = true;
        break;
      }
  }
  derived->cache.final_comp_set = 1;
  derived->cache.final_comp = retval;
  return retval;
}

It's no big deal anyway.
I dream of a compiler where all the non-standard symbol attribute flags,
expression rank and typespec, etc, would be implemented like this... No
need for resolution, etc; it would just work everywhere.
I know the story, patches welcome; they may come, one day...

Mikael
Rouson, Damian - Aug. 27, 2012, 6:20 p.m.
Hi Mikael,

Is this patch approved?  I realize it's not the final step (no pun
intended), but I will be very excited to see this hit the trunk.
Supporting FINAL will have broad impact on my work and the work of others
writing modern Fortran libraries and applications.

Damian

On 8/25/12 1:42 PM, "Mikael Morin" <mikael.morin@sfr.fr> wrote:

>On 25/08/2012 22:06, Tobias Burnus wrote:
>>>>> 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.
>>>> I probably miss something, but I don't see why this branch should
>>>> be unreachable. One has:
>>>> 
>>>> if (component is allocatable) call DEALLOCATE(comp) ! which might
>>>> invoke finalizers else if (component itself has a finalizer) call
>>>> FINAL_WRAPPER else for all nonpointer subcomponents which are
>>>> allocatables, have finalizers or have allocatable/finalizable
>>>> components, call finalize_component. end if
>>> I expected something like: if (allocatable) call deallocate (comp)
>>> else if (finalizer or subcomponents have a finalizer) call
>>> FINAL_WRAPPER
>> 
>> Well, the question is whether one wants to call a finalize wrapper
>> for a simple "comp%alloctable_int(10)" or not. In the current scheme,
>> I tried to avoid calling a finalizer wrapper for simple allocatable
>> components.
>> 
>> Thus, one has the choice: a) Directly call DEALLOCATE for alloctable
>> components of subcomponents b) Always call the finalizer wrapper ­
>> also for nonalloctable TYPEs (with finalizable/allocatable
>> components)
>> 
>> (a) is more direct and possibly a bit faster while (b) makes the
>> wrapper function a tad smaller.
>OK, this is a deliberate choice of implementation to avoid call
>overhead. I slightly prefer (b), but we can keep (a).
>I'm fine with (a) if the code walking the components is shared - which
>avoids c vs. comp issues by the way ;-) .
>
>> * * *
>> 
>> Regarding the flag or nonflag final_comp, I have to admit that I
>> still do not completely understand how you would implement it.
>> 
>> One option would be something like the following
>> 
>> bool has_final_comp(derived) { for (comp = derived->components; comp;
>> comp = comp->next) { if (comp->attr.pointer) continue; if
>> (comp->f2k_derived->finalizers || comp->ts.type == BT_CLASS) return
>> true; if (comp->ts.type == BT_DERIVED &&
>> has_final_comp(comp->ts.u.derived)) return true; } return false }
>This was my initial proposition. The benefit is it is very clear how it
>works compared to manual setting the flag here and there.
>As you raised a performance issue, I proposed something like this:
>
>bool has_final_comp(derived) {
>  bool retval = false;
>
>  if (derived->cache.final_comp_set)
>    return derived->cache.final_comp;
>
>  for (comp = derived->components; comp; comp = comp->next)
>  {
>   if (comp->attr.pointer)
>     continue;
>    if (comp->f2k_derived->finalizers || comp->ts.type == BT_CLASS)
>      {
>        retval = true;
>        break;
>      }
>    if (comp->ts.type == BT_DERIVED
>        && has_final_comp(comp->ts.u.derived))
>      {
>        retval = true;
>        break;
>      }
>  }
>  derived->cache.final_comp_set = 1;
>  derived->cache.final_comp = retval;
>  return retval;
>}
>
>It's no big deal anyway.
>I dream of a compiler where all the non-standard symbol attribute flags,
>expression rank and typespec, etc, would be implemented like this... No
>need for resolution, etc; it would just work everywhere.
>I know the story, patches welcome; they may come, one day...
>
>Mikael
>
Mikael Morin - Aug. 27, 2012, 6:48 p.m.
On 27/08/2012 20:20, Rouson, Damian wrote:
> Hi Mikael,
> 
> Is this patch approved?
There are a few overlooks to be fixed and the components walking code
that I would like to see shared.
Then I think it can go in. But there is no big stopper.

Mikael

Patch

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
@@ -34,7 +34,7 @@  along with GCC; see the file COPYING3.  If not see
              declared type of the class variable and its attributes
              (pointer/allocatable/dimension/...).
     * _vptr: A pointer to the vtable entry (see below) of the dynamic type.
-    
+
    For each derived type we set up a "vtable" entry, i.e. a structure with the
    following fields:
     * _hash:     A hash value serving as a unique identifier for this type.
@@ -42,6 +42,9 @@  along with GCC; see the file COPYING3.  If not see
     * _extends:  A pointer to the vtable entry of the parent derived type.
     * _def_init: A pointer to a default initialized variable of this type.
     * _copy:     A procedure pointer to a copying procedure.
+    * _final:    A procedure pointer to a wrapper function, which frees
+		 allocatable components and calls FINAL subroutines.
+
    After these follow procedure pointer components for the specific
    type-bound procedures.  */
 
@@ -572,7 +575,9 @@  gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
       if (gfc_add_component (fclass, "_vptr", &c) == FAILURE)
 	return FAILURE;
       c->ts.type = BT_DERIVED;
-      if (delayed_vtab)
+      if (delayed_vtab
+	  || (ts->u.derived->f2k_derived
+	      && ts->u.derived->f2k_derived->finalizers))
 	c->ts.u.derived = NULL;
       else
 	{
@@ -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 ();
+  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)
+    {
+      /* 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);
+    }
+}
+
+
+/* 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");
+  gfc_get_sym_tree ("c_f_pointer", sub_ns, &block->symtree, true);
+  block->resolved_sym = block->symtree->n.sym;
+  block->resolved_sym->attr.flavor = FL_PROCEDURE;
+  block->resolved_sym->attr.intrinsic = 1;
+  block->resolved_sym->from_intmod = INTMOD_ISO_C_BINDING;
+  block->resolved_sym->intmod_sym_id = ISOCBINDING_F_POINTER;
+  gfc_commit_symbol (block->resolved_sym);
+
+  /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t).  */
+  block->ext.actual = gfc_get_actual_arglist ();
+  block->ext.actual->next = gfc_get_actual_arglist ();
+  block->ext.actual->next->expr = gfc_get_int_expr (gfc_index_integer_kind,
+						    NULL, 0);
+
+  /* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t).  */
+
+  /* TRANSFER.  */
+  expr2 = gfc_get_expr ();
+  expr2->expr_type = EXPR_FUNCTION;
+  expr2->value.function.name = "__transfer0";
+  expr2->value.function.isym
+	    = gfc_intrinsic_function_by_id (GFC_ISYM_TRANSFER);
+  /* Set symtree for -fdump-parse-tree.  */
+  expr2->symtree = gfc_find_symtree (sub_ns->sym_root, "transfer");
+  gfc_get_sym_tree ("transfer", sub_ns, &expr2->symtree, false);
+  expr2->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+  expr2->symtree->n.sym->attr.intrinsic = 1;
+  gfc_commit_symbol (expr2->symtree->n.sym);
+  expr2->value.function.actual = gfc_get_actual_arglist ();
+  expr2->value.function.actual->expr
+	    = gfc_lval_expr_from_sym (array);
+  expr2->ts.type = BT_INTEGER;
+  expr2->ts.kind = gfc_index_integer_kind;
+
+  /* TRANSFER's second argument: 0_c_intptr_t.  */
+  expr2->value.function.actual = gfc_get_actual_arglist ();
+  expr2->value.function.actual->next = gfc_get_actual_arglist ();
+  expr2->value.function.actual->next->expr
+		= gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+  expr2->value.function.actual->next->next = gfc_get_actual_arglist ();
+
+  /* TRANSFER's first argument: C_LOC (array).  */
+  expr = gfc_get_expr ();
+  expr->expr_type = EXPR_FUNCTION;
+  expr->symtree = gfc_find_symtree (sub_ns->sym_root, "c_loc");
+  gfc_get_sym_tree ("c_loc", sub_ns, &expr->symtree, false);
+  expr->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+  expr->symtree->n.sym->intmod_sym_id = ISOCBINDING_LOC;
+  expr->symtree->n.sym->attr.intrinsic = 1;
+  expr->symtree->n.sym->from_intmod = INTMOD_ISO_C_BINDING;
+  expr->value.function.esym = expr->symtree->n.sym;
+  expr->value.function.actual = gfc_get_actual_arglist ();
+  expr->value.function.actual->expr
+	    = gfc_lval_expr_from_sym (array);
+  expr->symtree->n.sym->result = expr->symtree->n.sym;
+  gfc_commit_symbol (expr->symtree->n.sym);
+  expr->ts.type = BT_INTEGER;
+  expr->ts.kind = gfc_index_integer_kind;
+  expr2->value.function.actual->expr = expr;
+
+  /* STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE.  */
+  block->ext.actual->expr = gfc_get_expr ();
+  expr = block->ext.actual->expr;
+  expr->expr_type = EXPR_OP;
+  expr->value.op.op = INTRINSIC_DIVIDE;
+
+  /* STORAGE_SIZE (array,kind=c_intptr_t).  */
+  expr->value.op.op1 = gfc_get_expr ();
+  expr->value.op.op1->expr_type = EXPR_FUNCTION;
+  expr->value.op.op1->value.function.isym
+		= gfc_intrinsic_function_by_id (GFC_ISYM_STORAGE_SIZE);
+  expr->value.op.op1->symtree = gfc_find_symtree (sub_ns->sym_root,
+						  "storage_size");
+  gfc_get_sym_tree ("storage_size", sub_ns, &expr->value.op.op1->symtree,
+				    false);
+  expr->value.op.op1->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+  expr->value.op.op1->symtree->n.sym->attr.intrinsic = 1;
+  gfc_commit_symbol (expr->value.op.op1->symtree->n.sym);
+  expr->value.op.op1->value.function.actual = gfc_get_actual_arglist ();
+  expr->value.op.op1->value.function.actual->expr
+		= gfc_lval_expr_from_sym (array);
+  expr->value.op.op1->value.function.actual->next = gfc_get_actual_arglist ();
+  expr->value.op.op1->value.function.actual->next->expr
+		= gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+  expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
+					 gfc_character_storage_size);
+  expr->value.op.op1->ts = expr->value.op.op2->ts;
+  expr->ts = expr->value.op.op1->ts;
+
+  /* Offset calculation: idx * (STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE).  */
+  block->ext.actual->expr = gfc_get_expr ();
+  expr3 = block->ext.actual->expr;
+  expr3->expr_type = EXPR_OP;
+  expr3->value.op.op = INTRINSIC_TIMES;
+  expr3->value.op.op1 = gfc_lval_expr_from_sym (idx);
+  expr3->value.op.op2 = expr;
+  expr3->ts = expr->ts;
+
+  /* <array addr> + <offset>.  */
+  block->ext.actual->expr = gfc_get_expr ();
+  block->ext.actual->expr->expr_type = EXPR_OP;
+  block->ext.actual->expr->value.op.op = INTRINSIC_PLUS;
+  block->ext.actual->expr->value.op.op1 = expr2;
+  block->ext.actual->expr->value.op.op2 = expr3;
+  block->ext.actual->expr->ts = expr->ts;
+
+  /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=.  */
+  block->ext.actual->next = gfc_get_actual_arglist ();
+  block->ext.actual->next->expr = gfc_lval_expr_from_sym (ptr);
+  block->ext.actual->next->next = gfc_get_actual_arglist ();
+
+  return block;
+}
+
+
+/* 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;
+  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')
+	  {
+	    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
+      && (!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;
+    }
+
+  /* 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);
+    }
+
+  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
@@ -731,7 +1402,7 @@  gfc_find_derived_vtab (gfc_symbol *derived)
   /* If the type is a class container, use the underlying derived type.  */
   if (derived->attr.is_class)
     derived = gfc_get_derived_super_type (derived);
-    
+ 
   if (ns)
     {
       char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
@@ -831,6 +1502,7 @@  gfc_find_derived_vtab (gfc_symbol *derived)
 	      if (gfc_add_component (vtype, "_def_init", &c) == FAILURE)
 		goto cleanup;
 	      c->attr.pointer = 1;
+	      c->attr.artificial = 1;
 	      c->attr.access = ACCESS_PRIVATE;
 	      c->ts.type = BT_DERIVED;
 	      c->ts.u.derived = derived;
@@ -842,6 +1514,7 @@  gfc_find_derived_vtab (gfc_symbol *derived)
 		  sprintf (name, "__def_init_%s", tname);
 		  gfc_get_symbol (name, ns, &def_init);
 		  def_init->attr.target = 1;
+		  def_init->attr.artificial = 1;
 		  def_init->attr.save = SAVE_IMPLICIT;
 		  def_init->attr.access = ACCESS_PUBLIC;
 		  def_init->attr.flavor = FL_VARIABLE;
@@ -876,6 +1549,7 @@  gfc_find_derived_vtab (gfc_symbol *derived)
 		  copy->attr.flavor = FL_PROCEDURE;
 		  copy->attr.subroutine = 1;
 		  copy->attr.pure = 1;
+		  copy->attr.artificial = 1;
 		  copy->attr.if_source = IFSRC_DECL;
 		  /* This is elemental so that arrays are automatically
 		     treated correctly by the scalarizer.  */
@@ -889,7 +1563,8 @@  gfc_find_derived_vtab (gfc_symbol *derived)
 		  src->ts.u.derived = derived;
 		  src->attr.flavor = FL_VARIABLE;
 		  src->attr.dummy = 1;
-		  src->attr.intent = INTENT_IN;
+		  src->attr.artificial = 1;
+     		  src->attr.intent = INTENT_IN;
 		  gfc_set_sym_referenced (src);
 		  copy->formal = gfc_get_formal_arglist ();
 		  copy->formal->sym = src;
@@ -898,6 +1573,7 @@  gfc_find_derived_vtab (gfc_symbol *derived)
 		  dst->ts.u.derived = derived;
 		  dst->attr.flavor = FL_VARIABLE;
 		  dst->attr.dummy = 1;
+		  dst->attr.artificial = 1;
 		  dst->attr.intent = INTENT_OUT;
 		  gfc_set_sym_referenced (dst);
 		  copy->formal->next = gfc_get_formal_arglist ();
@@ -912,6 +1588,20 @@  gfc_find_derived_vtab (gfc_symbol *derived)
 		  c->ts.interface = copy;
 		}
 
+	      /* Add component _final, which contains a procedure pointer to
+		 a wrapper which handles both the freeing of allocatable
+		 components and the calls to finalization subroutines.
+		 Note: The actual wrapper function can only be generated
+		 at resolution time.  */
+
+	      if (gfc_add_component (vtype, "_final", &c) == FAILURE)
+		goto cleanup;
+	      c->attr.proc_pointer = 1;
+	      c->attr.access = ACCESS_PRIVATE;
+	      c->tb = XCNEW (gfc_typebound_proc);
+	      c->tb->ppc = 1;
+	      generate_finalization_wrapper (derived, ns, tname, c);
+
 	      /* Add procedure pointers for type-bound procedures.  */
 	      add_procs_to_declared_vtab (derived, vtype);
 	    }
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index cb8fab4..528b276 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -788,7 +788,7 @@  show_f2k_derived (gfc_namespace* f2k)
   for (f = f2k->finalizers; f; f = f->next)
     {
       show_indent ();
-      fprintf (dumpfile, "FINAL %s", f->proc_sym->name);
+      fprintf (dumpfile, "FINAL %s", f->proc_tree->n.sym->name);
     }
 
   /* Type-bound procedures.  */
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 7c4c0a4..d05e88a 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -761,6 +761,10 @@  typedef struct
   /* Set if a function must always be referenced by an explicit interface.  */
   unsigned always_explicit:1;
 
+  /* Set if the symbol is generated and, hence, standard violations
+     shouldn't be flaged.  */
+  unsigned artificial:1;
+
   /* Set if the symbol has been referenced in an expression.  No further
      modification of type or type parameters is permitted.  */
   unsigned referenced:1;
@@ -784,7 +788,8 @@  typedef struct
      possibly nested.  zero_comp is true if the derived type has no
      component at all.  */
   unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1,
-	   private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1;
+	   private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1,
+	   final_comp:1;
 
   /* This is a temporary selector for SELECT TYPE.  */
   unsigned select_type_temporary:1;
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index a4ff199..232956a 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -1840,7 +1840,7 @@  typedef enum
   AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
   AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE,
   AB_ALLOC_COMP, AB_POINTER_COMP, AB_PROC_POINTER_COMP, AB_PRIVATE_COMP,
-  AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP,
+  AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP, AB_FINAL_COMP,
   AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
   AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
   AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
@@ -2057,6 +2057,8 @@  mio_symbol_attribute (symbol_attribute *attr)
 	MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
       if (attr->coarray_comp)
 	MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits);
+      if (attr->final_comp)
+	MIO_NAME (ab_attribute) (AB_FINAL_COMP, attr_bits);
       if (attr->lock_comp)
 	MIO_NAME (ab_attribute) (AB_LOCK_COMP, attr_bits);
       if (attr->zero_comp)
@@ -2198,6 +2200,9 @@  mio_symbol_attribute (symbol_attribute *attr)
 	    case AB_COARRAY_COMP:
 	      attr->coarray_comp = 1;
 	      break;
+	    case AB_FINAL_COMP:
+	      attr->final_comp = 1;
+	      break;
 	    case AB_LOCK_COMP:
 	      attr->lock_comp = 1;
 	      break;
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->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
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index ac5a362..f19943d 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -11191,10 +11203,7 @@  error:
 		 " defined at %L, suggest also scalar one",
 		 derived->name, &derived->declared_at);
 
-  /* TODO:  Remove this error when finalization is finished.  */
-  gfc_error ("Finalization at %L is not yet implemented",
-	     &derived->declared_at);
-
+  gfc_find_derived_vtab (derived);
   return result;
 }
 
@@ -11898,6 +11907,9 @@  resolve_fl_derived0 (gfc_symbol *sym)
 
   for ( ; c != NULL; c = c->next)
     {
+      if (c->attr.artificial)
+	continue;
+
       /* See PRs 51550, 47545, 48654, 49050, 51075 - and 45170.  */
       if (c->ts.type == BT_CHARACTER && c->ts.deferred && !c->attr.function)
 	{
@@ -12294,6 +12306,10 @@  resolve_fl_derived (gfc_symbol *sym)
 			 &sym->declared_at) == FAILURE)
     return FAILURE;
 
+  /* Resolve the finalizer procedures.  */
+  if (gfc_resolve_finalizers (sym) == FAILURE)
+    return FAILURE;
+  
   if (sym->attr.is_class && sym->ts.u.derived == NULL)
     {
       /* Fix up incomplete CLASS symbols.  */
@@ -12314,10 +12330,6 @@  resolve_fl_derived (gfc_symbol *sym)
   if (resolve_typebound_procedures (sym) == FAILURE)
     return FAILURE;
 
-  /* Resolve the finalizer procedures.  */
-  if (gfc_resolve_finalizers (sym) == FAILURE)
-    return FAILURE;
-  
   return SUCCESS;
 }
 
@@ -12514,6 +12526,9 @@  resolve_symbol (gfc_symbol *sym)
   symbol_attribute class_attr;
   gfc_array_spec *as;
 
+  if (sym->attr.artificial)
+    return;
+
   if (sym->attr.flavor == FL_UNKNOWN
       || (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic
 	  && !sym->attr.generic && !sym->attr.external
@@ -12647,11 +12662,12 @@  resolve_symbol (gfc_symbol *sym)
   /* F2008, C530. */
   if (sym->attr.contiguous
       && (!class_attr.dimension
-	  || (as->type != AS_ASSUMED_SHAPE && !class_attr.pointer)))
+	  || (as->type != AS_ASSUMED_SHAPE && as->type != AS_ASSUMED_RANK
+	      && !class_attr.pointer)))
     {
       gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an "
-		  "array pointer or an assumed-shape array", sym->name,
-		  &sym->declared_at);
+		 "array pointer or an assumed-shape or assumed-rank array",
+		 sym->name, &sym->declared_at);
       return;
     }
 
diff --git a/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 b/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
index e607b6a..9096b85 100644
--- a/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
+++ b/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
@@ -25,5 +25,5 @@  contains
 
 end program 
 
-! { dg-final { scan-tree-dump-times "__builtin_free" 3 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free" 4 "original" } }
 ! { dg-final { cleanup-tree-dump "original" } }
diff --git a/gcc/testsuite/gfortran.dg/class_19.f03 b/gcc/testsuite/gfortran.dg/class_19.f03
index 63b8e06..884d6ae 100644
--- a/gcc/testsuite/gfortran.dg/class_19.f03
+++ b/gcc/testsuite/gfortran.dg/class_19.f03
@@ -39,5 +39,5 @@  program main
 
 end program main
 
-! { dg-final { scan-tree-dump-times "__builtin_free" 11 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free" 14 "original" } }
 ! { dg-final { cleanup-tree-dump "original" } }
diff --git a/gcc/testsuite/gfortran.dg/coarray_poly_3.f90 b/gcc/testsuite/gfortran.dg/coarray_poly_3.f90
index e6b19ae..8edd8d3 100644
--- a/gcc/testsuite/gfortran.dg/coarray_poly_3.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_poly_3.f90
@@ -3,13 +3,13 @@ 
 !
 
 
-subroutine cont1(x) ! { dg-error "has the CONTIGUOUS attribute but is not an array pointer or an assumed-shape array" }
+subroutine cont1(x) ! { dg-error "has the CONTIGUOUS attribute but is not an array pointer or an assumed-shape or assumed-rank array" }
   type t
   end type t
   class(t), contiguous, allocatable :: x(:)
 end
 
-subroutine cont2(x) ! { dg-error "has the CONTIGUOUS attribute but is not an array pointer or an assumed-shape array" }
+subroutine cont2(x) ! { dg-error "has the CONTIGUOUS attribute but is not an array pointer or an assumed-shape or assumed-rank array" }
   type t
   end type t
   class(t), contiguous, allocatable :: x(:)[:]
diff --git a/gcc/testsuite/gfortran.dg/finalize_4.f03 b/gcc/testsuite/gfortran.dg/finalize_4.f03
index 11e094f..b4c08f2 100644
--- a/gcc/testsuite/gfortran.dg/finalize_4.f03
+++ b/gcc/testsuite/gfortran.dg/finalize_4.f03
@@ -48,6 +48,3 @@  PROGRAM finalizer
   DEALLOCATE(mat)
 
 END PROGRAM finalizer
-
-! TODO: Remove this once finalization is implemented.
-! { dg-excess-errors "not yet implemented" }
diff --git a/gcc/testsuite/gfortran.dg/finalize_5.f03 b/gcc/testsuite/gfortran.dg/finalize_5.f03
index b9ec376..fb81531 100644
--- a/gcc/testsuite/gfortran.dg/finalize_5.f03
+++ b/gcc/testsuite/gfortran.dg/finalize_5.f03
@@ -107,6 +107,3 @@  PROGRAM finalizer
   IMPLICIT NONE
   ! Nothing here, errors above
 END PROGRAM finalizer
-
-! TODO: Remove this once finalization is implemented.
-! { dg-excess-errors "not yet implemented" }
diff --git a/gcc/testsuite/gfortran.dg/finalize_7.f03 b/gcc/testsuite/gfortran.dg/finalize_7.f03
index 6ca4f55..5807ed5 100644
--- a/gcc/testsuite/gfortran.dg/finalize_7.f03
+++ b/gcc/testsuite/gfortran.dg/finalize_7.f03
@@ -52,6 +52,3 @@  PROGRAM finalizer
   IMPLICIT NONE
   ! Nothing here
 END PROGRAM finalizer
-
-! TODO: Remove this once finalization is implemented.
-! { dg-excess-errors "not yet implemented" }
--- /dev/null	2012-08-16 07:16:46.391724752 +0200
+++ gcc/gcc/testsuite/gfortran.dg/coarray_class_1.f90	2012-08-19 19:23:41.000000000 +0200
@@ -0,0 +1,23 @@ 
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! PR fortran/51632
+!
+! Was rejected before as __def_init and __copy were
+! resolved and coarray components aren't valid in this
+! context
+!
+module periodic_2nd_order_module
+  implicit none
+
+  type periodic_2nd_order
+    real, allocatable :: global_f(:)[:]
+  contains
+    procedure :: output
+  end type
+
+contains
+  subroutine output (this)
+    class(periodic_2nd_order), intent(in) :: this
+  end subroutine
+end module