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

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

[Tobias Burnus]

[-- Attachment #1: Type: text/plain, Size: 3101 bytes --]

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

[-- Attachment #2: final-wrapper-update.diff --]
[-- Type: text/x-patch, Size: 44110 bytes --]

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

Re: [Patch, Fortran] No-op Patch - a.k.a. FINAL wrapper update

[Janus Weil]

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

Re: [Patch, Fortran] No-op Patch - a.k.a. FINAL wrapper update

[Tobias Burnus]

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

Re: [Patch, Fortran] No-op Patch - a.k.a. FINAL wrapper update

[Janus Weil]

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

Re: [Patch, Fortran] No-op Patch - a.k.a. FINAL wrapper update

[Janus Weil]

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

Re: [Patch, Fortran] No-op Patch - a.k.a. FINAL wrapper update

[Tobias Burnus]

[-- Attachment #1: Type: text/plain, Size: 759 bytes --]

Am 30.11.2012 11:22, schrieb Janus Weil:
> In my version of the patch I introduced a routine 'gfc_is_finalizable' 
> to perform this decision.

Okay. How about the following patch? It's the same without the renaming.

Build an regtested on x86-64-linux.*
OK for the trunk?

* * *

I will submit your gfc_is_finalizable together with some other auxiliary 
changes after that patch has been accepted.

I know that even with the auxiliary functions added and the updated 
finalization wrapper, it will take some work to get the remaining issues 
fixed. I am not sure that the automatic deallocation in the main program 
is really the most pressing issue with regards to finalization, but it 
surely one of the items.

Tobias

* I really like the GCC Build farm.

[-- Attachment #2: final-wrapper-update-v2.diff --]
[-- Type: text/x-patch, Size: 29749 bytes --]

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

	PR fortran/37336
	* class.c (finalizer_insert_packed_call): New static function.
	(finalize_component, generate_finalization_wrapper):
	Fix coarray handling and packing.

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 2e347cb..1271300 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -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;
@@ -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. */
@@ -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,7 +1757,7 @@ 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)
@@ -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);
 
@@ -1464,7 +1802,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)
 	    {

Re: [Patch, Fortran] No-op Patch - a.k.a. FINAL wrapper update

[Janus Weil]

Hi Tobias,

>> In my version of the patch I introduced a routine 'gfc_is_finalizable' to
>> perform this decision.
>
>
> Okay. How about the following patch? It's the same without the renaming.
>
> Build an regtested on x86-64-linux.*
> OK for the trunk?

Yes, looks ok to me. Thanks for the patch!

Cheers,
Janus

[PATCH,FORTRAN] Fix memory leak in finalization wrappers

[Bernhard Reutner-Fischer]

If a finalization is not required we created a namespace containing
formal arguments for an internal interface definition but never used
any of these. So the whole sub_ns namespace was not wired up to the
program and consequently was never freed. The fix is to simply not
generate any finalization wrappers if we know that it will be unused.
Note that this reverts back to the original r190869
(8a96d64282ac534cb597f446f02ac5d0b13249cc) handling for this case
by reverting this specific part of r194075
(f1ee56b4be7cc3892e6ccc75d73033c129098e87) for PR fortran/37336.

Regtests cleanly, installed to the fortran-fe-stringpool branch, sent
here for reference and later inclusion.
I might plug a few more leaks in preparation of switching to hash-maps.
I fear that the leaks around interfaces are another candidate ;)

Should probably add a tag for the compile-time leak PR68800 shouldn't i.

valgrind summary for e.g.
gfortran.dg/abstract_type_3.f03 and gfortran.dg/abstract_type_4.f03
where ".orig" is pristine trunk and ".mine" contains this fix:

at3.orig.vg:LEAK SUMMARY:
at3.orig.vg-   definitely lost: 8,460 bytes in 11 blocks
at3.orig.vg-   indirectly lost: 13,288 bytes in 55 blocks
at3.orig.vg-     possibly lost: 0 bytes in 0 blocks
at3.orig.vg-   still reachable: 572,278 bytes in 2,142 blocks
at3.orig.vg-        suppressed: 0 bytes in 0 blocks
at3.orig.vg-
at3.orig.vg-Use --track-origins=yes to see where uninitialised values come from
at3.orig.vg-ERROR SUMMARY: 38 errors from 33 contexts (suppressed: 0 from 0)
--
at3.mine.vg:LEAK SUMMARY:
at3.mine.vg-   definitely lost: 344 bytes in 1 blocks
at3.mine.vg-   indirectly lost: 7,192 bytes in 18 blocks
at3.mine.vg-     possibly lost: 0 bytes in 0 blocks
at3.mine.vg-   still reachable: 572,278 bytes in 2,142 blocks
at3.mine.vg-        suppressed: 0 bytes in 0 blocks
at3.mine.vg-
at3.mine.vg-ERROR SUMMARY: 1 errors from 1 contexts (suppressed: 0 from 0)
at3.mine.vg-ERROR SUMMARY: 1 errors from 1 contexts (suppressed: 0 from 0)
at4.orig.vg:LEAK SUMMARY:
at4.orig.vg-   definitely lost: 13,751 bytes in 12 blocks
at4.orig.vg-   indirectly lost: 11,976 bytes in 60 blocks
at4.orig.vg-     possibly lost: 0 bytes in 0 blocks
at4.orig.vg-   still reachable: 572,278 bytes in 2,142 blocks
at4.orig.vg-        suppressed: 0 bytes in 0 blocks
at4.orig.vg-
at4.orig.vg-Use --track-origins=yes to see where uninitialised values come from
at4.orig.vg-ERROR SUMMARY: 18 errors from 16 contexts (suppressed: 0 from 0)
--
at4.mine.vg:LEAK SUMMARY:
at4.mine.vg-   definitely lost: 3,008 bytes in 3 blocks
at4.mine.vg-   indirectly lost: 4,056 bytes in 11 blocks
at4.mine.vg-     possibly lost: 0 bytes in 0 blocks
at4.mine.vg-   still reachable: 572,278 bytes in 2,142 blocks
at4.mine.vg-        suppressed: 0 bytes in 0 blocks
at4.mine.vg-
at4.mine.vg-ERROR SUMMARY: 3 errors from 3 contexts (suppressed: 0 from 0)
at4.mine.vg-ERROR SUMMARY: 3 errors from 3 contexts (suppressed: 0 from 0)

gcc/fortran/ChangeLog:

2018-10-12  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>

	* class.c (generate_finalization_wrapper): Do leak finalization
	wrappers if they will not be used.
	* expr.c (gfc_free_actual_arglist): Formatting fix.
	* gfortran.h (gfc_free_symbol): Pass argument by reference.
	(gfc_release_symbol): Likewise.
	(gfc_free_namespace): Likewise.
	* symbol.c (gfc_release_symbol): Adjust acordingly.
	(free_components): Set procedure pointer components
	of derived types to NULL after freeing.
	(free_tb_tree): Likewise.
	(gfc_free_symbol): Set sym to NULL after freeing.
	(gfc_free_namespace): Set namespace to NULL after freeing.
---
 gcc/fortran/class.c    | 25 +++++++++----------------
 gcc/fortran/expr.c     |  2 +-
 gcc/fortran/gfortran.h |  6 +++---
 gcc/fortran/symbol.c   | 19 ++++++++++---------
 4 files changed, 23 insertions(+), 29 deletions(-)

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 69c95fc5dfa..e0bb381a55f 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -1533,7 +1533,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   gfc_code *last_code, *block;
   const char *name;
   bool finalizable_comp = false;
-  bool expr_null_wrapper = false;
   gfc_expr *ancestor_wrapper = NULL, *rank;
   gfc_iterator *iter;
 
@@ -1561,13 +1560,17 @@ 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; we defer this a bit to have have
+     components: Return a NULL() expression; we defer this a bit to 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))
-    expr_null_wrapper = true;
+    {
+      vtab_final->initializer = gfc_get_null_expr (NULL);
+      gcc_assert (vtab_final->ts.interface == NULL);
+      return;
+    }
   else
     /* Check whether there are new allocatable components.  */
     for (comp = derived->components; comp; comp = comp->next)
@@ -1581,7 +1584,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
 
   /* If there is no new finalizer and no new allocatable, return with
      an expr to the ancestor's one.  */
-  if (!expr_null_wrapper && !finalizable_comp
+  if (!finalizable_comp
       && (!derived->f2k_derived || !derived->f2k_derived->finalizers))
     {
       gcc_assert (ancestor_wrapper && ancestor_wrapper->ref == NULL
@@ -1605,8 +1608,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   /* Set up the namespace.  */
   sub_ns = gfc_get_namespace (ns, 0);
   sub_ns->sibling = ns->contained;
-  if (!expr_null_wrapper)
-    ns->contained = sub_ns;
+  ns->contained = sub_ns;
   sub_ns->resolved = 1;
 
   /* Set up the procedure symbol.  */
@@ -1622,7 +1624,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   final->ts.kind = 4;
   final->attr.artificial = 1;
   final->attr.always_explicit = 1;
-  final->attr.if_source = expr_null_wrapper ? IFSRC_IFBODY : IFSRC_DECL;
+  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);
@@ -1672,15 +1674,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   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;
-    }
-
   /* Local variables.  */
 
   gfc_get_symbol (gfc_get_string ("%s", "idx"), sub_ns, &idx);
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index cc12e0a8402..3d744ec9641 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -533,7 +533,7 @@ gfc_free_actual_arglist (gfc_actual_arglist *a1)
     {
       a2 = a1->next;
       if (a1->expr)
-      gfc_free_expr (a1->expr);
+	gfc_free_expr (a1->expr);
       free (a1);
       a1 = a2;
     }
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 4612835706b..3466c42132f 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3032,8 +3032,8 @@ gfc_user_op *gfc_get_uop (const char *);
 gfc_user_op *gfc_find_uop (const char *, gfc_namespace *);
 const char *gfc_get_uop_from_name (const char*);
 const char *gfc_get_name_from_uop (const char*);
-void gfc_free_symbol (gfc_symbol *);
-void gfc_release_symbol (gfc_symbol *);
+void gfc_free_symbol (gfc_symbol *&);
+void gfc_release_symbol (gfc_symbol *&);
 gfc_symbol *gfc_new_symbol (const char *, gfc_namespace *);
 gfc_symtree* gfc_find_symtree_in_proc (const char *, gfc_namespace *);
 int gfc_find_symbol (const char *, gfc_namespace *, int, gfc_symbol **);
@@ -3058,7 +3058,7 @@ void gfc_commit_symbols (void);
 void gfc_commit_symbol (gfc_symbol *);
 gfc_charlen *gfc_new_charlen (gfc_namespace *, gfc_charlen *);
 void gfc_free_charlen (gfc_charlen *, gfc_charlen *);
-void gfc_free_namespace (gfc_namespace *);
+void gfc_free_namespace (gfc_namespace *&);
 
 void gfc_symbol_init_2 (void);
 void gfc_symbol_done_2 (void);
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 09ad2bbf0cd..c99c106a0c0 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -2590,8 +2590,9 @@ free_components (gfc_component *p)
 	gfc_free_expr (p->kind_expr);
       if (p->param_list)
 	gfc_free_actual_arglist (p->param_list);
-      free (p->tb);
 
+      free (p->tb);
+      p->tb = NULL;
       free (p);
     }
 }
