*ping* - Re: [Patch, Fortran] Add end-of-scope finalization (Part 2 of 2)

[Tobias Burnus <burnus at net-b dot de>]

Ping.

Change: Updated scan-tree-dump for -m32 / -m64 differences.

Tobias Burnus wrote:
> This patch adds finalization calls for components. This completes the 
> end-of-scope finalization, but it is also called for the LHS of 
> intrinsic assignment. (LHS finalization for the variable itself is 
> still lacking.)
>
> Build and regtested on x86-64-gnu-linux.
> OK for the trunk?
>
> Tobias

2013-06-25  Tobias Burnus  <burnus@net-b.de>

	PR fortran/37336
	* trans.c (gfc_add_comp_finalizer_call): New function.
	* trans.h (gfc_add_comp_finalizer_call): New prototype.
	* trans-array.c (structure_alloc_comps): Call it.

2013-06-25  Tobias Burnus  <burnus@net-b.de>

	PR fortran/37336
	* gfortran.dg/finalize_18.f90: New.

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 96162e5..e4f78f4 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -7553,19 +7553,34 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	  called_dealloc_with_status = false;
 	  gfc_init_block (&tmpblock);
 
+	  if ((c->ts.type == BT_DERIVED && !c->attr.pointer)
+	      || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer))
+	    {
+	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+				      decl, cdecl, NULL_TREE);
+
+	      /* The finalizer frees allocatable components.  */
+	      called_dealloc_with_status
+		= gfc_add_comp_finalizer_call (&tmpblock, comp, c, true);
+	    }
+	  else
+	    comp = NULL_TREE;
+
 	  if (c->attr.allocatable && (c->attr.dimension || c->attr.codimension)
 	      && !c->attr.proc_pointer)
 	    {
-	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
-				      decl, cdecl, NULL_TREE);
+	      if (comp == NULL_TREE)
+		comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+					decl, cdecl, NULL_TREE);
 	      tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension, NULL);
 	      gfc_add_expr_to_block (&tmpblock, tmp);
 	    }
 	  else if (c->attr.allocatable)
 	    {
 	      /* Allocatable scalar components.  */
-	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
-				      decl, cdecl, NULL_TREE);
+	      if (comp == NULL_TREE)
+		comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+					decl, cdecl, NULL_TREE);
 
 	      tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
 						       c->ts);
@@ -7580,10 +7595,11 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	  else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
 	    {
 	      /* Allocatable CLASS components.  */
-	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
-				      decl, cdecl, NULL_TREE);
 
 	      /* Add reference to '_data' component.  */
+	      if (comp == NULL_TREE)
+		comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+					decl, cdecl, NULL_TREE);
 	      tmp = CLASS_DATA (c)->backend_decl;
 	      comp = fold_build3_loc (input_location, COMPONENT_REF,
 				      TREE_TYPE (tmp), comp, tmp, NULL_TREE);
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index f17eaca..53a0669 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -948,6 +948,102 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
 }
 
 
