Patchwork [Fortran] No-op Patch - a.k.a. FINAL wrapper update

login
register
mail settings
Submitter Tobias Burnus
Date Nov. 27, 2012, 6:29 p.m.
Message ID <50B5067B.9070005@net-b.de>
Download mbox | patch
Permalink /patch/202278/
State New
Headers show

Comments

Tobias Burnus - Nov. 27, 2012, 6:29 p.m.
Dear all,

effectively, this patch doesn't do anything. Except, it updates the – 
deactivated – finalization wrapper.


Note: This patch does not include any code to actually call the 
finalization wrapper. Nor is the modified code ever called in gfortran. 
However, that patch paves the road to a proper finalization (and 
polymorphic deallocation) support. When I mention below that I tested 
the patch: That was with the larger but incomplete 
final-2012-11-27-v2.diff patch, available at 
https://userpage.physik.fu-berlin.de/~tburnus/final/ Note that the patch 
there has known issues and does not incorporate all of Janus changes.


Changes relative to the trunk:

* Properly handles coarray components: Those may not be finalized for 
intrinsic assignment; with this patch there is now a generated "IF" 
condition to ensure this in the wrapper.

* While arrays arguments to the wrapper have to be contiguous, the new 
version takes a "stride" argument which allows noncontiguity in the 
lowest dimension. That is: One can pass a contiguous array directly to 
the parent's finalizer even if it then isn't anymore contiguous (for the 
parent type). If the finalizers are all elemental (or scalar), no 
copy-in/copy-out is needed. However, if it is passed to an array final 
subroutine, the array is packed using the following code:

if (stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
|| 0 == STORAGE_SIZE (array)) then
call final_rank3 (array)
else
block
type(t) :: tmp(shape (array))

do i = 0, size (array)-1
addr = transfer (c_loc (array), addr) + i * stride
call c_f_pointer (transfer (addr, cptr), ptr)

addr = transfer (c_loc (tmp), addr)
+ i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
call c_f_pointer (transfer (addr, cptr), ptr2)
ptr2 = ptr
end do
call final_rank3 (tmp)
end block
end if


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

Tobias

PS: I don't know when I will have time to continue working on the patch. 
The next steps from my side are: First, submit some smaller bits from 
the final-2012-11-27-v2.diff patch, even if they will be unused. 
Secondly, do some cleanup and fix a few issues and merge Janus' patch. 
(My patch is based on the 2012-10-26 version of the patch, Janus' latest 
patch was 2012-11-04.) At that point, one might consider enabling the 
FINAL feature partially (e.g. only polymorphic deallocation by not 
allowing FINAL) or fully.

PPS: The patch was successfully tested with the following test case (and 
some small variations of it):

module m
type t
integer :: i
contains
final :: fini
end type t
type, extends(t) :: t2
integer :: j
contains
final :: fini2
end type t2
contains
subroutine fini(x)
! type(t), intent(in) :: x(:,:)
type(t), intent(inout) :: x(:,:)
print *, 'SHAPE:', shape(x)
print *, x
end subroutine fini
impure elemental subroutine fini2(x)
type(t2), intent(inout) :: x
print *, 'FINI2 - elemental: ', x%i
x%i = x%i+10*x%i
end subroutine fini2
end module m

use m
class(t2), allocatable :: x(:,:)
allocate(t2 :: x(2,3))
x(:,:)%i = reshape([1,2,3,4,5,6],[2,3])
print *, 'HELLO: ', x%i
deallocate(x)
end
Janus Weil - Nov. 29, 2012, 10:51 p.m.
Hi Tobias,

> effectively, this patch doesn't do anything. Except, it updates the –
> deactivated – finalization wrapper.
>
>
> Note: This patch does not include any code to actually call the finalization
> wrapper. Nor is the modified code ever called in gfortran. However, that
> patch paves the road to a proper finalization (and polymorphic deallocation)
> support. When I mention below that I tested the patch: That was with the
> larger but incomplete final-2012-11-27-v2.diff patch, available at
> https://userpage.physik.fu-berlin.de/~tburnus/final/ Note that the patch
> there has known issues and does not incorporate all of Janus changes.

one thing that I do not like about your patch is the modification of
"gfc_find_derived_vtab": You create two versions of it, one of which
creates the vtab if it does not exist, while the other version does
not do this. In short: I think this is not needed (it was removed in
my version of the FINAL patch). Or can you explain to me why this
would be necessary?

[Moreover, the problem is that your new "gfc_find_derived_vtab"
behaves different from the old one but has the same name, while your
new "gfc_get_derived_vtab" behaves like the old
"gfc_find_derived_vtab". Therefore, the places where you change the
behavior by keeping the call to "gfc_find_derived_vtab" are not
visible in the patch.]

Cheers,
Janus
Tobias Burnus - Nov. 30, 2012, 12:32 a.m.
Am 29.11.2012 23:51, schrieb Janus Weil:
> one thing that I do not like about your patch is the modification of 
> "gfc_find_derived_vtab": You create two versions of it, one of which 
> creates the vtab if it does not exist, while the other version does 
> not do this. [...] can you explain to me why this would be necessary?