@@ -3070,7 +3071,7 @@ set_symbol_common_block (gfc_symbol *sym, gfc_common_head *common_block)
 /* Remove a gfc_symbol structure and everything it points to.  */
 
 void
-gfc_free_symbol (gfc_symbol *sym)
+gfc_free_symbol (gfc_symbol *&sym)
 {
 
   if (sym == NULL)
@@ -3078,8 +3079,6 @@ gfc_free_symbol (gfc_symbol *sym)
 
   gfc_free_array_spec (sym->as);
 
-  free_components (sym->components);
-
   gfc_free_expr (sym->value);
 
   gfc_free_namelist (sym->namelist);
@@ -3094,19 +3093,22 @@ gfc_free_symbol (gfc_symbol *sym)
 
   gfc_free_namespace (sym->f2k_derived);
 
+  free_components (sym->components);
+
   set_symbol_common_block (sym, NULL);
 
   if (sym->param_list)
     gfc_free_actual_arglist (sym->param_list);
 
   free (sym);
+  sym = NULL;
 }
 
 
 /* Decrease the reference counter and free memory when we reach zero.  */
 
 void
-gfc_release_symbol (gfc_symbol *sym)
+gfc_release_symbol (gfc_symbol *&sym)
 {
   if (sym == NULL)
     return;
@@ -3826,10 +3828,8 @@ free_tb_tree (gfc_symtree *t)
 
   free_tb_tree (t->left);
   free_tb_tree (t->right);
-
-  /* TODO: Free type-bound procedure structs themselves; probably needs some
-     sort of ref-counting mechanism.  */
   free (t->n.tb);
+  t->n.tb = NULL;
   free (t);
 }
 
@@ -4019,7 +4019,7 @@ free_entry_list (gfc_entry_list *el)
    taken care of when a specific name is freed.  */
 
 void
