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

login
register
mail settings
Submitter Tobias Burnus
Date Aug. 13, 2012, 8:05 p.m.
Message ID <50295E1A.5050108@net-b.de>
Download mbox | patch
Permalink /patch/177056/
State New
Headers show

Comments

Tobias Burnus - Aug. 13, 2012, 8:05 p.m.
Dear all,

Attached is the first part of a patch which will implement finalization 
support and polymorphic freeing in gfortran.


It addresses two needs:

a) For polymorphic ("CLASS") variables, allocatable components have to 
be freed; however, at compile time only the allocatable components of 
the declared type are known – and the dynamic type might have more

b) Fortran 2003 allows finalization subroutines ("FINAL", destructors), 
which can be elemental, scalar or for a given rank (any array type is 
allowed). Those should be called for DEALLOCATE, leaving the scope 
(unless saved), intrinsic assignment and with intent(out).


The finalization is done as follows (F2008, "4.5.6.2 The finalization 
process")

"(1) If the dynamic type of the entity has a final subroutine whose 
dummy argument has the same kind type parameters and rank as the entity 
being finalized, it is called with the entity as an actual argument. 
Otherwise, if there is an elemental final subroutine whose dummy 
argument has the same kind type parameters as the entity being 
finalized, it is called with the entity as an actual argument. 
Otherwise, no subroutine is called at this point.

"(2) All finalizable components that appear in the type definition are 
finalized in a processor-dependent order. If the entity being finalized 
is an array, each finalizable component of each element of that entity 
is finalized separately.

"(3) If the entity is of extended type and the parent type is 
finalizable, the parent component is finalized."


The idea is to create a wrapper function which handles those steps - and 
attach a reference to the dynamic type (i.e. add it via proc-pointer to 
the vtable). Additionally, the wrapper can be directly called for TYPE.


The attached patch implements the generation of the wrapper subroutine; 
it does not yet implement the actual calls. The wrapper is generated on 
Fortran AST level and creates code similar to

subroutine final_wrapper_for_type_t (array)
type(t), intent(inout) :: array(..)
integer, pointer :: ptr
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, c_ptr), ptr)
call elemental_final (ptr)
end do
end select

! For all noninherited allocatable components, call
! DEALLOCATE(array(:)%comp, stat=ignore)
! scalarized as above

call final_wrapper_of_parent (array(...)%parent)
end subroutine final_wrapper_for_type_t


Note 1: The call to the parent type requires packing support for 
assumed-rank arrays, which has not yet been implemented (also required 
for TS29113, though not for this usage). That is, without further 
patches, the wrapper will only work for scalars or if the parent has no 
wrapper subroutine.

Note 2: The next step will be to add the calls to the wrapper, starting 
with an explicit DEALLOCATE.


I intent to commit the patch, when approved, without allowing FINAL at 
resolution time; that way there is no false impression that finalization 
actually works.

Build and regtested on x86-64-gnu-linux.
OK for the trunk?

* * *

Note: The patch will break gfortran's OOP ABI. It does so by adding 
"_final" to the virtual table (vtab).

I think breaking the ABI for this functionality is unavoidable. The ABI 
change only affects code which uses the CLASS (polymorphic variables) 
and the issue only raises if one mixes old with new code for the same 
derived type. However, if one does so (e.g. by incomplete 
recompilation), segfaults and similar issues will occur. Hence, I am 
considering to bump the .mod version; that will effectively force a 
recompilation and thus avoid the issue. The down side is that it will 
also break packages (e.g. of Linux distributions) which ship .mod files 
(sorry!). What do you think?

I think it could then be combined with Janus' proc-pointer patch, which 
changes the assembler name of (non-Bind(C)) procedure pointers, declared 
at module level. Again, by forcing recompilation, the .mod version bump 
should ensure that users don't see the ABI breakage. His patch is at 
http://gcc.gnu.org/ml/fortran/2012-04/msg00033.html (I think is okay, 
but I believe it has not yet been reviewed.)

Tobias

PS: I used the following test case to test whether the wrapper 
generation and scalarization works; it properly prints 11,22,33,44,55,66 
and also the dump looks okay for various versions.

The scalarization code should work relatively well; there is only one 
call to an external function: For SIZE gfortran - for what ever reason - 
doesn't generate inline code, but calls libgfortran.


But now the test code:

module m
type tt
end type tt

type t
! type(tt), allocatable :: comp1
integer :: val
contains
final bar1
end type t

type t1t
! type(tt), allocatable :: comp1
integer :: val
!contains
! final bar1
end type t1t

type, extends(t) :: t2
type(tt), allocatable :: comp2
contains
final bar2
end type t2

class(t), allocatable, save :: a
class(t2), allocatable, save :: b