Well, strictly speaking it is not necessary. However, I use it in the 
to-be-submitted calling part of the patch:

           else if (al->expr->ts.type == BT_DERIVED)
             {
               gfc_symbol *vtab = gfc_find_derived_vtab 
(al->expr->ts.u.derived);
               if (vtab)

Here, I do not want to force the generation of a vtab which wouldn't 
otherwise exist. Otherwise, one had to at least guard it by checks for 
nonextensible derived types (sequence, bind(C)).

> [Moreover, the problem is that your new "gfc_find_derived_vtab" 
> behaves different from the old one but has the same name, while your 
> new "gfc_get_derived_vtab" behaves like the old "gfc_find_derived_vtab".

That's because of the bad choice of the current name. The other "find" 
functions do not generate the symbol if it does not exist, the "get" 
functions do. But otherwise I concur that changing the name is confusing.

> Therefore, the places where you change the behavior by keeping the 
> call to "gfc_find_derived_vtab" are not visible in the patch.

That should not happen. When I created the patch, I first renamed all 
existing versions, though it seems as if I there are currently three new 
ones which the current patch misses.

However, if you insist on the current meaning, can you provide a good 
name? Otherwise, I could use gfc_really_find_derived_vtab ;-)

Tobias
Janus Weil - Nov. 30, 2012, 10:22 a.m.
Hi,

>> one thing that I do not like about your patch is the modification of
>> "gfc_find_derived_vtab": You create two versions of it, one of which creates
>> the vtab if it does not exist, while the other version does not do this.
>> [...] can you explain to me why this would be necessary?
>
>
> Well, strictly speaking it is not necessary. However, I use it in the
> to-be-submitted calling part of the patch:
>
>           else if (al->expr->ts.type == BT_DERIVED)
>             {
>               gfc_symbol *vtab = gfc_find_derived_vtab
> (al->expr->ts.u.derived);
>               if (vtab)
>
> Here, I do not want to force the generation of a vtab which wouldn't
> otherwise exist. Otherwise, one had to at least guard it by checks for
> nonextensible derived types (sequence, bind(C)).

I don't think it is a good idea to base the decision whether to call a
finalizer on the presence of a vtab. In my version of the patch I
introduced a routine 'gfc_is_finalizable' to perform this decision.


>> [Moreover, the problem is that your new "gfc_find_derived_vtab" behaves
>> different from the old one but has the same name, while your new
>> "gfc_get_derived_vtab" behaves like the old "gfc_find_derived_vtab".
>
>
> That's because of the bad choice of the current name. The other "find"
> functions do not generate the symbol if it does not exist, the "get"
> functions do. But otherwise I concur that changing the name is confusing.
>
>
>> Therefore, the places where you change the behavior by keeping the call to
>> "gfc_find_derived_vtab" are not visible in the patch.
>
>
> That should not happen. When I created the patch, I first renamed all
> existing versions, though it seems as if I there are currently three new
> ones which the current patch misses.
>
> However, if you insist on the current meaning, can you provide a good name?
> Otherwise, I could use gfc_really_find_derived_vtab ;-)

I do not oppose to renaming gfc_find_derived_vtab to
gfc_get_derived_vtab. My main point is that we do not need a variant
which only searches for the vtab but does not generate it.

Cheers,
Janus
Janus Weil - Nov. 30, 2012, 10:31 a.m.
2012/11/30 Janus Weil <janus@gcc.gnu.org>:
> Hi,
>
>>> one thing that I do not like about your patch is the modification of
>>> "gfc_find_derived_vtab": You create two versions of it, one of which creates
>>> the vtab if it does not exist, while the other version does not do this.
>>> [...] can you explain to me why this would be necessary?
>>
>>
>> Well, strictly speaking it is not necessary. However, I use it in the
>> to-be-submitted calling part of the patch:
>>
>>           else if (al->expr->ts.type == BT_DERIVED)
>>             {
>>               gfc_symbol *vtab = gfc_find_derived_vtab
>> (al->expr->ts.u.derived);
>>               if (vtab)
>>
>> Here, I do not want to force the generation of a vtab which wouldn't
>> otherwise exist. Otherwise, one had to at least guard it by checks for
>> nonextensible derived types (sequence, bind(C)).
>
> I don't think it is a good idea to base the decision whether to call a
> finalizer on the presence of a vtab. In my version of the patch I
> introduced a routine 'gfc_is_finalizable' to perform this decision.

Forgot to mention: My last version of the patch is available at

http://gcc.gnu.org/ml/fortran/2012-11/msg00009.html


Btw, one prerequisite for the implementation of finalization would be
to have the following bug fixed:

http://gcc.gnu.org/bugzilla/show_bug.cgi?id=55207

(which is about automatic deallocation in the main program).

Cheers,
Janus

Patch

2012-11-27  Tobias Burnus  <burnus@net-b.de>

	PR fortran/37336
	* class.c (find_derived_vtab): New static function.
	(gfc_get_derived_vtab): Renamed from gfc_find_derived_vtab.
	(gfc_find_derived_vtab): New function.
	(gfc_class_null_initializer, get_unique_hashed_string,
	gfc_build_class_symbol, copy_vtab_proc_comps,
	): Use gfc_get_derived_vtab instead
	of gfc_find_derived_vtab.
	(finalizer_insert_packed_call): New static function.
	(finalize_component, generate_finalization_wrapper):
	Fix coarray handling and packing.
	* gfortran.h (gfc_get_derived_vtab): New prototype.
	* check.c (gfc_check_move_alloc): Use it.
	* expr.c (gfc_check_pointer_assign): Ditto.
	* interface.c (compare_parameter): Ditto.
	* iresolve.c (gfc_resolve_extends_type_of): Ditto.
	* trans-decl.c (gfc_get_symbol_decl): Ditto.
	* trans-expr.c (gfc_conv_derived_to_class,
	gfc_trans_class_assign): Ditto.
	* trans-intrinsic.c (conv_intrinsic_move_alloc): Ditto.
	* trans-stmt.c (gfc_trans_allocate,
	gfc_trans_deallocate): Ditto.
	* resolve.c (resolve_typebound_function,
	resolve_typebound_subroutine, resolve_allocate_expr,
	resolve_select_type, gfc_resolve_finalizers,
	resolve_typebound_procedures, resolve_fl_derived): Ditto.
	(resolve_symbol): Return early if attr.artificial.

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index a490238..20d6bbd 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -2801,7 +2801,7 @@  gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
 
   /* CLASS arguments: Make sure the vtab of from is present.  */
   if (to->ts.type == BT_CLASS)
-    gfc_find_derived_vtab (from->ts.u.derived);
+    gfc_get_derived_vtab (from->ts.u.derived);
 
   return SUCCESS;
 }
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 2e347cb..ab3bcc1 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -416,7 +416,7 @@  gfc_class_null_initializer (gfc_typespec *ts)
     {
       gfc_constructor *ctor = gfc_constructor_get();
       if (strcmp (comp->name, "_vptr") == 0)
-	ctor->expr = gfc_lval_expr_from_sym (gfc_find_derived_vtab (ts->u.derived));
+	ctor->expr = gfc_lval_expr_from_sym (gfc_get_derived_vtab (ts->u.derived));
       else
 	ctor->expr = gfc_get_null_expr (NULL);
       gfc_constructor_append (&init->value.constructor, ctor);
@@ -454,7 +454,7 @@  get_unique_hashed_string (char *string, gfc_symbol *derived)
   char tmp[2*GFC_MAX_SYMBOL_LEN+2];
   get_unique_type_string (&tmp[0], derived);
   /* If string is too long, use hash value in hex representation (allow for
-     extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).
+     extra decoration, cf. gfc_build_class_symbol & gfc_get_derived_vtab).
      We need space to for 15 characters "__class_" + symbol name + "_%d_%da",
      where %d is the (co)rank which can be up to n = 15.  */
   if (strlen (tmp) > GFC_MAX_SYMBOL_LEN - 15)
@@ -583,7 +583,7 @@  gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
 	c->ts.u.derived = NULL;
       else
 	{
-	  vtab = gfc_find_derived_vtab (ts->u.derived);
+	  vtab = gfc_get_derived_vtab (ts->u.derived);
 	  gcc_assert (vtab);
 	  c->ts.u.derived = vtab->ts.u.derived;
 	}
@@ -684,7 +684,7 @@  copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype)
   gfc_component *cmp;
   gfc_symbol *vtab;
 
-  vtab = gfc_find_derived_vtab (declared);
+  vtab = gfc_get_derived_vtab (declared);
 
   for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
     {
@@ -731,7 +731,7 @@  has_finalizer_component (gfc_symbol *derived)
 
 static void
 finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
-		    gfc_expr *stat, gfc_code **code)
+		    gfc_symbol *stat, gfc_symbol *fini_coarray, gfc_code **code)
 {
   gfc_expr *e;
   gfc_ref *ref;
@@ -779,12 +779,36 @@  finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
       e->rank = ref->next->u.ar.as->rank;
     }
 
+  /* Call DEALLOCATE (comp, stat=ignore).  */
   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;
+      gfc_code *dealloc, *block = NULL;
+
+      /* Add IF (fini_coarray).  */
+      if (comp->attr.codimension
+	  || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
+	      && CLASS_DATA (comp)->attr.allocatable))
+	{
+	  block = XCNEW (gfc_code);
+	  if (*code)
+	    {
+	      (*code)->next = block;
+	      (*code) = (*code)->next;
+	    }
+	  else
+	      (*code) = block;
+
+	  block->loc = gfc_current_locus;
+	  block->op = EXEC_IF;
+
+	  block->block = XCNEW (gfc_code);
+	  block = block->block;
+	  block->loc = gfc_current_locus;
+	  block->op = EXEC_IF;
+	  block->expr1 = gfc_lval_expr_from_sym (fini_coarray);
+	}
 
       dealloc = XCNEW (gfc_code);
       dealloc->op = EXEC_DEALLOCATE;