-gfc_free_namespace (gfc_namespace *ns)
+gfc_free_namespace (gfc_namespace *&ns)
 {
   gfc_namespace *p, *q;
   int i;
@@ -4057,6 +4057,7 @@ gfc_free_namespace (gfc_namespace *ns)
   gfc_free_data (ns->data);
   p = ns->contained;
   free (ns);
+  ns = NULL;
 
   /* Recursively free any contained namespaces.  */
   while (p != NULL)
-- 
2.19.1

Re: [PATCH,FORTRAN] Fix memory leak in finalization wrappers

[Bernhard Reutner-Fischer]

Ping
[hmz. it's been a while, I'll rebase and retest this one.
Ok if it passes?]

On Mon, 15 Oct 2018 10:23:06 +0200
Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> wrote:

> If a finalization is not required we created a namespace containing
> formal arguments for an internal interface definition but never used
> any of these. So the whole sub_ns namespace was not wired up to the
> program and consequently was never freed. The fix is to simply not
> generate any finalization wrappers if we know that it will be unused.
> Note that this reverts back to the original r190869
> (8a96d64282ac534cb597f446f02ac5d0b13249cc) handling for this case
> by reverting this specific part of r194075
> (f1ee56b4be7cc3892e6ccc75d73033c129098e87) for PR fortran/37336.
> 
> Regtests cleanly, installed to the fortran-fe-stringpool branch, sent
> here for reference and later inclusion.
> I might plug a few more leaks in preparation of switching to hash-maps.
> I fear that the leaks around interfaces are another candidate ;)
> 
> Should probably add a tag for the compile-time leak PR68800 shouldn't i.
> 
> valgrind summary for e.g.
> gfortran.dg/abstract_type_3.f03 and gfortran.dg/abstract_type_4.f03
> where ".orig" is pristine trunk and ".mine" contains this fix:
> 
> at3.orig.vg:LEAK SUMMARY:
> at3.orig.vg-   definitely lost: 8,460 bytes in 11 blocks
> at3.orig.vg-   indirectly lost: 13,288 bytes in 55 blocks
> at3.orig.vg-     possibly lost: 0 bytes in 0 blocks
> at3.orig.vg-   still reachable: 572,278 bytes in 2,142 blocks
> at3.orig.vg-        suppressed: 0 bytes in 0 blocks
> at3.orig.vg-
> at3.orig.vg-Use --track-origins=yes to see where uninitialised values come from
> at3.orig.vg-ERROR SUMMARY: 38 errors from 33 contexts (suppressed: 0 from 0)
> --
> at3.mine.vg:LEAK SUMMARY:
> at3.mine.vg-   definitely lost: 344 bytes in 1 blocks
> at3.mine.vg-   indirectly lost: 7,192 bytes in 18 blocks
> at3.mine.vg-     possibly lost: 0 bytes in 0 blocks
> at3.mine.vg-   still reachable: 572,278 bytes in 2,142 blocks
> at3.mine.vg-        suppressed: 0 bytes in 0 blocks
> at3.mine.vg-
> at3.mine.vg-ERROR SUMMARY: 1 errors from 1 contexts (suppressed: 0 from 0)
> at3.mine.vg-ERROR SUMMARY: 1 errors from 1 contexts (suppressed: 0 from 0)
> at4.orig.vg:LEAK SUMMARY:
> at4.orig.vg-   definitely lost: 13,751 bytes in 12 blocks
> at4.orig.vg-   indirectly lost: 11,976 bytes in 60 blocks
> at4.orig.vg-     possibly lost: 0 bytes in 0 blocks
> at4.orig.vg-   still reachable: 572,278 bytes in 2,142 blocks
> at4.orig.vg-        suppressed: 0 bytes in 0 blocks
> at4.orig.vg-
> at4.orig.vg-Use --track-origins=yes to see where uninitialised values come from
> at4.orig.vg-ERROR SUMMARY: 18 errors from 16 contexts (suppressed: 0 from 0)
> --
> at4.mine.vg:LEAK SUMMARY:
> at4.mine.vg-   definitely lost: 3,008 bytes in 3 blocks
> at4.mine.vg-   indirectly lost: 4,056 bytes in 11 blocks
> at4.mine.vg-     possibly lost: 0 bytes in 0 blocks
> at4.mine.vg-   still reachable: 572,278 bytes in 2,142 blocks
> at4.mine.vg-        suppressed: 0 bytes in 0 blocks
> at4.mine.vg-
> at4.mine.vg-ERROR SUMMARY: 3 errors from 3 contexts (suppressed: 0 from 0)
> at4.mine.vg-ERROR SUMMARY: 3 errors from 3 contexts (suppressed: 0 from 0)
> 
> gcc/fortran/ChangeLog:
> 
> 2018-10-12  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>
> 
> 	* class.c (generate_finalization_wrapper): Do leak finalization
> 	wrappers if they will not be used.
> 	* expr.c (gfc_free_actual_arglist): Formatting fix.
> 	* gfortran.h (gfc_free_symbol): Pass argument by reference.
> 	(gfc_release_symbol): Likewise.
> 	(gfc_free_namespace): Likewise.
> 	* symbol.c (gfc_release_symbol): Adjust acordingly.
> 	(free_components): Set procedure pointer components
> 	of derived types to NULL after freeing.
> 	(free_tb_tree): Likewise.
> 	(gfc_free_symbol): Set sym to NULL after freeing.
> 	(gfc_free_namespace): Set namespace to NULL after freeing.
> ---
>  gcc/fortran/class.c    | 25 +++++++++----------------
>  gcc/fortran/expr.c     |  2 +-
>  gcc/fortran/gfortran.h |  6 +++---
>  gcc/fortran/symbol.c   | 19 ++++++++++---------
>  4 files changed, 23 insertions(+), 29 deletions(-)
> 
> diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
> index 69c95fc5dfa..e0bb381a55f 100644
> --- a/gcc/fortran/class.c
> +++ b/gcc/fortran/class.c
> @@ -1533,7 +1533,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
>    gfc_code *last_code, *block;
>    const char *name;
>    bool finalizable_comp = false;
> -  bool expr_null_wrapper = false;
>    gfc_expr *ancestor_wrapper = NULL, *rank;
>    gfc_iterator *iter;
>  
> @@ -1561,13 +1560,17 @@ 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; we defer this a bit to have have
> +     components: Return a NULL() expression; we defer this a bit to 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))
> -    expr_null_wrapper = true;
> +    {
> +      vtab_final->initializer = gfc_get_null_expr (NULL);
> +      gcc_assert (vtab_final->ts.interface == NULL);
> +      return;
> +    }
>    else
>      /* Check whether there are new allocatable components.  */
>      for (comp = derived->components; comp; comp = comp->next)
> @@ -1581,7 +1584,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
>  
>    /* If there is no new finalizer and no new allocatable, return with
>       an expr to the ancestor's one.  */
> -  if (!expr_null_wrapper && !finalizable_comp
> +  if (!finalizable_comp
>        && (!derived->f2k_derived || !derived->f2k_derived->finalizers))
>      {
>        gcc_assert (ancestor_wrapper && ancestor_wrapper->ref == NULL
> @@ -1605,8 +1608,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
>    /* Set up the namespace.  */
>    sub_ns = gfc_get_namespace (ns, 0);
>    sub_ns->sibling = ns->contained;
> -  if (!expr_null_wrapper)
> -    ns->contained = sub_ns;
> +  ns->contained = sub_ns;
>    sub_ns->resolved = 1;
>  
>    /* Set up the procedure symbol.  */
> @@ -1622,7 +1624,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
>    final->ts.kind = 4;
>    final->attr.artificial = 1;
>    final->attr.always_explicit = 1;
> -  final->attr.if_source = expr_null_wrapper ? IFSRC_IFBODY : IFSRC_DECL;
> +  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);
> @@ -1672,15 +1674,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
>    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;
> -    }
> -
>    /* Local variables.  */
>  
>    gfc_get_symbol (gfc_get_string ("%s", "idx"), sub_ns, &idx);
> diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
> index cc12e0a8402..3d744ec9641 100644
> --- a/gcc/fortran/expr.c
> +++ b/gcc/fortran/expr.c
> @@ -533,7 +533,7 @@ gfc_free_actual_arglist (gfc_actual_arglist *a1)
>      {
>        a2 = a1->next;
>        if (a1->expr)
> -      gfc_free_expr (a1->expr);
> +	gfc_free_expr (a1->expr);
>        free (a1);
>        a1 = a2;
>      }
> diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
> index 4612835706b..3466c42132f 100644
> --- a/gcc/fortran/gfortran.h
> +++ b/gcc/fortran/gfortran.h
> @@ -3032,8 +3032,8 @@ gfc_user_op *gfc_get_uop (const char *);
>  gfc_user_op *gfc_find_uop (const char *, gfc_namespace *);
>  const char *gfc_get_uop_from_name (const char*);
>  const char *gfc_get_name_from_uop (const char*);
> -void gfc_free_symbol (gfc_symbol *);
> -void gfc_release_symbol (gfc_symbol *);
> +void gfc_free_symbol (gfc_symbol *&);
> +void gfc_release_symbol (gfc_symbol *&);
>  gfc_symbol *gfc_new_symbol (const char *, gfc_namespace *);
>  gfc_symtree* gfc_find_symtree_in_proc (const char *, gfc_namespace *);
>  int gfc_find_symbol (const char *, gfc_namespace *, int, gfc_symbol **);
> @@ -3058,7 +3058,7 @@ void gfc_commit_symbols (void);
>  void gfc_commit_symbol (gfc_symbol *);
>  gfc_charlen *gfc_new_charlen (gfc_namespace *, gfc_charlen *);
>  void gfc_free_charlen (gfc_charlen *, gfc_charlen *);
> -void gfc_free_namespace (gfc_namespace *);
> +void gfc_free_namespace (gfc_namespace *&);
>  
>  void gfc_symbol_init_2 (void);
>  void gfc_symbol_done_2 (void);
> diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
> index 09ad2bbf0cd..c99c106a0c0 100644
> --- a/gcc/fortran/symbol.c
> +++ b/gcc/fortran/symbol.c
> @@ -2590,8 +2590,9 @@ free_components (gfc_component *p)
>  	gfc_free_expr (p->kind_expr);
>        if (p->param_list)
>  	gfc_free_actual_arglist (p->param_list);
> -      free (p->tb);
>  
> +      free (p->tb);
> +      p->tb = NULL;
>        free (p);
>      }
>  }
> @@ -3070,7 +3071,7 @@ set_symbol_common_block (gfc_symbol *sym, gfc_common_head *common_block)
>  /* Remove a gfc_symbol structure and everything it points to.  */
>  
>  void
> -gfc_free_symbol (gfc_symbol *sym)
> +gfc_free_symbol (gfc_symbol *&sym)
>  {
>  
>    if (sym == NULL)
> @@ -3078,8 +3079,6 @@ gfc_free_symbol (gfc_symbol *sym)
>  
>    gfc_free_array_spec (sym->as);
>  
> -  free_components (sym->components);
> -
>    gfc_free_expr (sym->value);
>  
>    gfc_free_namelist (sym->namelist);
> @@ -3094,19 +3093,22 @@ gfc_free_symbol (gfc_symbol *sym)
>  
>    gfc_free_namespace (sym->f2k_derived);
>  
> +  free_components (sym->components);
> +
>    set_symbol_common_block (sym, NULL);
>  
>    if (sym->param_list)
>      gfc_free_actual_arglist (sym->param_list);
>  
>    free (sym);
> +  sym = NULL;
>  }
>  
>  
>  /* Decrease the reference counter and free memory when we reach zero.  */
>  
>  void
> -gfc_release_symbol (gfc_symbol *sym)
> +gfc_release_symbol (gfc_symbol *&sym)
>  {
>    if (sym == NULL)
>      return;
> @@ -3826,10 +3828,8 @@ free_tb_tree (gfc_symtree *t)
>  
>    free_tb_tree (t->left);
>    free_tb_tree (t->right);
> -
> -  /* TODO: Free type-bound procedure structs themselves; probably needs some
> -     sort of ref-counting mechanism.  */
>    free (t->n.tb);
> +  t->n.tb = NULL;
>    free (t);
>  }
>  
> @@ -4019,7 +4019,7 @@ free_entry_list (gfc_entry_list *el)
>     taken care of when a specific name is freed.  */
>  
>  void
> -gfc_free_namespace (gfc_namespace *ns)
> +gfc_free_namespace (gfc_namespace *&ns)
>  {
>    gfc_namespace *p, *q;
>    int i;
> @@ -4057,6 +4057,7 @@ gfc_free_namespace (gfc_namespace *ns)
>    gfc_free_data (ns->data);
>    p = ns->contained;
>    free (ns);
> +  ns = NULL;
>  
>    /* Recursively free any contained namespaces.  */
>    while (p != NULL)

Re: [PATCH,FORTRAN] Fix memory leak in finalization wrappers

[Bernhard Reutner-Fischer]

On Wed, 27 Oct 2021 23:39:43 +0200
Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> wrote:

> Ping
> [hmz. it's been a while, I'll rebase and retest this one.
> Ok if it passes?]
Testing passed without any new regressions.
Ok for trunk?
thanks,
> 
> On Mon, 15 Oct 2018 10:23:06 +0200
> Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> wrote:
> 
> > If a finalization is not required we created a namespace containing
> > formal arguments for an internal interface definition but never used
> > any of these. So the whole sub_ns namespace was not wired up to the
> > program and consequently was never freed. The fix is to simply not
> > generate any finalization wrappers if we know that it will be unused.
> > Note that this reverts back to the original r190869
> > (8a96d64282ac534cb597f446f02ac5d0b13249cc) handling for this case
> > by reverting this specific part of r194075
> > (f1ee56b4be7cc3892e6ccc75d73033c129098e87) for PR fortran/37336.
> > 
> > Regtests cleanly, installed to the fortran-fe-stringpool branch, sent
> > here for reference and later inclusion.
> > I might plug a few more leaks in preparation of switching to hash-maps.
> > I fear that the leaks around interfaces are another candidate ;)
> > 
> > Should probably add a tag for the compile-time leak PR68800 shouldn't i.
> > 
> > valgrind summary for e.g.
> > gfortran.dg/abstract_type_3.f03 and gfortran.dg/abstract_type_4.f03
> > where ".orig" is pristine trunk and ".mine" contains this fix:
> > 
> > at3.orig.vg:LEAK SUMMARY:
> > at3.orig.vg-   definitely lost: 8,460 bytes in 11 blocks
> > at3.orig.vg-   indirectly lost: 13,288 bytes in 55 blocks
> > at3.orig.vg-     possibly lost: 0 bytes in 0 blocks
> > at3.orig.vg-   still reachable: 572,278 bytes in 2,142 blocks
> > at3.orig.vg-        suppressed: 0 bytes in 0 blocks
> > at3.orig.vg-
> > at3.orig.vg-Use --track-origins=yes to see where uninitialised values come from
> > at3.orig.vg-ERROR SUMMARY: 38 errors from 33 contexts (suppressed: 0 from 0)
> > --
> > at3.mine.vg:LEAK SUMMARY:
> > at3.mine.vg-   definitely lost: 344 bytes in 1 blocks
> > at3.mine.vg-   indirectly lost: 7,192 bytes in 18 blocks
> > at3.mine.vg-     possibly lost: 0 bytes in 0 blocks
> > at3.mine.vg-   still reachable: 572,278 bytes in 2,142 blocks
> > at3.mine.vg-        suppressed: 0 bytes in 0 blocks
> > at3.mine.vg-
> > at3.mine.vg-ERROR SUMMARY: 1 errors from 1 contexts (suppressed: 0 from 0)
> > at3.mine.vg-ERROR SUMMARY: 1 errors from 1 contexts (suppressed: 0 from 0)
> > at4.orig.vg:LEAK SUMMARY:
> > at4.orig.vg-   definitely lost: 13,751 bytes in 12 blocks
> > at4.orig.vg-   indirectly lost: 11,976 bytes in 60 blocks
> > at4.orig.vg-     possibly lost: 0 bytes in 0 blocks
> > at4.orig.vg-   still reachable: 572,278 bytes in 2,142 blocks
> > at4.orig.vg-        suppressed: 0 bytes in 0 blocks
> > at4.orig.vg-
> > at4.orig.vg-Use --track-origins=yes to see where uninitialised values come from
> > at4.orig.vg-ERROR SUMMARY: 18 errors from 16 contexts (suppressed: 0 from 0)
> > --
> > at4.mine.vg:LEAK SUMMARY:
> > at4.mine.vg-   definitely lost: 3,008 bytes in 3 blocks
> > at4.mine.vg-   indirectly lost: 4,056 bytes in 11 blocks
> > at4.mine.vg-     possibly lost: 0 bytes in 0 blocks
> > at4.mine.vg-   still reachable: 572,278 bytes in 2,142 blocks
> > at4.mine.vg-        suppressed: 0 bytes in 0 blocks
> > at4.mine.vg-
> > at4.mine.vg-ERROR SUMMARY: 3 errors from 3 contexts (suppressed: 0 from 0)
> > at4.mine.vg-ERROR SUMMARY: 3 errors from 3 contexts (suppressed: 0 from 0)
> > 
> > gcc/fortran/ChangeLog:
> > 
> > 2018-10-12  Bernhard Reutner-Fischer  <aldot@gcc.gnu.org>
> > 
> > 	* class.c (generate_finalization_wrapper): Do leak finalization
> > 	wrappers if they will not be used.
> > 	* expr.c (gfc_free_actual_arglist): Formatting fix.
> > 	* gfortran.h (gfc_free_symbol): Pass argument by reference.
> > 	(gfc_release_symbol): Likewise.
> > 	(gfc_free_namespace): Likewise.
> > 	* symbol.c (gfc_release_symbol): Adjust acordingly.
> > 	(free_components): Set procedure pointer components
> > 	of derived types to NULL after freeing.
> > 	(free_tb_tree): Likewise.
> > 	(gfc_free_symbol): Set sym to NULL after freeing.
> > 	(gfc_free_namespace): Set namespace to NULL after freeing.
> > ---
> >  gcc/fortran/class.c    | 25 +++++++++----------------
> >  gcc/fortran/expr.c     |  2 +-
> >  gcc/fortran/gfortran.h |  6 +++---
> >  gcc/fortran/symbol.c   | 19 ++++++++++---------
> >  4 files changed, 23 insertions(+), 29 deletions(-)
> > 
> > diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
> > index 69c95fc5dfa..e0bb381a55f 100644
> > --- a/gcc/fortran/class.c
> > +++ b/gcc/fortran/class.c
> > @@ -1533,7 +1533,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
> >    gfc_code *last_code, *block;
> >    const char *name;
> >    bool finalizable_comp = false;
> > -  bool expr_null_wrapper = false;
> >    gfc_expr *ancestor_wrapper = NULL, *rank;
> >    gfc_iterator *iter;
> >  
> > @@ -1561,13 +1560,17 @@ 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; we defer this a bit to have have
> > +     components: Return a NULL() expression; we defer this a bit to 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))
> > -    expr_null_wrapper = true;
> > +    {
> > +      vtab_final->initializer = gfc_get_null_expr (NULL);
> > +      gcc_assert (vtab_final->ts.interface == NULL);
> > +      return;
> > +    }
> >    else
> >      /* Check whether there are new allocatable components.  */
> >      for (comp = derived->components; comp; comp = comp->next)
> > @@ -1581,7 +1584,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
> >  
> >    /* If there is no new finalizer and no new allocatable, return with
> >       an expr to the ancestor's one.  */
> > -  if (!expr_null_wrapper && !finalizable_comp
> > +  if (!finalizable_comp
> >        && (!derived->f2k_derived || !derived->f2k_derived->finalizers))
> >      {
> >        gcc_assert (ancestor_wrapper && ancestor_wrapper->ref == NULL
> > @@ -1605,8 +1608,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
> >    /* Set up the namespace.  */
> >    sub_ns = gfc_get_namespace (ns, 0);
> >    sub_ns->sibling = ns->contained;
> > -  if (!expr_null_wrapper)
> > -    ns->contained = sub_ns;
> > +  ns->contained = sub_ns;
> >    sub_ns->resolved = 1;
> >  
> >    /* Set up the procedure symbol.  */
> > @@ -1622,7 +1624,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
> >    final->ts.kind = 4;
> >    final->attr.artificial = 1;
> >    final->attr.always_explicit = 1;
> > -  final->attr.if_source = expr_null_wrapper ? IFSRC_IFBODY : IFSRC_DECL;
> > +  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);
> > @@ -1672,15 +1674,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
> >    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;
> > -    }
> > -
> >    /* Local variables.  */
> >  
> >    gfc_get_symbol (gfc_get_string ("%s", "idx"), sub_ns, &idx);
> > diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
> > index cc12e0a8402..3d744ec9641 100644
> > --- a/gcc/fortran/expr.c
> > +++ b/gcc/fortran/expr.c
> > @@ -533,7 +533,7 @@ gfc_free_actual_arglist (gfc_actual_arglist *a1)
> >      {
> >        a2 = a1->next;
> >        if (a1->expr)
> > -      gfc_free_expr (a1->expr);
> > +	gfc_free_expr (a1->expr);
> >        free (a1);
> >        a1 = a2;
> >      }
> > diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
> > index 4612835706b..3466c42132f 100644
> > --- a/gcc/fortran/gfortran.h
> > +++ b/gcc/fortran/gfortran.h
> > @@ -3032,8 +3032,8 @@ gfc_user_op *gfc_get_uop (const char *);
> >  gfc_user_op *gfc_find_uop (const char *, gfc_namespace *);
> >  const char *gfc_get_uop_from_name (const char*);
> >  const char *gfc_get_name_from_uop (const char*);
> > -void gfc_free_symbol (gfc_symbol *);
> > -void gfc_release_symbol (gfc_symbol *);
> > +void gfc_free_symbol (gfc_symbol *&);
> > +void gfc_release_symbol (gfc_symbol *&);
> >  gfc_symbol *gfc_new_symbol (const char *, gfc_namespace *);
> >  gfc_symtree* gfc_find_symtree_in_proc (const char *, gfc_namespace *);
> >  int gfc_find_symbol (const char *, gfc_namespace *, int, gfc_symbol **);
> > @@ -3058,7 +3058,7 @@ void gfc_commit_symbols (void);
> >  void gfc_commit_symbol (gfc_symbol *);
> >  gfc_charlen *gfc_new_charlen (gfc_namespace *, gfc_charlen *);
> >  void gfc_free_charlen (gfc_charlen *, gfc_charlen *);
> > -void gfc_free_namespace (gfc_namespace *);
> > +void gfc_free_namespace (gfc_namespace *&);
> >  
> >  void gfc_symbol_init_2 (void);
> >  void gfc_symbol_done_2 (void);
> > diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
> > index 09ad2bbf0cd..c99c106a0c0 100644
> > --- a/gcc/fortran/symbol.c
> > +++ b/gcc/fortran/symbol.c
> > @@ -2590,8 +2590,9 @@ free_components (gfc_component *p)
> >  	gfc_free_expr (p->kind_expr);
> >        if (p->param_list)
> >  	gfc_free_actual_arglist (p->param_list);
> > -      free (p->tb);
> >  
> > +      free (p->tb);
> > +      p->tb = NULL;
> >        free (p);
> >      }
> >  }
> > @@ -3070,7 +3071,7 @@ set_symbol_common_block (gfc_symbol *sym, gfc_common_head *common_block)
> >  /* Remove a gfc_symbol structure and everything it points to.  */
> >  
> >  void
> > -gfc_free_symbol (gfc_symbol *sym)
> > +gfc_free_symbol (gfc_symbol *&sym)
> >  {
> >  
> >    if (sym == NULL)
> > @@ -3078,8 +3079,6 @@ gfc_free_symbol (gfc_symbol *sym)
> >  
> >    gfc_free_array_spec (sym->as);
> >  
> > -  free_components (sym->components);
> > -
> >    gfc_free_expr (sym->value);
> >  
> >    gfc_free_namelist (sym->namelist);
> > @@ -3094,19 +3093,22 @@ gfc_free_symbol (gfc_symbol *sym)
> >  
> >    gfc_free_namespace (sym->f2k_derived);
> >  
> > +  free_components (sym->components);
> > +
> >    set_symbol_common_block (sym, NULL);
> >  
> >    if (sym->param_list)
> >      gfc_free_actual_arglist (sym->param_list);
> >  
> >    free (sym);
> > +  sym = NULL;
> >  }
> >  
> >  
> >  /* Decrease the reference counter and free memory when we reach zero.  */
> >  
> >  void
> > -gfc_release_symbol (gfc_symbol *sym)
> > +gfc_release_symbol (gfc_symbol *&sym)
> >  {
> >    if (sym == NULL)
> >      return;
> > @@ -3826,10 +3828,8 @@ free_tb_tree (gfc_symtree *t)
> >  
> >    free_tb_tree (t->left);
> >    free_tb_tree (t->right);
> > -
> > -  /* TODO: Free type-bound procedure structs themselves; probably needs some
> > -     sort of ref-counting mechanism.  */
> >    free (t->n.tb);
> > +  t->n.tb = NULL;
> >    free (t);
> >  }
> >  
> > @@ -4019,7 +4019,7 @@ free_entry_list (gfc_entry_list *el)
> >     taken care of when a specific name is freed.  */
> >  
> >  void
> > -gfc_free_namespace (gfc_namespace *ns)
> > +gfc_free_namespace (gfc_namespace *&ns)
> >  {
> >    gfc_namespace *p, *q;
> >    int i;
> > @@ -4057,6 +4057,7 @@ gfc_free_namespace (gfc_namespace *ns)
> >    gfc_free_data (ns->data);
> >    p = ns->contained;
> >    free (ns);
> > +  ns = NULL;
> >  
> >    /* Recursively free any contained namespaces.  */
> >    while (p != NULL)  
> 

Re: [PATCH,FORTRAN] Fix memory leak in finalization wrappers

[Mikael Morin]

Le 29/10/2021 à 01:58, Bernhard Reutner-Fischer via Fortran a écrit :
> On Wed, 27 Oct 2021 23:39:43 +0200
> Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> wrote:
> 
>> Ping
>> [hmz. it's been a while, I'll rebase and retest this one.
>> Ok if it passes?]
> Testing passed without any new regressions.
> Ok for trunk?
> thanks,
>>
>> On Mon, 15 Oct 2018 10:23:06 +0200
>> Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> wrote:
>>
>>> If a finalization is not required we created a namespace containing
>>> formal arguments for an internal interface definition but never used
>>> any of these. So the whole sub_ns namespace was not wired up to the
>>> program and consequently was never freed. The fix is to simply not
>>> generate any finalization wrappers if we know that it will be unused.
>>> Note that this reverts back to the original r190869
>>> (8a96d64282ac534cb597f446f02ac5d0b13249cc) handling for this case
>>> by reverting this specific part of r194075
>>> (f1ee56b4be7cc3892e6ccc75d73033c129098e87) for PR fortran/37336.
>>>
I’m a bit concerned by the loss of the null_expr’s type interface.
I can’t convince myself that it’s either absolutely necessary or 
completely useless.
Tobias didn’t include a test in his commit unfortunately, but I bet he 
did the change on purpose.
Don’t you get the same effect on the memory leaks if you keep just the 
following hunk?

 >>> @@ -1605,8 +1608,7 @@ generate_finalization_wrapper (gfc_symbol 
*derived, gfc_namespace *ns,
 >>>     /* Set up the namespace.  */
 >>>     sub_ns = gfc_get_namespace (ns, 0);
 >>>     sub_ns->sibling = ns->contained;
 >>> -  if (!expr_null_wrapper)
 >>> -    ns->contained = sub_ns;
 >>> +  ns->contained = sub_ns;
 >>>     sub_ns->resolved = 1;
 >>>
 >>>     /* Set up the procedure symbol.  */


The rest of the changes (appart from class.c) are mostly OK with the nit 
below and should be put in their own commit.

 >>> @@ -3826,10 +3828,8 @@ free_tb_tree (gfc_symtree *t)
 >>>
 >>>     free_tb_tree (t->left);
 >>>     free_tb_tree (t->right);
 >>> -
 >>> -  /* TODO: Free type-bound procedure structs themselves; probably 
needs some
 >>> -     sort of ref-counting mechanism.  */
 >>>     free (t->n.tb);

Please keep a comment; it remains somehow valid but could be updated 
maybe: gfc_typebound_proc’s u.generic field for example is nowhere freed 
as far as I know.

Thanks.

Mikael

Re: [PATCH,FORTRAN] Fix memory leak in finalization wrappers

[Bernhard Reutner-Fischer]

On Fri, 5 Nov 2021 19:46:16 +0100
Mikael Morin <morin-mikael@orange.fr> wrote:

> Le 29/10/2021 à 01:58, Bernhard Reutner-Fischer via Fortran a écrit :
> > On Wed, 27 Oct 2021 23:39:43 +0200
> > Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> wrote:
> >   
> >> Ping
> >> [hmz. it's been a while, I'll rebase and retest this one.
> >> Ok if it passes?]  
> > Testing passed without any new regressions.
> > Ok for trunk?
> > thanks,  
> >>
> >> On Mon, 15 Oct 2018 10:23:06 +0200
> >> Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> wrote:
> >>  
> >>> If a finalization is not required we created a namespace containing
> >>> formal arguments for an internal interface definition but never used
> >>> any of these. So the whole sub_ns namespace was not wired up to the
> >>> program and consequently was never freed. The fix is to simply not
> >>> generate any finalization wrappers if we know that it will be unused.
> >>> Note that this reverts back to the original r190869
> >>> (8a96d64282ac534cb597f446f02ac5d0b13249cc) handling for this case
> >>> by reverting this specific part of r194075
> >>> (f1ee56b4be7cc3892e6ccc75d73033c129098e87) for PR fortran/37336.
> >>>  
> I’m a bit concerned by the loss of the null_expr’s type interface.
> I can’t convince myself that it’s either absolutely necessary or 
> completely useless.

It's a delicate spot, yes, but i do think they are completely useless.
If we do NOT need a finalization, the initializer can (and has to be
AFAIU) be a null_expr and AFAICS then does not need an interface.

> Tobias didn’t include a test in his commit unfortunately, but I bet he 
> did the change on purpose.
> Don’t you get the same effect on the memory leaks if you keep just the 
> following hunk?

No, i don't think emitting the finalization-wrappers unconditionally is
correct. In
https://gcc.gnu.org/pipermail/gcc-patches/2021-October/582894.html
i noted:
---8<---
We were generating (and emitting to modules) finalization wrapper
needlessly, i.e. even when they were not called for.

This 1) leaked like shown in the initial submission and
2) polluted module files with unwarranted (wrong) mention of
finalization wrappers even when compiling without any coarray stuff.

