re PR fortran/37336 ([F03] Finish derived-type finalization)

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

        PR fortran/37336
        * trans.h (gfc_build_final_call): Remove prototype.
        (gfc_add_finalizer_call): Add prototype.
        * trans-array.c (gfc_trans_dealloc_allocated): Support
        * finalization.
        (structure_alloc_comps): Update caller.
        (gfc_trans_deferred_array): Call finalizer.
        * trans-array.h (gfc_trans_dealloc_allocated): Update prototype.
        * trans-decl.c (gfc_trans_deferred_vars): Don't
        * deallocate/finalize
        variables of the main program.
        * trans-expr.c (gfc_conv_procedure_call): Support finalization.
        * trans-openmp.c (gfc_omp_clause_dtor,
        gfc_trans_omp_array_reduction): Update calls.
        * trans-stmt.c (gfc_trans_deallocate): Avoid double deallocation
        of alloc components.
        * trans.c (gfc_add_finalizer_call): New function.
        (gfc_deallocate_with_status,
        gfc_deallocate_scalar_with_status): Call it
        (gfc_build_final_call): Fix handling of scalar coarrays,
        move up in the file and make static.

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

        PR fortran/37336
        * gfortran.dg/finalize_12.f90: New.
        * gfortran.dg/alloc_comp_basics_1.f90: Add BLOCK for
        end of scope finalization.
        * gfortran.dg/alloc_comp_constructor_1.f90: Ditto.
        * gfortran.dg/allocatable_scalar_9.f90: Ditto.
        * gfortran.dg/auto_dealloc_2.f90: Ditto.
        * gfortran.dg/class_19.f03: Ditto.
        * gfortran.dg/coarray_lib_alloc_1.f90: Ditto.
        * gfortran.dg/coarray_lib_alloc_2.f90: Ditto.
        * gfortran.dg/extends_14.f03: Ditto.
        * gfortran.dg/move_alloc_4.f90: Ditto.
        * gfortran.dg/typebound_proc_27.f03: Ditto.

From-SVN: r199643

1 files changed, 16 insertions, 9 deletions

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 8556278..89f26d7 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -7247,7 +7247,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
 /* Generate code to deallocate an array, if it is allocated.  */
 
 tree
-gfc_trans_dealloc_allocated (tree descriptor, bool coarray)
+gfc_trans_dealloc_allocated (tree descriptor, bool coarray, gfc_expr *expr)
 {
   tree tmp;
   tree var;
@@ -7263,7 +7263,7 @@ gfc_trans_dealloc_allocated (tree descriptor, bool coarray)
      are already deallocated are ignored.  */
   tmp = gfc_deallocate_with_status (coarray ? descriptor : var, NULL_TREE,
 				    NULL_TREE, NULL_TREE, NULL_TREE, true,
-				    NULL, coarray);
+				    expr, coarray);
   gfc_add_expr_to_block (&block, tmp);
 
   /* Zero the data pointer.  */
@@ -7552,7 +7552,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	    {
 	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
 				      decl, cdecl, NULL_TREE);
-	      tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension);
+	      tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension, NULL);
 	      gfc_add_expr_to_block (&tmpblock, tmp);
 	    }
 	  else if (c->attr.allocatable)
@@ -7584,7 +7584,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 
 	      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
 	        tmp = gfc_trans_dealloc_allocated (comp,
-					CLASS_DATA (c)->attr.codimension);
+					CLASS_DATA (c)->attr.codimension, NULL);
 	      else
 		{
 		  tmp = gfc_deallocate_scalar_with_status (comp, NULL_TREE, true, NULL,
@@ -8296,7 +8296,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
   stmtblock_t cleanup;
   locus loc;
   int rank;
-  bool sym_has_alloc_comp;
+  bool sym_has_alloc_comp, has_finalizer;
 
   sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
 			|| sym->ts.type == BT_CLASS)
@@ -8383,8 +8383,12 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
 
   /* Allocatable arrays need to be freed when they go out of scope.
      The allocatable components of pointers must not be touched.  */
-  if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
-      && !sym->attr.pointer && !sym->attr.save)
+  has_finalizer = sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED
+		   ? gfc_is_finalizable (sym->ts.u.derived, NULL) : false;
+  if ((!sym->attr.allocatable || !has_finalizer)
+      && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
+      && !sym->attr.pointer && !sym->attr.save
+      && !sym->ns->proc_name->attr.is_main_program)
     {
       int rank;
       rank = sym->as ? sym->as->rank : 0;
@@ -8393,10 +8397,13 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
     }
 
   if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
-      && !sym->attr.save && !sym->attr.result)
+      && !sym->attr.save && !sym->attr.result
+      && !sym->ns->proc_name->attr.is_main_program)
     {
       tmp = gfc_trans_dealloc_allocated (sym->backend_decl,
-					 sym->attr.codimension);
+					 sym->attr.codimension,
+					 has_finalizer
+					 ? gfc_lval_expr_from_sym (sym) : NULL);
       gfc_add_expr_to_block (&cleanup, tmp);
     }