@@ -792,9 +816,11 @@  finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
 
       dealloc->ext.alloc.list = gfc_get_alloc ();
       dealloc->ext.alloc.list->expr = e;
+      dealloc->expr1 = gfc_lval_expr_from_sym (stat);
 
-      dealloc->expr1 = stat;
-      if (*code)
+      if (block)
+	block->next = dealloc;
+      else if (*code)
 	{
 	  (*code)->next = dealloc;
 	  (*code) = (*code)->next;
@@ -811,7 +837,7 @@  finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
       gfc_symbol *vtab;
       gfc_component *c;
 
-      vtab = gfc_find_derived_vtab (comp->ts.u.derived);
+      vtab = gfc_get_derived_vtab (comp->ts.u.derived);
       for (c = vtab->ts.u.derived->components; c; c = c->next)
 	if (strcmp (c->name, "_final") == 0)
 	  break;
@@ -839,7 +865,7 @@  finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
       gfc_component *c;
 
       for (c = comp->ts.u.derived->components; c; c = c->next)
-	finalize_component (e, c->ts.u.derived, c, stat, code);
+	finalize_component (e, comp->ts.u.derived, c, stat, fini_coarray, code);
       gfc_free_expr (e);
     }
 }
@@ -847,12 +873,11 @@  finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
 
 /* 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).  */
+		     + idx * stride, c_ptr), ptr).  */
 
 static gfc_code *
 finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr,
-			 gfc_namespace *sub_ns)
+			 gfc_expr *stride, gfc_namespace *sub_ns)
 {
   gfc_code *block;
   gfc_expr *expr, *expr2, *expr3;
@@ -919,40 +944,13 @@  finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr,
   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);
-  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).  */
+  /* Offset calculation: idx * stride (in bytes).  */
   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->value.op.op2 = stride;
   expr3->ts = expr->ts;
 
   /* <array addr> + <offset>.  */
@@ -972,6 +970,265 @@  finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr,
 }
 
 