E.g. a modified udr10.f90 (from libgomp) has the following diff in the
module which illustrates the positive side-effect of the fix:

-26 'array' '' '' 25 ((VARIABLE INOUT UNKNOWN-PROC UNKNOWN UNKNOWN 0 0
-ARTIFICIAL DIMENSION CONTIGUOUS DUMMY) () (DERIVED 3 0 0 0 DERIVED ()) 0
-0 () (0 0 ASSUMED_RANK) 0 () () () 0 0)
-27 'byte_stride' '' '' 25 ((VARIABLE UNKNOWN-INTENT UNKNOWN-PROC UNKNOWN
-UNKNOWN 0 0 ARTIFICIAL VALUE DUMMY) () (INTEGER 8 0 0 0 INTEGER ()) 0 0
-() () 0 () () () 0 0)
-28 'fini_coarray' '' '' 25 ((VARIABLE UNKNOWN-INTENT UNKNOWN-PROC
-UNKNOWN UNKNOWN 0 0 ARTIFICIAL VALUE DUMMY) () (LOGICAL 1 0 0 0 LOGICAL
-()) 0 0 () () 0 () () () 0 0)
---8<---
[Should be visible with the original udr10.f90 too.]

If something in a module would trigger finalization to be emitted
legitimately then this will continue to work as before. But IMHO
it is not proper to emit them in an undue manner. Hence it does not
help to just wire the sub_ns up in the program when it should not be
wired up (and not generated in the first place) I'd say.