contains
impure elemental subroutine bar1(x)
! subroutine bar1(x)
type(t), intent(inout) :: x!(:)
print *, 'bar1, ....'
print *, '..........', x%val
end subroutine bar1
subroutine bar2(y)
type(t2),intent(inout) :: y(:,:)
end subroutine bar2
end

use m
use iso_c_binding
type(t1t) ::x(3,2)

interface
subroutine fini(x) bind(C,name="__m_MOD___final_m_T")
type(*) :: x(..)
end subroutine
end interface

x%val = reshape([11,22,33,44,55,66],shape(x))
print *, storage_size(x)
call fini(x)
end


And one example for a dump:

__final_m_T (struct array7_t & restrict array)
{
integer(kind=8) idx;
integer(kind=8) nelem;
struct t * ptr;

{
struct array7_t * D.1977;

D.1977 = (struct array7_t *) array;
nelem = (integer(kind=8)) (integer(kind=4)) _gfortran_size0 (D.1977) + -1;
}
switch ((integer(kind=4)) array->dtype & 7)
{
default:;
{
integer(kind=8) D.1981;

D.1981 = nelem;
idx = 0;
if (idx <= D.1981)
{
while (1)
{
{
logical(kind=4) D.1991;

{
integer(kind=8) transfer.3;
integer(kind=8) D.1989;
integer(kind=8) D.1988;
static integer(kind=8) C.1987 = 0;
void * D.1986;
void * D.1985;
integer(kind=8) D.1984;

D.1985 = (void *) array->data;
D.1986 = D.1985;
D.1984 = 8;
D.1988 = 8;
__builtin_memcpy ((void *) &transfer.3, (void *) &D.1986, MAX_EXPR 
<MIN_EXPR <D.1988, D.1984>, 0>);
ptr = (struct t *) (idx * 4 + transfer.3);
}
bar1 (ptr);
L.11:;
D.1991 = idx == D.1981;
idx = idx + 1;
if (D.1991) goto L.12;
}
}
}
L.12:;
}
goto L.9;
}
L.9:;
L.8:;
}
Rouson, Damian - Aug. 14, 2012, 1:11 a.m.
Hi Tobias,

Thanks for your work on this.  This is a big step.  I would add to your
list the following:

(4) If the entity is of extended type and the parent type has a component
that is finalizable, the parent component's component is finalized.

In ForTrilnos, we need for this to happen even when the parent is abstract
but has a finalizable component.  So far, the IBM, NAG, and Cray compilers
support this use case and we've had enough dialogue with committee members
that I'm confident it's required by the standard, although I can't cite
the specific part of the standard that requires it.

Please copy my staff member Karla Morris on any replies.  Thanks again!

Damian


On 8/13/12 1:05 PM, "Tobias Burnus" <burnus@net-b.de> wrote:

>Dear all,
>
>Attached is the first part of a patch which will implement finalization
>support and polymorphic freeing in gfortran.
>
>
>It addresses two needs:
>
>a) For polymorphic ("CLASS") variables, allocatable components have to
>be freed; however, at compile time only the allocatable components of
>the declared type are known ­ and the dynamic type might have more
>
>b) Fortran 2003 allows finalization subroutines ("FINAL", destructors),
>which can be elemental, scalar or for a given rank (any array type is
>allowed). Those should be called for DEALLOCATE, leaving the scope
>(unless saved), intrinsic assignment and with intent(out).
>
>
>The finalization is done as follows (F2008, "4.5.6.2 The finalization
>process")
>
>"(1) If the dynamic type of the entity has a final subroutine whose
>dummy argument has the same kind type parameters and rank as the entity
>being finalized, it is called with the entity as an actual argument.
>Otherwise, if there is an elemental final subroutine whose dummy
>argument has the same kind type parameters as the entity being
>finalized, it is called with the entity as an actual argument.
>Otherwise, no subroutine is called at this point.
>
>"(2) All finalizable components that appear in the type definition are
>finalized in a processor-dependent order. If the entity being finalized
>is an array, each finalizable component of each element of that entity
>is finalized separately.
>
>"(3) If the entity is of extended type and the parent type is
>finalizable, the parent component is finalized."
>
>
>The idea is to create a wrapper function which handles those steps - and
>attach a reference to the dynamic type (i.e. add it via proc-pointer to
>the vtable). Additionally, the wrapper can be directly called for TYPE.
>
>
>The attached patch implements the generation of the wrapper subroutine;
>it does not yet implement the actual calls. The wrapper is generated on
>Fortran AST level and creates code similar to
>
>subroutine final_wrapper_for_type_t (array)
>type(t), intent(inout) :: array(..)
>integer, pointer :: ptr
>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, c_ptr), ptr)
>call elemental_final (ptr)
>end do
>end select
>
>! For all noninherited allocatable components, call
>! DEALLOCATE(array(:)%comp, stat=ignore)
>! scalarized as above
>
>call final_wrapper_of_parent (array(...)%parent)
>end subroutine final_wrapper_for_type_t
>
>
>Note 1: The call to the parent type requires packing support for
>assumed-rank arrays, which has not yet been implemented (also required
>for TS29113, though not for this usage). That is, without further
>patches, the wrapper will only work for scalars or if the parent has no
>wrapper subroutine.
>
>Note 2: The next step will be to add the calls to the wrapper, starting
>with an explicit DEALLOCATE.
>
>
>I intent to commit the patch, when approved, without allowing FINAL at
>resolution time; that way there is no false impression that finalization
>actually works.
>
>Build and regtested on x86-64-gnu-linux.
>OK for the trunk?
>
>* * *
>
>Note: The patch will break gfortran's OOP ABI. It does so by adding
>"_final" to the virtual table (vtab).
>
>I think breaking the ABI for this functionality is unavoidable. The ABI
>change only affects code which uses the CLASS (polymorphic variables)
>and the issue only raises if one mixes old with new code for the same
>derived type. However, if one does so (e.g. by incomplete
>recompilation), segfaults and similar issues will occur. Hence, I am
>considering to bump the .mod version; that will effectively force a
>recompilation and thus avoid the issue. The down side is that it will
>also break packages (e.g. of Linux distributions) which ship .mod files
>(sorry!). What do you think?
>
>I think it could then be combined with Janus' proc-pointer patch, which
>changes the assembler name of (non-Bind(C)) procedure pointers, declared
>at module level. Again, by forcing recompilation, the .mod version bump
>should ensure that users don't see the ABI breakage. His patch is at
>http://gcc.gnu.org/ml/fortran/2012-04/msg00033.html (I think is okay,
>but I believe it has not yet been reviewed.)
>
>Tobias
>
>PS: I used the following test case to test whether the wrapper
>generation and scalarization works; it properly prints 11,22,33,44,55,66
>and also the dump looks okay for various versions.
>
>The scalarization code should work relatively well; there is only one
>call to an external function: For SIZE gfortran - for what ever reason -
>doesn't generate inline code, but calls libgfortran.
>
>
>But now the test code:
>
>module m
>type tt
>end type tt
>
>type t
>! type(tt), allocatable :: comp1
>integer :: val
>contains
>final bar1
>end type t
>
>type t1t
>! type(tt), allocatable :: comp1
>integer :: val
>!contains
>! final bar1
>end type t1t
>
>type, extends(t) :: t2
>type(tt), allocatable :: comp2
>contains
>final bar2
>end type t2
>
>class(t), allocatable, save :: a
>class(t2), allocatable, save :: b
>
>contains
>impure elemental subroutine bar1(x)
>! subroutine bar1(x)
>type(t), intent(inout) :: x!(:)
>print *, 'bar1, ....'
>print *, '..........', x%val
>end subroutine bar1
>subroutine bar2(y)
>type(t2),intent(inout) :: y(:,:)
>end subroutine bar2
>end
>
>use m
>use iso_c_binding
>type(t1t) ::x(3,2)
>
>interface
>subroutine fini(x) bind(C,name="__m_MOD___final_m_T")
>type(*) :: x(..)
>end subroutine
>end interface
>
>x%val = reshape([11,22,33,44,55,66],shape(x))
>print *, storage_size(x)
>call fini(x)
>end
>
>
>And one example for a dump:
>
>__final_m_T (struct array7_t & restrict array)
>{
>integer(kind=8) idx;
>integer(kind=8) nelem;
>struct t * ptr;
>
>{
>struct array7_t * D.1977;
>
>D.1977 = (struct array7_t *) array;
>nelem = (integer(kind=8)) (integer(kind=4)) _gfortran_size0 (D.1977) + -1;
>}
>switch ((integer(kind=4)) array->dtype & 7)
>{
>default:;
>{
>integer(kind=8) D.1981;
>
>D.1981 = nelem;
>idx = 0;
>if (idx <= D.1981)
>{
>while (1)
>{
>{
>logical(kind=4) D.1991;
>
>{
>integer(kind=8) transfer.3;
>integer(kind=8) D.1989;
>integer(kind=8) D.1988;
>static integer(kind=8) C.1987 = 0;
>void * D.1986;
>void * D.1985;
>integer(kind=8) D.1984;
>
>D.1985 = (void *) array->data;
>D.1986 = D.1985;
>D.1984 = 8;
>D.1988 = 8;
>__builtin_memcpy ((void *) &transfer.3, (void *) &D.1986, MAX_EXPR
><MIN_EXPR <D.1988, D.1984>, 0>);
>ptr = (struct t *) (idx * 4 + transfer.3);
>}
>bar1 (ptr);
>L.11:;
>D.1991 = idx == D.1981;
>idx = idx + 1;
>if (D.1991) goto L.12;
>}
>}
>}
>L.12:;
>}
>goto L.9;
>}
>L.9:;
>L.8:;
>}
Tobias Burnus - Aug. 14, 2012, 5:55 a.m.
Hi Damian, dear all,