+/* Insert code of the following form:
+
+   if (stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
+       || 0 == STORAGE_SIZE (array)) then
+     call final_rank3 (array)
+   else
+     block
+       type(t) :: tmp(shape (array))
+
+       do i = 0, size (array)-1
+	 addr = transfer (c_loc (array), addr) + i * stride
+	 call c_f_pointer (transfer (addr, cptr), ptr)
+
+	 addr = transfer (c_loc (tmp), addr)
+			  + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
+	 call c_f_pointer (transfer (addr, cptr), ptr2)
+	 ptr2 = ptr
+       end do
+       call final_rank3 (tmp)
+     end block
+   end if  */
+
+static void
+finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
+			      gfc_symbol *array, gfc_symbol *stride,
+			      gfc_symbol *idx, gfc_symbol *ptr,
+			      gfc_symbol *nelem, gfc_symtree *size_intr,
+			      gfc_namespace *sub_ns)
+{
+  gfc_symbol *tmp_array, *ptr2;
+  gfc_expr *size_expr;
+  gfc_namespace *ns;
+  gfc_iterator *iter;
+  int i;
+
+  block->next = XCNEW (gfc_code);
+  block = block->next;
+  block->loc = gfc_current_locus;
+  block->op = EXEC_IF;
+
+  block->block = XCNEW (gfc_code);
+  block = block->block;
+  block->loc = gfc_current_locus;
+  block->op = EXEC_IF;
+
+  /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE.  */
+  size_expr = gfc_get_expr ();
+  size_expr->where = gfc_current_locus;
+  size_expr->expr_type = EXPR_OP;
+  size_expr->value.op.op = INTRINSIC_DIVIDE;
+
+  /* STORAGE_SIZE (array,kind=c_intptr_t).  */
+  size_expr->value.op.op1 = gfc_get_expr ();
+  size_expr->value.op.op1->where = gfc_current_locus;
+  size_expr->value.op.op1->expr_type = EXPR_FUNCTION;
+  size_expr->value.op.op1->value.function.isym
+               = gfc_intrinsic_function_by_id (GFC_ISYM_STORAGE_SIZE);
+  gfc_get_sym_tree ("storage_size", sub_ns, &size_expr->value.op.op1->symtree,
+  		    false);
+  size_expr->value.op.op1->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+  size_expr->value.op.op1->symtree->n.sym->attr.intrinsic = 1;
+  gfc_commit_symbol (size_expr->value.op.op1->symtree->n.sym);
+  size_expr->value.op.op1->value.function.actual = gfc_get_actual_arglist ();
+  size_expr->value.op.op1->value.function.actual->expr
+               = gfc_lval_expr_from_sym (array);
+  size_expr->value.op.op1->value.function.actual->next = gfc_get_actual_arglist ();
+  size_expr->value.op.op1->value.function.actual->next->expr
+               = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+
+  /* NUMERIC_STORAGE_SIZE.  */
+  size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
+					      gfc_character_storage_size);
+  size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
+  size_expr->ts = size_expr->value.op.op1->ts;
+
+  /* IF condition: stride == size_expr || 0 == size_expr.  */
+  block->expr1 = gfc_get_expr ();
+  block->expr1->expr_type = EXPR_FUNCTION;
+  block->expr1->ts.type = BT_LOGICAL;
+  block->expr1->ts.kind = 4;
+  block->expr1->expr_type = EXPR_OP;
+  block->expr1->where = gfc_current_locus;
+
+  block->expr1->value.op.op = INTRINSIC_OR;
+
+  /* stride == size_expr */
+  block->expr1->value.op.op1 = gfc_get_expr ();
+  block->expr1->value.op.op1->expr_type = EXPR_FUNCTION;
+  block->expr1->value.op.op1->ts.type = BT_LOGICAL;
+  block->expr1->value.op.op1->ts.kind = 4;
+  block->expr1->value.op.op1->expr_type = EXPR_OP;
+  block->expr1->value.op.op1->where = gfc_current_locus;
+  block->expr1->value.op.op1->value.op.op = INTRINSIC_EQ;
+  block->expr1->value.op.op1->value.op.op1 = gfc_lval_expr_from_sym (stride);
+  block->expr1->value.op.op1->value.op.op2 = size_expr;
+
+  /* 0 == size_expr */
+  block->expr1->value.op.op2 = gfc_get_expr ();
+  block->expr1->value.op.op2->expr_type = EXPR_FUNCTION;
+  block->expr1->value.op.op2->ts.type = BT_LOGICAL;
+  block->expr1->value.op.op2->ts.kind = 4;
+  block->expr1->value.op.op2->expr_type = EXPR_OP;
+  block->expr1->value.op.op2->where = gfc_current_locus;
+  block->expr1->value.op.op2->value.op.op = INTRINSIC_EQ;
+  block->expr1->value.op.op2->value.op.op1 =
+			gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+  block->expr1->value.op.op2->value.op.op2 = gfc_copy_expr (size_expr);
+
+  /* IF body: call final subroutine.  */
+  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);
+
+  /* ELSE.  */
+
+  block->block = XCNEW (gfc_code);
+  block = block->block;
+  block->loc = gfc_current_locus;
+  block->op = EXEC_IF;
+
+  block->next = XCNEW (gfc_code);
+  block = block->next;
+
+  /* BLOCK ... END BLOCK.  */
+  block->op = EXEC_BLOCK;
+  block->loc = gfc_current_locus;
+  ns = gfc_build_block_ns (sub_ns);
+  block->ext.block.ns = ns;
+  block->ext.block.assoc = NULL;
+
+  gfc_get_symbol ("ptr2", ns, &ptr2);
+  ptr2->ts.type = BT_DERIVED;
+  ptr2->ts.u.derived = array->ts.u.derived;
+  ptr2->attr.flavor = FL_VARIABLE;
+  ptr2->attr.pointer = 1;
+  ptr2->attr.artificial = 1;
+  gfc_set_sym_referenced (ptr2);
+  gfc_commit_symbol (ptr2);
+
+  gfc_get_symbol ("tmp_array", ns, &tmp_array);
+  tmp_array->ts.type = BT_DERIVED;
+  tmp_array->ts.u.derived = array->ts.u.derived;
+  tmp_array->attr.flavor = FL_VARIABLE;
+  tmp_array->attr.contiguous = 1;
+  tmp_array->attr.dimension = 1;
+  tmp_array->attr.artificial = 1;
+  tmp_array->as = gfc_get_array_spec();
+  tmp_array->attr.intent = INTENT_INOUT;
+  tmp_array->as->type = AS_EXPLICIT;
+  tmp_array->as->rank = fini->proc_tree->n.sym->formal->sym->as->rank;
+
+  for (i = 0; i < tmp_array->as->rank; i++)
+    {
+      gfc_expr *shape_expr;
+      tmp_array->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
+						  NULL, 1);
+      /* SIZE (array, dim=i+1, kind=default_kind).  */
+      shape_expr = gfc_get_expr ();
+      shape_expr->expr_type = EXPR_FUNCTION;
+      shape_expr->value.function.isym
+				= gfc_intrinsic_function_by_id (GFC_ISYM_SIZE);
+      shape_expr->symtree = size_intr;
+      shape_expr->value.function.actual = gfc_get_actual_arglist ();
+      shape_expr->value.function.actual->expr = gfc_lval_expr_from_sym (array);
+      shape_expr->value.function.actual->next = gfc_get_actual_arglist ();
+      shape_expr->value.function.actual->next->expr
+		= gfc_get_int_expr (gfc_default_integer_kind, NULL, i+1);
+      shape_expr->value.function.actual->next->next = gfc_get_actual_arglist ();
+      shape_expr->value.function.actual->next->next->expr
+		= gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
+      shape_expr->ts = shape_expr->value.function.isym->ts;
+
+      tmp_array->as->upper[i] = shape_expr;
+    }
+  gfc_set_sym_referenced (tmp_array);
+  gfc_commit_symbol (tmp_array);
+
+  /* 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 = XCNEW (gfc_code);
+  ns->code = block;
+  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 * stride, c_ptr), ptr).  */
+  block->block->next = finalization_scalarizer (idx, array, ptr,
+						gfc_lval_expr_from_sym (stride),
+						sub_ns);
+  block->block->next->next = finalization_scalarizer (idx, tmp_array, ptr2,
+						      gfc_copy_expr (size_expr),
+						      sub_ns);
+  /* ptr2 = ptr.  */
+  block->block->next->next->next = XCNEW (gfc_code);
+  block->block->next->next->next->op = EXEC_ASSIGN;
+  block->block->next->next->next->loc = gfc_current_locus;
+  block->block->next->next->next->expr1 = gfc_lval_expr_from_sym (ptr2);
+  block->block->next->next->next->expr2 = gfc_lval_expr_from_sym (ptr);
+
+  block->next  = XCNEW (gfc_code);
+  block = block->next;
+  block->op = EXEC_CALL;
+  block->loc = gfc_current_locus;
+  block->symtree = fini->proc_tree;
+  block->resolved_sym = fini->proc_tree->n.sym;
+  block->ext.actual = gfc_get_actual_arglist ();
+  block->ext.actual->expr = gfc_lval_expr_from_sym (tmp_array);
+
+  if (fini->proc_tree->n.sym->formal->sym->attr.intent == INTENT_IN)
+    return;
+
+  /* Copy back.  */
+
+  /* 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 * stride, c_ptr), ptr).  */
+  block->block->next = finalization_scalarizer (idx, array, ptr,
+						gfc_lval_expr_from_sym (stride),
+						sub_ns);
+  block->block->next->next = finalization_scalarizer (idx, tmp_array, ptr2,
+						      gfc_copy_expr (size_expr),
+						      sub_ns);
+  /* ptr = ptr2.  */
+  block->block->next->next->next = XCNEW (gfc_code);
+  block->block->next->next->next->op = EXEC_ASSIGN;
+  block->block->next->next->next->loc = gfc_current_locus;
+  block->block->next->next->next->expr1 = gfc_lval_expr_from_sym (ptr);
+  block->block->next->next->next->expr2 = gfc_lval_expr_from_sym (ptr2);
+}
+
+
 /* Generate the finalization/polymorphic freeing wrapper subroutine for the
    derived type "derived". The function first calls the approriate FINAL
    subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
@@ -979,19 +1236,28 @@  finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr,
    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.  */