> 
>  >>> @@ -1605,8 +1608,7 @@ generate_finalization_wrapper (gfc_symbol   
> *derived, gfc_namespace *ns,
>  >>>     /* Set up the namespace.  */
>  >>>     sub_ns = gfc_get_namespace (ns, 0);
>  >>>     sub_ns->sibling = ns->contained;
>  >>> -  if (!expr_null_wrapper)
>  >>> -    ns->contained = sub_ns;
>  >>> +  ns->contained = sub_ns;
>  >>>     sub_ns->resolved = 1;
>  >>>
>  >>>     /* Set up the procedure symbol.  */  
> 
> 
> The rest of the changes (appart from class.c) are mostly OK with the nit 
> below and should be put in their own commit.
> 
>  >>> @@ -3826,10 +3828,8 @@ free_tb_tree (gfc_symtree *t)
>  >>>
>  >>>     free_tb_tree (t->left);
>  >>>     free_tb_tree (t->right);
>  >>> -
>  >>> -  /* TODO: Free type-bound procedure structs themselves; probably   
> needs some
>  >>> -     sort of ref-counting mechanism.  */
>  >>>     free (t->n.tb);  
> 
> Please keep a comment; it remains somehow valid but could be updated 
> maybe: gfc_typebound_proc’s u.generic field for example is nowhere freed 
> as far as I know.

Well that's a valid point, not sure where they are freed indeed.
Do you have a specific testcase in mind that leaks tbp's u.generic (or
specific for that matter) for me to look at?

I'm happy to change the comment to
TODO: Free type-bound procedure u.generic and u.specific fields
to reflect the current state. Ok?
> 
> Thanks.

Many thanks for looking at the patch!
> 
> Mikael

Re: [PATCH,FORTRAN] Fix memory leak in finalization wrappers

[Mikael Morin]

Le 05/11/2021 à 19:46, Mikael Morin a écrit :
> Don’t you get the same effect on the memory leaks if you keep just the 
> following hunk?
> 
>  >>> @@ -1605,8 +1608,7 @@ generate_finalization_wrapper (gfc_symbol 
> *derived, gfc_namespace *ns,
>  >>>     /* Set up the namespace.  */
>  >>>     sub_ns = gfc_get_namespace (ns, 0);
>  >>>     sub_ns->sibling = ns->contained;
>  >>> -  if (!expr_null_wrapper)
>  >>> -    ns->contained = sub_ns;
>  >>> +  ns->contained = sub_ns;
>  >>>     sub_ns->resolved = 1;
>  >>>
>  >>>     /* Set up the procedure symbol.  */
> 

That’s probably not a good idea on second thought; it’s preferable to 
leak memory and not generate an empty finalization procedure.

Re: [PATCH,FORTRAN] Fix memory leak in finalization wrappers

[Mikael Morin]

Sorry, I hadn’t seen your message.

Le 05/11/2021 à 23:08, Bernhard Reutner-Fischer a écrit :
> On Fri, 5 Nov 2021 19:46:16 +0100
> Mikael Morin <morin-mikael@orange.fr> wrote:
> 
>> Le 29/10/2021 à 01:58, Bernhard Reutner-Fischer via Fortran a écrit :
>>> On Wed, 27 Oct 2021 23:39:43 +0200
>>> Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> wrote:
>>>    
>>>> On Mon, 15 Oct 2018 10:23:06 +0200
>>>> Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> wrote:
>>>>   
>>>>> If a finalization is not required we created a namespace containing
>>>>> formal arguments for an internal interface definition but never used
>>>>> any of these. So the whole sub_ns namespace was not wired up to the
>>>>> program and consequently was never freed. The fix is to simply not
>>>>> generate any finalization wrappers if we know that it will be unused.
>>>>> Note that this reverts back to the original r190869
>>>>> (8a96d64282ac534cb597f446f02ac5d0b13249cc) handling for this case
>>>>> by reverting this specific part of r194075
>>>>> (f1ee56b4be7cc3892e6ccc75d73033c129098e87) for PR fortran/37336.
>>>>>   
>> I’m a bit concerned by the loss of the null_expr’s type interface.
>> I can’t convince myself that it’s either absolutely necessary or
>> completely useless.
> 
> It's a delicate spot, yes, but i do think they are completely useless.
> If we do NOT need a finalization, the initializer can (and has to be
> AFAIU) be a null_expr and AFAICS then does not need an interface.
> 
Well, the null pointer itself doesn’t need a type, but I think it’s 
better if the pointer it’s assigned to has a type different from void*.
It will (hopefully) help the middle-end optimizers downstream.

I will see if I can manage to create a testcase where it makes a 
difference (don’t hold your breath, I don’t even have a bootstrapped 
compiler ready yet).


>> Don’t you get the same effect on the memory leaks if you keep just the
>> following hunk?
> 
> No, i don't think emitting the finalization-wrappers unconditionally is
> correct. 
 > (... lengthy explaination ...)
 >
Agreed, it was a poor suggestion.


>> The rest of the changes (appart from class.c) are mostly OK with the nit
>> below and should be put in their own commit.
>>
>>   >>> @@ -3826,10 +3828,8 @@ free_tb_tree (gfc_symtree *t)
>>   >>>
>>   >>>     free_tb_tree (t->left);
>>   >>>     free_tb_tree (t->right);
>>   >>> -
>>   >>> -  /* TODO: Free type-bound procedure structs themselves; probably
>> needs some
>>   >>> -     sort of ref-counting mechanism.  */
>>   >>>     free (t->n.tb);
>>
>> Please keep a comment; it remains somehow valid but could be updated
>> maybe: gfc_typebound_proc’s u.generic field for example is nowhere freed
>> as far as I know.
> 
> Well that's a valid point, not sure where they are freed indeed.
> Do you have a specific testcase in mind that leaks tbp's u.generic (or
> specific for that matter) for me to look at?
> 
Any testcase with generic typebound procedures, I guess.
typebound_generic_3.f03 for example seems like a good candidate.

> I'm happy to change the comment to
> TODO: Free type-bound procedure u.generic and u.specific fields
> to reflect the current state. Ok?
>
I don’t think specific leaks because it’s one of gfc_namespace’s 
sym_root sub-nodes, and it’s freed with gfc_namespace.
OK without "and u.specific".

Re: [PATCH,FORTRAN] Fix memory leak in finalization wrappers

[Bernhard Reutner-Fischer]