Rouson, Damian wrote:
> Thanks for your work on this.  This is a big step.  I would add to your
> list the following:
>
> (4) If the entity is of extended type and the parent type has a component
> that is finalizable, the parent component's component is finalized.

I believe that's already covered by (3) which invokes (1) for the parent 
type – and handles the parent's components via (2). (Besides, in the 
standard is not much more than (1)–(3); thus, if it weren't implied by 
those, it likely wouldn't be part of the standard at all.)

> In ForTrilnos, we need for this to happen even when the parent is abstract
> but has a finalizable component.

I think that's (mostly) handled via the current wrapper subroutine (i.e. 
the finalizer of an allocatable component, which has been added in an 
abstract type, is finalized).

However, I think there are two issues with the current patch:

(a) If an abstract type has itself finalizer, it is currently not 
called. (Only its components are finalized)
(b) The current patch doesn't finalize nonallocatable [nonpointer] 
components, but those might also have a finalizer.

Thanks for your comments.

Tobias

> On 8/13/12 1:05 PM, "Tobias Burnus" <burnus@net-b.de> wrote:
>> The finalization is done as follows (F2008, "4.5.6.2 The finalization
>> process")
>>
>> "(1) If the dynamic type of the entity has a final subroutine whose
>> dummy argument has the same kind type parameters and rank as the entity
>> being finalized, it is called with the entity as an actual argument.
>> Otherwise, if there is an elemental final subroutine whose dummy
>> argument has the same kind type parameters as the entity being
>> finalized, it is called with the entity as an actual argument.
>> Otherwise, no subroutine is called at this point.
>>
>> "(2) All finalizable components that appear in the type definition are
>> finalized in a processor-dependent order. If the entity being finalized
>> is an array, each finalizable component of each element of that entity
>> is finalized separately.
>>
>> "(3) If the entity is of extended type and the parent type is
>> finalizable, the parent component is finalized."

Patch

2012-08-13  Alessandro Fanfarillo  <fanfarillo.gcc@gmail.com>
            Tobias Burnus  <burnus@net-b.de>

	PR fortran/37336
	* class.c (gfc_build_class_symbol): Defer creation of the vtab
	if the DT has finalizers.
	(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.

2012-08-13  Alessandro Fanfarillo  <fanfarillo.gcc@gmail.com>
            Tobias Burnus  <burnus@net-b.de>

	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..b263372 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,633 @@  copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype)
 }
 
 
+/* Call DEALLOCATE for the passed component - or if it is a nonallocatable,
+   nonpointer derived type with allocatable components, DEALLOCATE its
+   allocatable components instead.
+   Either of the two 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
+    {
+      gfc_component *c;
+
+      gcc_assert (comp->attr.alloc_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->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, false);
+  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;
+
+  if (derived->attr.abstract)
+    {
+      vtab_final->initializer = gfc_get_null_expr (NULL);
+      return;
+    }
+
+  /* Search for the ancestor's finalizers. */
+  if (derived->attr.extension && derived->components
+      && !derived->components->ts.u.derived->attr.abstract)
+    {
+      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
+	  && !derived->components->ts.u.derived->attr.abstract)
+	continue;
+
+      if (comp->ts.type != BT_CLASS && !comp->attr.pointer
+	  && (comp->attr.alloc_comp || comp->attr.allocatable))
+	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.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->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;
+  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;
+	  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;
+	  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;
+	  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;
+	  gfc_set_sym_referenced (ptr);
+	  gfc_commit_symbol (ptr);
+	}
+
+      gfc_get_symbol ("ignore", sub_ns, &stat);
+      stat->attr.flavor = FL_VARIABLE;
+      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
+	      && !derived->components->ts.u.derived->attr.abstract)
+	    continue;
+
+	  if ((comp->ts.type != BT_CLASS && !comp->attr.pointer
+	       && (comp->attr.alloc_comp || comp->attr.allocatable))
+	      || (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 +1363,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];
@@ -912,6 +1544,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 681dc8d..ac776bf 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/resolve.c b/gcc/fortran/resolve.c
index c5810b2..0804a6c 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -11187,10 +11187,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;
 }
 
@@ -12289,6 +12286,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.  */
@@ -12309,10 +12310,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;
 }
 
@@ -12642,11 +12639,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" }