+   will contain a NULL pointer.
+   The generated function has the form
+     _final(assumed-rank array, stride, skip_corarray)
+   where the array has to be contiguous (except of the lowest dimension). The
+   stride (in bytes) is used to allow different sizes for ancestor types by
+   skipping over the additionally added components in the scalarizer. If
+   "fini_coarray" is false, coarray components are not finalized to allow for
+   the correct semantic with intrinsic assignment.  */
 
 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 *final, *array, *nelem, *fini_coarray, *stride;
   gfc_symbol *ptr = NULL, *idx = NULL;
+  gfc_symtree *size_intr;
   gfc_component *comp;
   gfc_namespace *sub_ns;
   gfc_code *last_code;
   char name[GFC_MAX_SYMBOL_LEN+1];
   bool finalizable_comp = false;
+  bool expr_null_wrapper = false;
   gfc_expr *ancestor_wrapper = NULL;
 
   /* Search for the ancestor's finalizers. */
@@ -1002,7 +1268,7 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
       gfc_symbol *vtab;
       gfc_component *comp;
 
-      vtab = gfc_find_derived_vtab (derived->components->ts.u.derived);
+      vtab = gfc_get_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')
 	  {
@@ -1011,40 +1277,44 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
 	  }
     }
 
-  /* No wrapper of the ancestor and no own FINAL subroutines and
-     allocatable components: Return a NULL() expression.  */
+  /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
+     components: Return a NULL() expression; we defer this a bit to have have
+     an interface declaration.  */
   if ((!ancestor_wrapper || ancestor_wrapper->expr_type == EXPR_NULL)
       && !derived->attr.alloc_comp
       && (!derived->f2k_derived || !derived->f2k_derived->finalizers)
       && !has_finalizer_component (derived))
-    {
-      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)
+    expr_null_wrapper = true;
+  else
+    /* 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->ts.type == BT_DERIVED
-		  && has_finalizer_component (comp->ts.u.derived))))
-	finalizable_comp = true;
-      else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
-	       && CLASS_DATA (comp)->attr.allocatable)
-	finalizable_comp = true;
-    }
+	if (comp->ts.type != BT_CLASS && !comp->attr.pointer
+	    && (comp->attr.allocatable
+		|| (comp->ts.type == BT_DERIVED
+		    && (comp->ts.u.derived->attr.alloc_comp
+			|| has_finalizer_component (comp->ts.u.derived)
+			|| (comp->ts.u.derived->f2k_derived
+			    && comp->ts.u.derived->f2k_derived->finalizers)))))
+	  finalizable_comp = true;
+	else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
+		 && CLASS_DATA (comp)->attr.allocatable)
+	  finalizable_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)
-      && !finalizable_comp)
+  if (!expr_null_wrapper && !finalizable_comp
+      && (!derived->f2k_derived || !derived->f2k_derived->finalizers))
     {
+      gcc_assert (ancestor_wrapper && ancestor_wrapper->ref == NULL
+	          && ancestor_wrapper->expr_type == EXPR_VARIABLE);
       vtab_final->initializer = gfc_copy_expr (ancestor_wrapper);
+      vtab_final->ts.interface = vtab_final->initializer->symtree->n.sym;
       return;
     }
 
@@ -1057,12 +1327,13 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
      3. Call the ancestor's finalizer.  */
 
   /* Declare the wrapper function; it takes an assumed-rank array
-     as argument. */
+     and a VALUE logical as arguments. */
 
   /* Set up the namespace.  */
   sub_ns = gfc_get_namespace (ns, 0);
   sub_ns->sibling = ns->contained;