[-- Attachment #1: Type: text/plain, Size: 5305 bytes --]

On Sat, 6 Nov 2021 13:04:07 +0100
Mikael Morin <morin-mikael@orange.fr> wrote:

> Le 05/11/2021 à 23:08, Bernhard Reutner-Fischer a écrit :
> > On Fri, 5 Nov 2021 19:46:16 +0100
> > Mikael Morin <morin-mikael@orange.fr> wrote:
> >   
> >> Le 29/10/2021 à 01:58, Bernhard Reutner-Fischer via Fortran a écrit :  
> >>> On Wed, 27 Oct 2021 23:39:43 +0200
> >>> Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> wrote:
> >>>      
> >>>> On Mon, 15 Oct 2018 10:23:06 +0200
> >>>> Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> wrote:
> >>>>     
> >>>>> If a finalization is not required we created a namespace containing
> >>>>> formal arguments for an internal interface definition but never used
> >>>>> any of these. So the whole sub_ns namespace was not wired up to the
> >>>>> program and consequently was never freed. The fix is to simply not
> >>>>> generate any finalization wrappers if we know that it will be unused.
> >>>>> Note that this reverts back to the original r190869
> >>>>> (8a96d64282ac534cb597f446f02ac5d0b13249cc) handling for this case
> >>>>> by reverting this specific part of r194075
> >>>>> (f1ee56b4be7cc3892e6ccc75d73033c129098e87) for PR fortran/37336.
> >>>>>     
> >> I’m a bit concerned by the loss of the null_expr’s type interface.
> >> I can’t convince myself that it’s either absolutely necessary or
> >> completely useless.  
> > 
> > It's a delicate spot, yes, but i do think they are completely useless.
> > If we do NOT need a finalization, the initializer can (and has to be
> > AFAIU) be a null_expr and AFAICS then does not need an interface.
> >   
> Well, the null pointer itself doesn’t need a type, but I think it’s 
> better if the pointer it’s assigned to has a type different from void*.
> It will (hopefully) help the middle-end optimizers downstream.

I would not expect this to help all that much or at all TBH.

So i compiled
for i in $(grep -li final $(grep -L dg-error /scratch/src/gcc-12.mine/gcc/testsuite/gfortran.dg/*.f*)); do gfortran -O2 -fcoarray=single -c $i -g -g3 -ggdb3 -fdump-tree-original -fdump-tree-optimized;done
and diffed all .original and .optimized dumps against pristine trunk
and they are identical.

I inspected and ran the binary from finalize_14 and there is no change
in the leaks compared to pristine trunk. The 3 shape_w in p leak as
they used to. I do remember that finalize_14 was a good testcase, in
sum i glared at it for quite some time ;)
> 
> I will see if I can manage to create a testcase where it makes a 
> difference (don’t hold your breath, I don’t even have a bootstrapped 
> compiler ready yet).
> 
That'd be great, TIA!
[]

btw.. Just because it's vagely related.
I think f8add009ce300f24b75e9c2e2cc5dd944a020c28 for
PR fortran/88009 (ICE in find_intrinsic_vtab, at fortran/class.c:2761)
is incomplete in that i think all the internal class helpers should be
flagged artificial. All these symbols built in gfc_build_class_symbol,
generate_finalization_wrapper, gfc_find_derived_vtab etc.
Looking at the history it seems the artificial bit often was forgotten.
And most importantly i think it is not correct to ignore artificial in
gfc_check_conflict!

I'm attaching my notes on this to illustrate what i mean.
Not a patch, even if it regtests cleanly..

The hunk in gfc_match_derived_decl() plugs another leak by first
checking if the max extension level is reached before adding the
component. Maybe i should split that hunk out.
Similar to the removal of *head in gfc_match_derived_decl, there's
another spot in gfc_match_decl_type_spec which should get rid of the
*head and just wire the interface up as usual. Just cosmetics.

Several tests do exercise this code: alloc_comp_class_1.f90,
class_19.f03 and 62, unlimited_polymorphic_8.f90 and others.

> >> The rest of the changes (appart from class.c) are mostly OK with the nit
> >> below and should be put in their own commit.
> >>  
> >>   >>> @@ -3826,10 +3828,8 @@ free_tb_tree (gfc_symtree *t)
> >>   >>>
> >>   >>>     free_tb_tree (t->left);
> >>   >>>     free_tb_tree (t->right);
> >>   >>> -
> >>   >>> -  /* TODO: Free type-bound procedure structs themselves; probably  
> >> needs some  
> >>   >>> -     sort of ref-counting mechanism.  */
> >>   >>>     free (t->n.tb);  
> >>
> >> Please keep a comment; it remains somehow valid but could be updated
> >> maybe: gfc_typebound_proc’s u.generic field for example is nowhere freed
> >> as far as I know.  
> > 
> > Well that's a valid point, not sure where they are freed indeed.
> > Do you have a specific testcase in mind that leaks tbp's u.generic (or
> > specific for that matter) for me to look at?
> >   
> Any testcase with generic typebound procedures, I guess.
> typebound_generic_3.f03 for example seems like a good candidate.

I'll have a look at these later, thanks for the pointer.
> 
> > I'm happy to change the comment to
> > TODO: Free type-bound procedure u.generic and u.specific fields
> > to reflect the current state. Ok?
> >  
> I don’t think specific leaks because it’s one of gfc_namespace’s 
> sym_root sub-nodes, and it’s freed with gfc_namespace.
> OK without "and u.specific".

Ah right. Done.

Thanks so far!

[-- Attachment #2: gfc-class-artificial.02.txt --]
[-- Type: text/plain, Size: 20021 bytes --]

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 6b017667600..44fccced7b9 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -637,7 +637,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
 			gfc_array_spec **as)
 {
   char tname[GFC_MAX_SYMBOL_LEN+1];
-  char *name;
+  const char *name;
   gfc_symbol *fclass;
   gfc_symbol *vtab;
   gfc_component *c;
@@ -665,17 +665,17 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
 
   get_unique_hashed_string (tname, ts->u.derived);
   if ((*as) && attr->allocatable)
-    name = xasprintf ("__class_%s_%d_%da", tname, rank, (*as)->corank);
+    name = gfc_get_string ("__class_%s_%d_%da", tname, rank, (*as)->corank);
   else if ((*as) && attr->pointer)
-    name = xasprintf ("__class_%s_%d_%dp", tname, rank, (*as)->corank);
+    name = gfc_get_string ("__class_%s_%d_%dp", tname, rank, (*as)->corank);
   else if ((*as))
-    name = xasprintf ("__class_%s_%d_%dt", tname, rank, (*as)->corank);
+    name = gfc_get_string ("__class_%s_%d_%dt", tname, rank, (*as)->corank);
   else if (attr->pointer)
-    name = xasprintf ("__class_%s_p", tname);
+    name = gfc_get_string ("__class_%s_p", tname);
   else if (attr->allocatable)
-    name = xasprintf ("__class_%s_a", tname);
+    name = gfc_get_string ("__class_%s_a", tname);
   else
-    name = xasprintf ("__class_%s_t", tname);
+    name = gfc_get_string ("__class_%s_t", tname);
 
   if (ts->u.derived->attr.unlimited_polymorphic)
     {
@@ -695,7 +695,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
   if (attr->dummy && !attr->codimension && (*as)
       && !((*as)->type == AS_DEFERRED || (*as)->type == AS_ASSUMED_RANK))
     {
-      char *sname;
+      const char *sname;
       ns = gfc_current_ns;
       gfc_find_symbol (name, ns, 0, &fclass);
       /* If a local class type with this name already exists, update the
@@ -703,8 +703,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
       if (fclass)
 	{
 	  fclass = NULL;
-	  sname = xasprintf ("%s_%d", name, ++ctr);
-	  free (name);
+	  sname = gfc_get_string ("%s_%d", name, ++ctr);
 	  name = sname;
 	}
     }
@@ -735,6 +734,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
       c->ts.type = BT_DERIVED;
       c->attr.access = ACCESS_PRIVATE;
       c->ts.u.derived = ts->u.derived;
+      c->attr.artificial = 1;
       c->attr.class_pointer = attr->pointer;
       c->attr.pointer = attr->pointer || (attr->dummy && !attr->allocatable)
 			|| attr->select_type_temporary;
@@ -742,7 +742,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
       c->attr.dimension = attr->dimension;
       c->attr.codimension = attr->codimension;
       c->attr.abstract = fclass->attr.abstract;
-      c->as = (*as);
+      c->as = *as;
       c->initializer = NULL;
 
       /* Add component '_vptr'.  */
@@ -751,6 +751,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
       c->ts.type = BT_DERIVED;
       c->attr.access = ACCESS_PRIVATE;
       c->attr.pointer = 1;
+      c->attr.artificial = 1;
 
       if (ts->u.derived->attr.unlimited_polymorphic)
 	{
@@ -792,8 +793,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
   fclass->attr.is_class = 1;
   ts->u.derived = fclass;
   attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0;
-  (*as) = NULL;
-  free (name);
+  *as = NULL;
   return true;
 }
 
@@ -1600,7 +1600,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   gfc_component *comp;
   gfc_namespace *sub_ns;
   gfc_code *last_code, *block;
-  char *name;
+  const char *name;
   bool finalizable_comp = false;
   gfc_expr *ancestor_wrapper = NULL, *rank;
   gfc_iterator *iter;
@@ -1681,7 +1681,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   sub_ns->resolved = 1;
 
   /* Set up the procedure symbol.  */
-  name = xasprintf ("__final_%s", tname);
+  name = gfc_get_string ("__final_%s", tname);
   gfc_get_symbol (name, sub_ns, &final);
   sub_ns->proc_name = final;
   final->attr.flavor = FL_PROCEDURE;
@@ -2238,7 +2238,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
   gfc_free_expr (rank);
   vtab_final->initializer = gfc_lval_expr_from_sym (final);
   vtab_final->ts.interface = final;
-  free (name);
 }
 
 
@@ -2313,10 +2312,10 @@ gfc_find_derived_vtab (gfc_symbol *derived)
   if (ns)
     {
       char tname[GFC_MAX_SYMBOL_LEN+1];
-      char *name;
+      const char *name;
 
       get_unique_hashed_string (tname, derived);
-      name = xasprintf ("__vtab_%s", tname);
+      name = gfc_get_string ("__vtab_%s", tname);
 
       /* Look for the vtab symbol in various namespaces.  */
       if (gsym && gsym->ns)
@@ -2344,7 +2343,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 	  vtab->attr.vtab = 1;
 	  vtab->attr.access = ACCESS_PUBLIC;
 	  gfc_set_sym_referenced (vtab);
-	  name = xasprintf ("__vtype_%s", tname);
+	  name = gfc_get_string ("__vtype_%s", tname);
 
 	  gfc_find_symbol (name, ns, 0, &vtype);
 	  if (vtype == NULL)
@@ -2372,6 +2371,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		goto cleanup;
 	      vtype->attr.access = ACCESS_PUBLIC;
 	      vtype->attr.vtype = 1;
+	      vtype->attr.artificial = 1;
 	      gfc_set_sym_referenced (vtype);
 
 	      /* Add component '_hash'.  */
@@ -2380,6 +2380,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 	      c->ts.type = BT_INTEGER;
 	      c->ts.kind = 4;
 	      c->attr.access = ACCESS_PRIVATE;
+	      c->attr.artificial = 1;
 	      c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
 						 NULL, derived->hash_value);
 
@@ -2389,6 +2390,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 	      c->ts.type = BT_INTEGER;
 	      c->ts.kind = gfc_size_kind;
 	      c->attr.access = ACCESS_PRIVATE;
+	      c->attr.artificial = 1;
 	      /* Remember the derived type in ts.u.derived,
 		 so that the correct initializer can be set later on
 		 (in gfc_conv_structure).  */
@@ -2401,6 +2403,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		goto cleanup;
 	      c->attr.pointer = 1;
 	      c->attr.access = ACCESS_PRIVATE;
+	      c->attr.artificial = 1;
 	      if (!derived->attr.unlimited_polymorphic)
 		parent = gfc_get_derived_super_type (derived);
 	      else
@@ -2447,7 +2450,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 	      else
 		{
 		  /* Construct default initialization variable.  */
-		  name = xasprintf ("__def_init_%s", tname);
+		  name = gfc_get_string ("__def_init_%s", tname);
 		  gfc_get_symbol (name, ns, &def_init);
 		  def_init->attr.target = 1;
 		  def_init->attr.artificial = 1;
@@ -2467,6 +2470,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		goto cleanup;
 	      c->attr.proc_pointer = 1;
 	      c->attr.access = ACCESS_PRIVATE;
+	      c->attr.artificial = 1;
 	      c->tb = XCNEW (gfc_typebound_proc);
 	      c->tb->ppc = 1;
 	      if (derived->attr.unlimited_polymorphic
@@ -2480,7 +2484,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		  ns->contained = sub_ns;
 		  sub_ns->resolved = 1;
 		  /* Set up procedure symbol.  */
-		  name = xasprintf ("__copy_%s", tname);
+		  name = gfc_get_string ("__copy_%s", tname);
 		  gfc_get_symbol (name, sub_ns, &copy);
 		  sub_ns->proc_name = copy;
 		  copy->attr.flavor = FL_PROCEDURE;
@@ -2543,6 +2547,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		goto cleanup;
 	      c->attr.proc_pointer = 1;
 	      c->attr.access = ACCESS_PRIVATE;
+	      c->attr.artificial = 1;
 	      c->tb = XCNEW (gfc_typebound_proc);
 	      c->tb->ppc = 1;
 	      if (derived->attr.unlimited_polymorphic
@@ -2558,7 +2563,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
 		  ns->contained = sub_ns;
 		  sub_ns->resolved = 1;
 		  /* Set up procedure symbol.  */
-		  name = xasprintf ("__deallocate_%s", tname);
+		  name = gfc_get_string ("__deallocate_%s", tname);
 		  gfc_get_symbol (name, sub_ns, &dealloc);
 		  sub_ns->proc_name = dealloc;
 		  dealloc->attr.flavor = FL_PROCEDURE;
@@ -2607,7 +2612,6 @@ have_vtype:
 	  vtab->ts.u.derived = vtype;
 	  vtab->value = gfc_default_initializer (&vtab->ts);
 	}
-      free (name);
     }
 
   found_sym = vtab;
@@ -2700,13 +2704,13 @@ find_intrinsic_vtab (gfc_typespec *ts)
   if (ns)
     {
       char tname[GFC_MAX_SYMBOL_LEN+1];
-      char *name;
+      const char *name;
 
       /* Encode all types as TYPENAME_KIND_ including especially character
 	 arrays, whose length is now consistently stored in the _len component
 	 of the class-variable.  */
       sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind);
-      name = xasprintf ("__vtab_%s", tname);
+      name = gfc_get_string ("__vtab_%s", tname);
 
       /* Look for the vtab symbol in the top-level namespace only.  */
       gfc_find_symbol (name, ns, 0, &vtab);
@@ -2722,8 +2726,9 @@ find_intrinsic_vtab (gfc_typespec *ts)
 	  vtab->attr.save = SAVE_IMPLICIT;
 	  vtab->attr.vtab = 1;
 	  vtab->attr.access = ACCESS_PUBLIC;
+	  vtab->attr.artificial = 1;
 	  gfc_set_sym_referenced (vtab);
-	  name = xasprintf ("__vtype_%s", tname);
+	  name = gfc_get_string ("__vtype_%s", tname);
 
 	  gfc_find_symbol (name, ns, 0, &vtype);
 	  if (vtype == NULL)
@@ -2740,6 +2745,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
 				   &gfc_current_locus))
 		goto cleanup;
 	      vtype->attr.access = ACCESS_PUBLIC;
+	      vtype->attr.artificial = 1;
 	      vtype->attr.vtype = 1;
 	      gfc_set_sym_referenced (vtype);
 
@@ -2749,6 +2755,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
 	      c->ts.type = BT_INTEGER;
 	      c->ts.kind = 4;
 	      c->attr.access = ACCESS_PRIVATE;
+	      c->attr.artificial = 1;
 	      hash = gfc_intrinsic_hash_value (ts);
 	      c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
 						 NULL, hash);
@@ -2759,6 +2766,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
 	      c->ts.type = BT_INTEGER;
 	      c->ts.kind = gfc_size_kind;
 	      c->attr.access = ACCESS_PRIVATE;
+	      c->attr.artificial = 1;
 
 	      /* Build a minimal expression to make use of
 		 target-memory.c/gfc_element_size for 'size'.  Special handling
@@ -2782,6 +2790,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
 		goto cleanup;
 	      c->attr.pointer = 1;
 	      c->attr.access = ACCESS_PRIVATE;
+	      c->attr.artificial = 1;
 	      c->ts.type = BT_VOID;
 	      c->initializer = gfc_get_null_expr (NULL);
 
@@ -2790,6 +2799,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
 		goto cleanup;
 	      c->attr.pointer = 1;
 	      c->attr.access = ACCESS_PRIVATE;
+	      c->attr.artificial = 1;
 	      c->ts.type = BT_VOID;
 	      c->initializer = gfc_get_null_expr (NULL);
 
@@ -2798,16 +2808,17 @@ find_intrinsic_vtab (gfc_typespec *ts)
 		goto cleanup;
 	      c->attr.proc_pointer = 1;
 	      c->attr.access = ACCESS_PRIVATE;
+	      c->attr.artificial = 1;
 	      c->tb = XCNEW (gfc_typebound_proc);
 	      c->tb->ppc = 1;
 
 	      if (ts->type != BT_CHARACTER)
-		name = xasprintf ("__copy_%s", tname);
+		name = gfc_get_string ("__copy_%s", tname);
 	      else
 		{
 		  /* __copy is always the same for characters.
 		     Check to see if copy function already exists.  */
-		  name = xasprintf ("__copy_character_%d", ts->kind);
+		  name = gfc_get_string ("__copy_character_%d", ts->kind);
 		  contained = ns->contained;
 		  for (; contained; contained = contained->sibling)
 		    if (contained->proc_name
@@ -2829,6 +2840,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
 	      copy->attr.flavor = FL_PROCEDURE;
 	      copy->attr.subroutine = 1;
 	      copy->attr.pure = 1;
+	      copy->attr.artificial = 1;
 	      copy->attr.if_source = IFSRC_DECL;
 	      /* This is elemental so that arrays are automatically
 		 treated correctly by the scalarizer.  */
@@ -2851,6 +2863,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
 	      dst->ts.kind = ts->kind;
 	      dst->attr.flavor = FL_VARIABLE;
 	      dst->attr.dummy = 1;
+	      dst->attr.artificial = 1;
 	      dst->attr.intent = INTENT_INOUT;
 	      gfc_set_sym_referenced (dst);
 	      copy->formal->next = gfc_get_formal_arglist ();
@@ -2877,7 +2890,6 @@ find_intrinsic_vtab (gfc_typespec *ts)
 	  vtab->ts.u.derived = vtype;
 	  vtab->value = gfc_default_initializer (&vtab->ts);
 	}
-      free (name);
     }
 
   found_sym = vtab;
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index ab88ab5e9c1..04aa43af1d5 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -4458,7 +4458,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
 	      upe->attr.zero_comp = 1;
 	      if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL,
 				   &gfc_current_locus))