+bool
+gfc_add_comp_finalizer_call (stmtblock_t *block, tree decl, gfc_component *comp,
+			     bool fini_coarray)
+{
+  gfc_se se;
+  stmtblock_t block2;
+  tree final_fndecl, size, array, tmp, cond;
+  symbol_attribute attr;
+  gfc_expr *final_expr = NULL;
+
+  if (comp->ts.type != BT_DERIVED && comp->ts.type != BT_CLASS)
+    return false;
+
+  gfc_init_block (&block2);
+
+  if (comp->ts.type == BT_DERIVED)
+    {
+      if (comp->attr.pointer)
+	return false;
+
+      gfc_is_finalizable (comp->ts.u.derived, &final_expr);
+      if (!final_expr)
+        return false;
+
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr (&se, final_expr);
+      final_fndecl = se.expr;
+      size = gfc_typenode_for_spec (&comp->ts);
+      size = TYPE_SIZE_UNIT (size);
+      size = fold_convert (gfc_array_index_type, size);
+
+      array = decl;
+    }
+  else /* comp->ts.type == BT_CLASS.  */
+    {
+      if (CLASS_DATA (comp)->attr.class_pointer)
+	return false;
+
+      gfc_is_finalizable (CLASS_DATA (comp)->ts.u.derived, &final_expr);
+      final_fndecl = gfc_vtable_final_get (decl);
+      size = gfc_vtable_size_get (decl);
+      array = gfc_class_data_get (decl);
+    }
+
+  if (comp->attr.allocatable
+      || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable))
+    {
+      tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array))
+	    ?  gfc_conv_descriptor_data_get (array) : array;
+      cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			    tmp, fold_convert (TREE_TYPE (tmp),
+						 null_pointer_node));
+    }
+  else
+    cond = boolean_true_node;
+
+  if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array)))
+    {
+      gfc_clear_attr (&attr);
+      gfc_init_se (&se, NULL);
+      array = gfc_conv_scalar_to_descriptor (&se, array, attr);
+      gfc_add_block_to_block (&block2, &se.pre);
+      gcc_assert (se.post.head == NULL_TREE);
+    }
+
+  if (!POINTER_TYPE_P (TREE_TYPE (array)))
+    array = gfc_build_addr_expr (NULL, array);
+
+  if (!final_expr)
+    {
+      tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			     final_fndecl,
+			     fold_convert (TREE_TYPE (final_fndecl),
+					   null_pointer_node));
+      cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+			      boolean_type_node, cond, tmp);
+    }
+
+  if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
+    final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);
+
+  tmp = build_call_expr_loc (input_location,
+			     final_fndecl, 3, array,
+			     size, fini_coarray ? boolean_true_node
+						: boolean_false_node);
+  gfc_add_expr_to_block (&block2, tmp);
+  tmp = gfc_finish_block (&block2);
+
+  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
+			 build_empty_stmt (input_location));
+  gfc_add_expr_to_block (block, tmp);
+
+  return true;
+}
+
+
 /* Add a call to the finalizer, using the passed *expr. Returns
    true when a finalizer call has been inserted.  */
 
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 06cb63d..424ce7a 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -353,6 +353,8 @@ tree gfc_get_vptr_from_expr (tree);
 tree gfc_get_class_array_ref (tree, tree);
 tree gfc_copy_class_to_class (tree, tree, tree);
 bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *);
+bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool);
+
 void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree, bool,
 				bool);
 void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool, bool,
--- /dev/null	2013-06-28 09:04:44.785079259 +0200
+++ gcc/gcc/testsuite/gfortran.dg/finalize_18.f90	2013-06-28 09:32:48.187122781 +0200
@@ -0,0 +1,47 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! PR fortran/37336
+!
+module m
+  type t
+  contains
+    final :: fini
+  end type t
+  type t2
+    integer :: ii
+    type(t), allocatable :: aa
+    type(t), allocatable :: bb(:)
+    class(t), allocatable :: cc
+    class(t), allocatable :: dd(:)
+  end type t2
+  integer, save :: cnt = -1
+contains
+  subroutine fini(x)
+     type(t) :: x
+     if (cnt == -1) call abort ()
+     cnt = cnt + 1
+  end subroutine fini
+end module m
+
+use m
+block
+  type(t2) :: y
+  y%ii = 123
+end block
+end
+
+! { dg-final { scan-tree-dump-times "if \\(y.aa != 0B\\)" 2 "original" } }
+! { dg-final { scan-tree-dump-times "if \\(y.cc._data != 0B\\)" 2 "original" } }
+! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.bb.data != 0B\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.dd._data.data != 0B\\)" 1 "original" } }
+
+! { dg-final { scan-tree-dump-times "desc.\[0-9\]+.data = \\(void . restrict\\) y.aa;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "desc.\[0-9\]+.data = \\(void . restrict\\) y.cc._data;" 1 "original" } }
+
+! { dg-final { scan-tree-dump-times "__final_m_T \\(&desc.\[0-9\]+, 0, 1\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__final_m_T \\(&y.bb, 0, 1\\);" 1 "original" } }
+! { dg-final { scan-tree-dump "y.cc._vptr->_final \\(&desc.\[0-9\]+, (\\(integer\\(kind=8\\)\\) |)y.cc._vptr->_size, 1\\);" "original" } }
+! { dg-final { scan-tree-dump "y.dd._vptr->_final \\(&y.dd._data, (\\(integer\\(kind=8\\)\\) |)y.dd._vptr->_size, 1\\);" "original" } }
+
+! { dg-final { cleanup-tree-dump "original" } }