-  ns->contained = sub_ns;
+  if (!expr_null_wrapper)
+    ns->contained = sub_ns;
   sub_ns->resolved = 1;
 
   /* Set up the procedure symbol.  */
@@ -1070,13 +1341,17 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   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.function = 1;
+  final->attr.pure = 0;
+  final->result = final;
+  final->ts.type = BT_INTEGER;
+  final->ts.kind = 4;
   final->attr.artificial = 1;
-  final->attr.if_source = IFSRC_DECL;
+  final->attr.if_source = expr_null_wrapper ? IFSRC_IFBODY : IFSRC_DECL;
   if (ns->proc_name->attr.flavor == FL_MODULE)
     final->module = ns->proc_name->name;
   gfc_set_sym_referenced (final);
+  gfc_commit_symbol (final);
 
   /* Set up formal argument.  */
   gfc_get_symbol ("array", sub_ns, &array);
@@ -1096,6 +1371,50 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   final->formal->sym = array;
   gfc_commit_symbol (array);
 
+  /* Set up formal argument.  */
+  gfc_get_symbol ("stride", sub_ns, &stride);
+  stride->ts.type = BT_INTEGER;
+  stride->ts.kind = gfc_index_integer_kind;
+  stride->attr.flavor = FL_VARIABLE;
+  stride->attr.dummy = 1;
+  stride->attr.value = 1;
+  stride->attr.artificial = 1;
+  gfc_set_sym_referenced (stride);
+  final->formal->next = gfc_get_formal_arglist ();
+  final->formal->next->sym = stride;
+  gfc_commit_symbol (stride);
+
+  /* Set up formal argument.  */
+  gfc_get_symbol ("fini_coarray", sub_ns, &fini_coarray);
+  fini_coarray->ts.type = BT_LOGICAL;
+  fini_coarray->ts.kind = 4;
+  fini_coarray->attr.flavor = FL_VARIABLE;
+  fini_coarray->attr.dummy = 1;
+  fini_coarray->attr.value = 1;
+  fini_coarray->attr.artificial = 1;
+  gfc_set_sym_referenced (fini_coarray);
+  final->formal->next->next = gfc_get_formal_arglist ();
+  final->formal->next->next->sym = fini_coarray;
+  gfc_commit_symbol (fini_coarray);
+
+  /* Return with a NULL() expression but with an interface which has
+     the formal arguments.  */
+  if (expr_null_wrapper)
+    {
+      vtab_final->initializer = gfc_get_null_expr (NULL);
+      vtab_final->ts.interface = final;
+      return;
+    }
+
+
+  /* Set return value to 0.  */
+  last_code = XCNEW (gfc_code);
+  last_code->op = EXEC_ASSIGN;
+  last_code->loc = gfc_current_locus;
+  last_code->expr1 = gfc_lval_expr_from_sym (final);
+  last_code->expr2 = gfc_get_int_expr (4, NULL, 0);
+  sub_ns->code = last_code;
+
   /* Obtain the size (number of elements) of "array" MINUS ONE,
      which is used in the scalarization.  */
   gfc_get_symbol ("nelem", sub_ns, &nelem);
@@ -1107,7 +1426,8 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   gfc_commit_symbol (nelem);
 
   /* Generate: nelem = SIZE (array) - 1.  */
-  last_code = XCNEW (gfc_code);
+  last_code->next = XCNEW (gfc_code);
+  last_code = last_code->next;
   last_code->op = EXEC_ASSIGN;
   last_code->loc = gfc_current_locus;
 
@@ -1126,6 +1446,7 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
 	= gfc_intrinsic_function_by_id (GFC_ISYM_SIZE);
   gfc_get_sym_tree ("size", sub_ns, &last_code->expr2->value.op.op1->symtree,
 		    false);
+  size_intr = last_code->expr2->value.op.op1->symtree;
   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);
@@ -1154,10 +1475,11 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
 
      select case (rank (array))
        case (3)
+         ! If needed, the array is packed
 	 call final_rank3 (array)
        case default:
 	 do i = 0, size (array)-1
-	   addr = transfer (c_loc (array), addr) + i * STORAGE_SIZE (array)
+	   addr = transfer (c_loc (array), addr) + i * stride
 	   call c_f_pointer (transfer (addr, cptr), ptr)
 	   call elemental_final (ptr)
 	 end do
@@ -1168,6 +1490,23 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
       gfc_finalizer *fini, *fini_elem = NULL;
       gfc_code *block = NULL;
 
+      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);
+
       /* SELECT CASE (RANK (array)).  */
       last_code->next = XCNEW (gfc_code);
       last_code = last_code->next;
@@ -1221,14 +1560,20 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
 	  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);
+	  /* CALL fini_rank (array) - possibly with packing.  */
+          if (fini->proc_tree->n.sym->formal->sym->attr.dimension)
+	    finalizer_insert_packed_call (block, fini, array, stride, idx, ptr,
+					  nelem, size_intr, sub_ns);
+	  else
+	    {
+	      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.  */
@@ -1251,23 +1596,6 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
 	  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);
@@ -1284,8 +1612,11 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
 
 	  /* 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);
+			       + idx * stride, c_ptr), ptr).  */
+	  block->block->next
+			= finalization_scalarizer (idx, array, ptr,
+						   gfc_lval_expr_from_sym (stride),
+						   sub_ns);
 	  block = block->block->next;
 
 	  /* CALL final_elemental (array).  */
@@ -1356,8 +1687,11 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
 
       /* 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);
+			   + idx * stride, c_ptr), ptr).  */
+      last_code->block->next
+		= finalization_scalarizer (idx, array, ptr,
+					   gfc_lval_expr_from_sym (stride),
+					   sub_ns);
       block = last_code->block->next;
 
       for (comp = derived->components; comp; comp = comp->next)