-	      return MATCH_ERROR;
+		return MATCH_ERROR;
 	    }
 	  else
 	    {
@@ -8342,7 +8342,7 @@ gfc_match_end (gfc_statement *st)
     case COMP_SUBROUTINE:
       *st = ST_END_SUBROUTINE;
       if (!abreviated_modproc_decl)
-      target = " subroutine";
+	target = " subroutine";
       else
 	target = " procedure";
       eos_ok = !contained_procedure ();
@@ -8351,7 +8351,7 @@ gfc_match_end (gfc_statement *st)
     case COMP_FUNCTION:
       *st = ST_END_FUNCTION;
       if (!abreviated_modproc_decl)
-      target = " function";
+	target = " function";
       else
 	target = " procedure";
       eos_ok = !contained_procedure ();
@@ -10473,7 +10473,7 @@ gfc_match_derived_decl (void)
   match m;
   match is_type_attr_spec = MATCH_NO;
   bool seen_attr = false;
-  gfc_interface *intr = NULL, *head;
+  gfc_interface *intr = NULL;
   bool parameterized_type = false;
   bool seen_colons = false;
 
@@ -10498,16 +10498,15 @@ gfc_match_derived_decl (void)
      been added to 'attr' but now the parent type must be found and
      checked.  */
   if (parent[0])
-    extended = check_extended_derived_type (parent);
-
-  if (parent[0] && !extended)
-    return MATCH_ERROR;
+    {
+      extended = check_extended_derived_type (parent);
+      if (extended == NULL)
+	return MATCH_ERROR;
+    }
 
   m = gfc_match (" ::");
   if (m == MATCH_YES)
-    {
-      seen_colons = true;
-    }
+    seen_colons = true;
   else if (seen_attr)
     {
       gfc_error ("Expected :: in TYPE definition at %C");
@@ -10582,7 +10581,7 @@ gfc_match_derived_decl (void)
   if (gensym->attr.dummy)
     {
       gfc_error ("Dummy argument %qs at %L cannot be a derived type at %C",
-		 name, &gensym->declared_at);
+		 gensym->name, &gensym->declared_at);
       return MATCH_ERROR;
     }
 
@@ -10599,13 +10598,12 @@ gfc_match_derived_decl (void)
     {
       /* Use upper case to save the actual derived-type symbol.  */
       gfc_get_symbol (gfc_dt_upper_string (gensym->name), NULL, &sym);
-      sym->name = gfc_get_string ("%s", gensym->name);
-      head = gensym->generic;
+      sym->name = gensym->name;
+      sym->declared_at = gfc_current_locus;
       intr = gfc_get_interface ();
       intr->sym = sym;
       intr->where = gfc_current_locus;
-      intr->sym->declared_at = gfc_current_locus;
-      intr->next = head;
+      intr->next = gensym->generic;
       gensym->generic = intr;
       gensym->attr.if_source = IFSRC_DECL;
     }
@@ -10662,15 +10660,6 @@ gfc_match_derived_decl (void)
       gfc_component *p;
       gfc_formal_arglist *f, *g, *h;
 
-      /* Add the extended derived type as the first component.  */
-      gfc_add_component (sym, parent, &p);
-      extended->refs++;
-      gfc_set_sym_referenced (extended);
-
-      p->ts.type = BT_DERIVED;
-      p->ts.u.derived = extended;
-      p->initializer = gfc_default_initializer (&p->ts);
-
       /* Set extension level.  */
       if (extended->attr.extension == 255)
 	{
@@ -10680,6 +10669,16 @@ gfc_match_derived_decl (void)
 		     extended->name, &extended->declared_at);
 	  return MATCH_ERROR;
 	}