@@ -1367,7 +1701,7 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
 	    continue;
 
 	  finalize_component (gfc_lval_expr_from_sym (ptr), derived, comp,
-			      gfc_lval_expr_from_sym (stat), &block);
+			      stat, fini_coarray, &block);
 	  if (!last_code->block->next)
 	    last_code->block->next = block;
 	}
@@ -1386,9 +1720,13 @@  generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
 
       last_code->ext.actual = gfc_get_actual_arglist ();
       last_code->ext.actual->expr = gfc_lval_expr_from_sym (array);
+      last_code->ext.actual->next = gfc_get_actual_arglist ();
+      last_code->ext.actual->next->expr = gfc_lval_expr_from_sym (stride);
+      last_code->ext.actual->next->next = gfc_get_actual_arglist ();
+      last_code->ext.actual->next->next->expr
+			= gfc_lval_expr_from_sym (fini_coarray);
     }
 
-  gfc_commit_symbol (final);
   vtab_final->initializer = gfc_lval_expr_from_sym (final);
   vtab_final->ts.interface = final;
 }
@@ -1419,10 +1757,10 @@  add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype)
 }
 
 
-/* Find (or generate) the symbol for a derived type's vtab.  */
+/* Find or generate the symbol for a derived type's vtab.  */
 