+
+      /* Add the extended derived type as the first component.  */
+      gfc_add_component (sym, parent, &p);
+      extended->refs++;
+      gfc_set_sym_referenced (extended);
+
+      p->ts.type = BT_DERIVED;
+      p->ts.u.derived = extended;
+      p->initializer = gfc_default_initializer (&p->ts);
+
       sym->attr.extension = extended->attr.extension + 1;
 
       /* Provide the links between the extended type and its extension.  */
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 12aa80ec45c..fcbff0c1dcf 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -3581,6 +3581,7 @@ parse_derived (void)
 	{
 	case ST_NONE:
 	  unexpected_eof ();
+	  break; /* never reached */
 
 	case ST_DATA_DECL:
 	case ST_PROCEDURE:
@@ -3640,9 +3641,7 @@ endType:
 			 "TYPE statement");
 
 	  if (seen_sequence)
-	    {
-	      gfc_error ("Duplicate SEQUENCE statement at %C");
-	    }
+	    gfc_error ("Duplicate SEQUENCE statement at %C");
 
 	  seen_sequence = 1;
 	  gfc_add_sequence (&gfc_current_block ()->attr,
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 1f4abd08720..a9a1103e049 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -2588,7 +2588,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
   gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name,
 			  sym->binding_label != NULL);
 
-  if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
+  if (gsym->type != GSYM_UNKNOWN && gsym->type != type)
     gfc_global_used (gsym, where);
 
   if ((sym->attr.if_source == IFSRC_UNKNOWN
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 91798f2a3a5..1a1e4551355 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -440,9 +440,6 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where)
   const char *a1, *a2;
   int standard;
 
-  if (attr->artificial)
-    return true;
-
   if (where == NULL)
     where = &gfc_current_locus;
 
@@ -1773,7 +1770,7 @@ gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
   /* Copying a procedure dummy argument for a module procedure in a
      submodule results in the flavor being copied and would result in
      an error without this.  */
-  if (attr->flavor == f && f == FL_PROCEDURE
+  if (f == FL_PROCEDURE && attr->flavor == f
       && gfc_new_block && gfc_new_block->abr_modproc_decl)
     return true;
 
@@ -3155,7 +3152,6 @@ gfc_new_symbol (const char *name, gfc_namespace *ns)
   gfc_symbol *p;
 
   p = XCNEW (gfc_symbol);
-
   gfc_clear_ts (&p->ts);
   gfc_clear_attr (&p->attr);
   p->ns = ns;
@@ -3397,7 +3393,6 @@ gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
       p = gfc_new_symbol (name, ns);
 
       /* Add to the list of tentative symbols.  */
-      p->old_symbol = NULL;
       p->mark = 1;
       p->gfc_new = 1;
       latest_undo_chgset->syms.safe_push (p);
@@ -3405,7 +3400,6 @@ gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
       st = gfc_new_symtree (&ns->sym_root, name);
       st->n.sym = p;
       p->refs++;
-
     }
   else
     {
@@ -4835,9 +4829,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
 	      gfc_derived_types->dt_next = tmp_sym;
 	    }
 	  else
-	    {
-	      tmp_sym->dt_next = tmp_sym;
-	    }
+	    tmp_sym->dt_next = tmp_sym;
 	  gfc_derived_types = tmp_sym;
         }
 
@@ -5013,9 +5005,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
 	      gfc_derived_types->dt_next = dt_sym;
 	    }
 	  else
-	    {
-	      dt_sym->dt_next = dt_sym;
-	    }
+	    dt_sym->dt_next = dt_sym;
 	  gfc_derived_types = dt_sym;
 
 	  gfc_add_component (dt_sym, "c_address", &tmp_comp);
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index e7aec3845d3..56ddb6629bc 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -9033,7 +9033,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
 	  gfc_add_expr_to_block (&block, tmp);
 	}
     }
-  else if (!cm->attr.artificial)
+  else
     {
       /* Scalar component (excluding deferred parameters).  */
       gfc_init_se (&se, NULL);

Re: [PATCH,FORTRAN] Fix memory leak in finalization wrappers

[Mikael Morin]

Le 07/11/2021 à 00:56, Bernhard Reutner-Fischer a écrit :
> On Sat, 6 Nov 2021 13:04:07 +0100
> Mikael Morin <morin-mikael@orange.fr> wrote:
> 
>> Le 05/11/2021 à 23:08, Bernhard Reutner-Fischer a écrit :
>>> On Fri, 5 Nov 2021 19:46:16 +0100
>>> Mikael Morin <morin-mikael@orange.fr> wrote:
>>>    
>>>> I’m a bit concerned by the loss of the null_expr’s type interface.
>>>> I can’t convince myself that it’s either absolutely necessary or
>>>> completely useless.
>>>
>>> It's a delicate spot, yes, but i do think they are completely useless.
>>> If we do NOT need a finalization, the initializer can (and has to be
>>> AFAIU) be a null_expr and AFAICS then does not need an interface.
>>>    
>> Well, the null pointer itself doesn’t need a type, but I think it’s
>> better if the pointer it’s assigned to has a type different from void*.
>> It will (hopefully) help the middle-end optimizers downstream.
> 
> I would not expect this to help all that much or at all TBH.
> 
> So i compiled
> for i in $(grep -li final $(grep -L dg-error /scratch/src/gcc-12.mine/gcc/testsuite/gfortran.dg/*.f*)); do gfortran -O2 -fcoarray=single -c $i -g -g3 -ggdb3 -fdump-tree-original -fdump-tree-optimized;done
> and diffed all .original and .optimized dumps against pristine trunk
> and they are identical.
> 
> I inspected and ran the binary from finalize_14 and there is no change
> in the leaks compared to pristine trunk. The 3 shape_w in p leak as
> they used to. I do remember that finalize_14 was a good testcase, in
> sum i glared at it for quite some time ;)

In fact, the interface is not used.
the type is built in gfc_get_ppc_type which has the following.

   /* Explicit interface.  */
   if (c->attr.if_source != IFSRC_UNKNOWN && c->ts.interface)
     return build_pointer_type (gfc_get_function_type (c->ts.interface));

As components have no if_source attribute set, the type is not built 
here and a default function type is built further down without interface 
information.
This is probably unintended as the components’ initializers carefully 
set an if_source attribute.

The problem has been identified before ; see vaguely related posts from 
FX in september 2020.

Anyway, I don’t think your changes will have negative impact then, and 
it makes things more readable, so I’m fine with it after all; OK.

>>
>> I will see if I can manage to create a testcase where it makes a
>> difference (don’t hold your breath, I don’t even have a bootstrapped
>> compiler ready yet).
>>
> That'd be great, TIA!
> []
> 
I’ve given up eventually.

> btw.. Just because it's vagely related.
> I think f8add009ce300f24b75e9c2e2cc5dd944a020c28 for
> PR fortran/88009 (ICE in find_intrinsic_vtab, at fortran/class.c:2761)
> is incomplete in that i think all the internal class helpers should be
> flagged artificial. All these symbols built in gfc_build_class_symbol,
> generate_finalization_wrapper, gfc_find_derived_vtab etc.
> Looking at the history it seems the artificial bit often was forgotten.

I guess so, yes...

> And most importantly i think it is not correct to ignore artificial in
> gfc_check_conflict!
> 
Well, it’s not correct to throw errors at users for things they haven’t 
written and that they don’t control.

Re: [PATCH,FORTRAN] Fix memory leak in finalization wrappers

[Bernhard Reutner-Fischer]

On Sun, 7 Nov 2021 13:32:34 +0100
Mikael Morin <morin-mikael@orange.fr> wrote:

> > btw.. Just because it's vagely related.
> > I think f8add009ce300f24b75e9c2e2cc5dd944a020c28 for
> > PR fortran/88009 (ICE in find_intrinsic_vtab, at fortran/class.c:2761)
> > is incomplete in that i think all the internal class helpers should be
> > flagged artificial. All these symbols built in gfc_build_class_symbol,
> > generate_finalization_wrapper, gfc_find_derived_vtab etc.
> > Looking at the history it seems the artificial bit often was forgotten.  
> 
> I guess so, yes...
> 
> > And most importantly i think it is not correct to ignore artificial in
> > gfc_check_conflict!
> >   
> Well, it’s not correct to throw errors at users for things they haven’t 
> written and that they don’t control.

oops, i forgot to add the hunk to the patch to drain complaints to
the user 1).

Of course we don't want the error to be user-visible, but i think we do
want to check_conflicts (e.g. gfortran.dg/pr95587.f90 regresses via an
unspecific Unclassifiable statement; I assume we should copy all or at
least some sym attribs to the corresponding CLASS_DATA attribs which i
think makes sense for consistency anyway).

1)
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 1a1e4551355..9df23f314df 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -898,6 +898,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where)
   return true;
 
 conflict:
+  /* It would be wrong to complain about artificial code.  */
+  if (attr->artificial)
+    return false;
+
   if (name == NULL)
     gfc_error ("%s attribute conflicts with %s attribute at %L",
 	       a1, a2, where);