-gfc_symbol *
-gfc_find_derived_vtab (gfc_symbol *derived)
+static gfc_symbol *
+find_derived_vtab (gfc_symbol *derived, bool generate)
 {
   gfc_namespace *ns;
   gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
@@ -1440,7 +1778,7 @@  gfc_find_derived_vtab (gfc_symbol *derived)
   if (ns)
     {
       char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
-      
+
       get_unique_hashed_string (tname, derived);
       sprintf (name, "__vtab_%s", tname);
 
@@ -1451,6 +1789,9 @@  gfc_find_derived_vtab (gfc_symbol *derived)
       if (vtab == NULL)
 	gfc_find_symbol (name, derived->ns, 0, &vtab);
 
+      if (!generate && !vtab)
+       return NULL;
+
       if (vtab == NULL)
 	{
 	  gfc_get_symbol (name, ns, &vtab);
@@ -1464,7 +1805,7 @@  gfc_find_derived_vtab (gfc_symbol *derived)
 	  vtab->attr.access = ACCESS_PUBLIC;
 	  gfc_set_sym_referenced (vtab);
 	  sprintf (name, "__vtype_%s", tname);
-	  
+
 	  gfc_find_symbol (name, ns, 0, &vtype);
 	  if (vtype == NULL)
 	    {
@@ -1509,7 +1850,7 @@  gfc_find_derived_vtab (gfc_symbol *derived)
 	      parent = gfc_get_derived_super_type (derived);
 	      if (parent)
 		{
-		  parent_vtab = gfc_find_derived_vtab (parent);
+		  parent_vtab = gfc_get_derived_vtab (parent);
 		  c->ts.type = BT_DERIVED;
 		  c->ts.u.derived = parent_vtab->ts.u.derived;
 		  c->initializer = gfc_get_expr ();
@@ -1675,6 +2016,20 @@  cleanup:
 }
 
 
+gfc_symbol *
+gfc_find_derived_vtab (gfc_symbol *derived)
+{
+  return find_derived_vtab (derived, false);
+}
+
+
+gfc_symbol *
+gfc_get_derived_vtab (gfc_symbol *derived)
+{
+  return find_derived_vtab (derived, true);
+}
+
+
 /* General worker function to find either a type-bound procedure or a
    type-bound user operator.  */
 
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 211f304..32e8c49 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3571,7 +3571,7 @@  gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
 
   if (lvalue->ts.type == BT_CLASS && rvalue->ts.type == BT_DERIVED)
     /* Make sure the vtab is present.  */
-    gfc_find_derived_vtab (rvalue->ts.u.derived);
+    gfc_get_derived_vtab (rvalue->ts.u.derived);
 
   /* Check rank remapping.  */
   if (rank_remap)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index fabc16a..00f5055 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2956,6 +2956,7 @@  unsigned int gfc_hash_value (gfc_symbol *);
 gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
 				gfc_array_spec **, bool);
 gfc_symbol *gfc_find_derived_vtab (gfc_symbol *);
+gfc_symbol *gfc_get_derived_vtab (gfc_symbol *);
 gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*,
 				      const char*, bool, locus*);
 gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*,
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index d90fc73..d2a4ec9 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1847,7 +1847,7 @@  compare_parameter (gfc_symbol *formal, gfc_expr *actual,
   if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED)
     /* Make sure the vtab symbol is present when
        the module variables are generated.  */
-    gfc_find_derived_vtab (actual->ts.u.derived);
+    gfc_get_derived_vtab (actual->ts.u.derived);
 
   if (actual->ts.type == BT_PROCEDURE)
     {
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 3f981d8..83a896a 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -945,7 +945,7 @@  gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
     gfc_add_vptr_component (a);
   else if (a->ts.type == BT_DERIVED)
     {
-      vtab = gfc_find_derived_vtab (a->ts.u.derived);
+      vtab = gfc_get_derived_vtab (a->ts.u.derived);
       /* Clear the old expr.  */
       gfc_free_ref_list (a->ref);
       memset (a, '\0', sizeof (gfc_expr));
@@ -961,7 +961,7 @@  gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
     gfc_add_vptr_component (mo);
   else if (mo->ts.type == BT_DERIVED)
     {
-      vtab = gfc_find_derived_vtab (mo->ts.u.derived);
+      vtab = gfc_get_derived_vtab (mo->ts.u.derived);
       /* Clear the old expr.  */
       gfc_free_ref_list (mo->ref);
       memset (mo, '\0', sizeof (gfc_expr));
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index f3d3beb..dfa5066 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6214,7 +6214,7 @@  resolve_typebound_function (gfc_expr* e)
       declared = ts.u.derived;
       c = gfc_find_component (declared, "_vptr", true, true);
       if (c->ts.u.derived == NULL)
-	c->ts.u.derived = gfc_find_derived_vtab (declared);
+	c->ts.u.derived = gfc_get_derived_vtab (declared);
 
       if (resolve_compcall (e, &name) == FAILURE)
 	return FAILURE;
@@ -6342,7 +6342,7 @@  resolve_typebound_subroutine (gfc_code *code)
       declared = expr->ts.u.derived;
       c = gfc_find_component (declared, "_vptr", true, true);
       if (c->ts.u.derived == NULL)
-	c->ts.u.derived = gfc_find_derived_vtab (declared);
+	c->ts.u.derived = gfc_get_derived_vtab (declared);
 
       if (resolve_typebound_call (code, &name) == FAILURE)
 	return FAILURE;
@@ -7369,7 +7369,7 @@  resolve_allocate_expr (gfc_expr *e, gfc_code *code)
 	ts = code->expr3->ts;
       else if (code->ext.alloc.ts.type == BT_DERIVED)
 	ts = code->ext.alloc.ts;
-      gfc_find_derived_vtab (ts.u.derived);
+      gfc_get_derived_vtab (ts.u.derived);
       if (dimension)
 	e = gfc_expr_to_initialize (e);
     }
@@ -8567,7 +8567,7 @@  resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
 	  new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
 	  new_st->expr1->value.function.actual->expr->where = code->loc;
 	  gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
-	  vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
+	  vtab = gfc_get_derived_vtab (body->ext.block.case_list->ts.u.derived);
 	  st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
 	  new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
 	  new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
@@ -11290,7 +11290,7 @@  error:
   gfc_error ("Finalization at %L is not yet implemented",
 	     &derived->declared_at);
 
-  gfc_find_derived_vtab (derived);
+  gfc_get_derived_vtab (derived);
   return result;
 }
 
@@ -11850,7 +11850,7 @@  resolve_typebound_procedures (gfc_symbol* derived)
   resolve_bindings_result = SUCCESS;
 
   /* Make sure the vtab has been generated.  */
-  gfc_find_derived_vtab (derived);
+  gfc_get_derived_vtab (derived);
 
   if (derived->f2k_derived->tb_sym_root)
     gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
@@ -12405,7 +12405,7 @@  resolve_fl_derived (gfc_symbol *sym)
       gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true);
       if (vptr->ts.u.derived == NULL)
 	{
-	  gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
+	  gfc_symbol *vtab = gfc_get_derived_vtab (data->ts.u.derived);
 	  gcc_assert (vtab);
 	  vptr->ts.u.derived = vtab->ts.u.derived;
 	}
@@ -12618,6 +12618,9 @@  resolve_symbol (gfc_symbol *sym)
   if (sym->attr.artificial)
     return;
 
+  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
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 3bee178..84cdfa0 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -1206,7 +1206,7 @@  gfc_get_symbol_decl (gfc_symbol * sym)
       gfc_component *c = CLASS_DATA (sym);
       if (!c->ts.u.derived->backend_decl)
 	{
-	  gfc_find_derived_vtab (c->ts.u.derived);
+	  gfc_get_derived_vtab (c->ts.u.derived);
 	  gfc_get_derived_type (sym->ts.u.derived);
 	}
     }
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index d6410d3..3188ee5 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -263,7 +263,7 @@  gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
     {
       /* In this case the vtab corresponds to the derived type and the
 	 vptr must point to it.  */
-      vtab = gfc_find_derived_vtab (e->ts.u.derived);
+      vtab = gfc_get_derived_vtab (e->ts.u.derived);
       gcc_assert (vtab);
       tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
     }
@@ -859,9 +859,9 @@  gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
       gfc_add_vptr_component (lhs);
 
       if (expr2->ts.type == BT_DERIVED)
-	vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
+	vtab = gfc_get_derived_vtab (expr2->ts.u.derived);
       else if (expr2->expr_type == EXPR_NULL)
-	vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
+	vtab = gfc_get_derived_vtab (expr1->ts.u.derived);
       gcc_assert (vtab);
 
       rhs = gfc_get_expr ();
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index e9eb307..3bb6eb3 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -7356,7 +7356,7 @@  conv_intrinsic_move_alloc (gfc_code *code)
 	  else
 	    {
 	      gfc_symbol *vtab;
-	      vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
+	      vtab = gfc_get_derived_vtab (from_expr->ts.u.derived);
 	      gcc_assert (vtab);
 	      tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
 	    }
@@ -7387,7 +7387,7 @@  conv_intrinsic_move_alloc (gfc_code *code)
       else
 	{
 	  gfc_symbol *vtab;
-	  vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
+	  vtab = gfc_get_derived_vtab (from_expr->ts.u.derived);
 	  gcc_assert (vtab);
 	  tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
 	}
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index bdc559b..01431a9 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5099,7 +5099,7 @@  gfc_trans_allocate (gfc_code * code)
 
 	      if (ts->type == BT_DERIVED)
 		{
-		  vtab = gfc_find_derived_vtab (ts->u.derived);
+		  vtab = gfc_get_derived_vtab (ts->u.derived);
 		  gcc_assert (vtab);
 		  gfc_init_se (&lse, NULL);
 		  lse.want_pointer = 1;
@@ -5186,7 +5186,7 @@  gfc_trans_allocate (gfc_code * code)
 		}
 	      else
 		ppc = gfc_lval_expr_from_sym
-				(gfc_find_derived_vtab (rhs->ts.u.derived));
+				(gfc_get_derived_vtab (rhs->ts.u.derived));
 	      gfc_add_component_ref (ppc, "_copy");
 
 	      ppc_code = gfc_get_code ();
@@ -5393,7 +5393,7 @@  gfc_trans_deallocate (gfc_code *code)
 	    {
 	      /* Reset _vptr component to declared type.  */
 	      gfc_expr *rhs, *lhs = gfc_copy_expr (al->expr);
-	      gfc_symbol *vtab = gfc_find_derived_vtab (al->expr->ts.u.derived);
+	      gfc_symbol *vtab = gfc_get_derived_vtab (al->expr->ts.u.derived);
 	      gfc_add_vptr_component (lhs);
 	      rhs = gfc_lval_expr_from_sym (vtab);
 	      tmp = gfc_trans_pointer_assignment (lhs, rhs);