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

9 files changed, 273 insertions, 151 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 2043691..d8ff752 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,25 @@
+2013-06-04  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-01  Janus Weil  <janus@gcc.gnu.org>
 	    Mikael Morin  <mikael@gcc.gnu.org>
 
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);
     }
 
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index d00e156..8d9e461 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -42,7 +42,7 @@ void gfc_trans_dummy_array_bias (gfc_symbol *, tree, gfc_wrapped_block *);
 /* Generate entry and exit code for g77 calling convention arrays.  */
 void gfc_trans_g77_array (gfc_symbol *, gfc_wrapped_block *);
 /* Generate code to deallocate an array, if it is allocated.  */
-tree gfc_trans_dealloc_allocated (tree, bool);
+tree gfc_trans_dealloc_allocated (tree, bool, gfc_expr *);
 
 tree gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank);
 
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 100ec18..b0e3ffc 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -3872,7 +3872,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 
 	      /* Deallocate when leaving the scope. Nullifying is not
 		 needed.  */
-	      if (!sym->attr.result && !sym->attr.dummy)
+	      if (!sym->attr.result && !sym->attr.dummy
+		  && !sym->ns->proc_name->attr.is_main_program)
 		{
 		  if (sym->ts.type == BT_CLASS
 		      && CLASS_DATA (sym)->attr.codimension)
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 07b0fa6..9d07345 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -4274,10 +4274,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		      if (e->ts.type == BT_CLASS)
 			ptr = gfc_class_data_get (ptr);
 
-		      tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
-							NULL_TREE, NULL_TREE,
-							NULL_TREE, true, NULL,
-							false);
+		      tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
+							       true, e, e->ts);
 		      gfc_add_expr_to_block (&block, tmp);
 		      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
 					     void_type_node, ptr,
@@ -4409,8 +4407,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		  else
 		    tmp = gfc_finish_block (&block);
 
-		      gfc_add_expr_to_block (&se->pre, tmp);
-}
+		  gfc_add_expr_to_block (&se->pre, tmp);
+		}
 
 	      /* The conversion does not repackage the reference to a class
 	         array - _data descriptor.  */
@@ -4511,7 +4509,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		{
 		  tmp = build_fold_indirect_ref_loc (input_location,
 						     parmse.expr);
-		  tmp = gfc_trans_dealloc_allocated (tmp, false);
+		  tmp = gfc_trans_dealloc_allocated (tmp, false, e);
 		  if (fsym->attr.optional
 		      && e->expr_type == EXPR_VARIABLE
 		      && e->symtree->n.sym->attr.optional)
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index 882927e..2765561 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -325,7 +325,7 @@ gfc_omp_clause_dtor (tree clause ATTRIBUTE_UNUSED, tree decl)
 
   /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
      to be deallocated if they were allocated.  */
-  return gfc_trans_dealloc_allocated (decl, false);
+  return gfc_trans_dealloc_allocated (decl, false, NULL);
 }
 
 
@@ -707,7 +707,8 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
       gfc_start_block (&block);
       gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false,
 			     true));
-      gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl, false));
+      gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl, false,
+								  NULL));
       stmt = gfc_finish_block (&block);
     }
   else
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 7759b86..e2d0110 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5398,7 +5398,8 @@ gfc_trans_deallocate (gfc_code *code)
 
       if (expr->rank || gfc_is_coarray (expr))
 	{
-	  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
+	  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp
+	      && !gfc_is_finalizable (expr->ts.u.derived, NULL))
 	    {
 	      gfc_ref *ref;
 	      gfc_ref *last = NULL;
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 8211573..a1ea300 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -838,6 +838,223 @@ gfc_call_free (tree var)
 }
 
 
+/* Build a call to a FINAL procedure, which finalizes "var".  */
+
+static tree
+gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
+		      bool fini_coarray, gfc_expr *class_size)
+{
+  stmtblock_t block;
+  gfc_se se;
+  tree final_fndecl, array, size, tmp;
+  symbol_attribute attr;
+
+  gcc_assert (final_wrapper->expr_type == EXPR_VARIABLE);
+  gcc_assert (var);
+
+  gfc_init_se (&se, NULL);
+  gfc_conv_expr (&se, final_wrapper);
+  final_fndecl = se.expr;
+  if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
+    final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);
+
+  if (ts.type == BT_DERIVED)
+    {
+      tree elem_size;
+
+      gcc_assert (!class_size);
+      elem_size = gfc_typenode_for_spec (&ts);
+      elem_size = TYPE_SIZE_UNIT (elem_size);
+      size = fold_convert (gfc_array_index_type, elem_size);
+
+      gfc_init_se (&se, NULL);
+      se.want_pointer = 1;
+      if (var->rank)
+	{
+	  se.descriptor_only = 1;
+	  gfc_conv_expr_descriptor (&se, var);
+	  array = se.expr;
+	}
+      else
+	{
+	  gfc_conv_expr (&se, var);
+	  gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
+	  array = se.expr;
+
+	  /* No copy back needed, hence set attr's allocatable/pointer
+	     to zero.  */
+	  gfc_clear_attr (&attr);
+	  gfc_init_se (&se, NULL);
+	  array = gfc_conv_scalar_to_descriptor (&se, array, attr);
+	  gcc_assert (se.post.head == NULL_TREE);
+	}
+    }
+  else
+    {
+      gfc_expr *array_expr;
+      gcc_assert (class_size);
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr (&se, class_size);
+      gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
+      size = se.expr;
+
+      array_expr = gfc_copy_expr (var);
+      gfc_init_se (&se, NULL);
+      se.want_pointer = 1;
+      if (array_expr->rank)
+	{
+	  gfc_add_class_array_ref (array_expr);
+	  se.descriptor_only = 1;
+	  gfc_conv_expr_descriptor (&se, array_expr);
+	  array = se.expr;
+	}
+      else
+	{
+	  gfc_add_data_component (array_expr);
+	  gfc_conv_expr (&se, array_expr);
+	  gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
+	  array = se.expr;
+	  if (TREE_CODE (array) == ADDR_EXPR
+	      && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array, 0))))
+	    tmp = TREE_OPERAND (array, 0);
+
+	  if (!gfc_is_coarray (array_expr))
+	    {
+	      /* No copy back needed, hence set attr's allocatable/pointer
+		 to zero.  */
+	      gfc_clear_attr (&attr);
+	      gfc_init_se (&se, NULL);
+	      array = gfc_conv_scalar_to_descriptor (&se, array, attr);
+	    }
+	  gcc_assert (se.post.head == NULL_TREE);
+	}
+      gfc_free_expr (array_expr);
+    }
+
+  if (!POINTER_TYPE_P (TREE_TYPE (array)))
+    array = gfc_build_addr_expr (NULL, array);
+
+  gfc_start_block (&block);
+  gfc_add_block_to_block (&block, &se.pre);
+  tmp = build_call_expr_loc (input_location,
+			     final_fndecl, 3, array,
+			     size, fini_coarray ? boolean_true_node
+						: boolean_false_node);
+  gfc_add_block_to_block (&block, &se.post);
+  gfc_add_expr_to_block (&block, tmp);
+  return gfc_finish_block (&block);
+}
+
+
+/* Add a call to the finalizer, using the passed *expr. Returns
+   true when a finalizer call has been inserted.  */
+
+bool
+gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2)
+{
+  tree tmp;
+  gfc_ref *ref;
+  gfc_expr *expr;
+  gfc_expr *final_expr = NULL;
+  gfc_expr *elem_size = NULL;
+  bool has_finalizer = false;
+
+  if (!expr2 || (expr2->ts.type != BT_DERIVED && expr2->ts.type != BT_CLASS))
+    return false;
+
+  if (expr2->ts.type == BT_DERIVED)
+    {
+      gfc_is_finalizable (expr2->ts.u.derived, &final_expr);
+      if (!final_expr)
+        return false;
+    }
+
+  /* If we have a class array, we need go back to the class
+     container. */
+  expr = gfc_copy_expr (expr2);
+
+  if (expr->ref && expr->ref->next && !expr->ref->next->next
+      && expr->ref->next->type == REF_ARRAY
+      && expr->ref->type == REF_COMPONENT
+      && strcmp (expr->ref->u.c.component->name, "_data") == 0)
+    {
+      gfc_free_ref_list (expr->ref);
+      expr->ref = NULL;
+    }
+  else
+    for (ref = expr->ref; ref; ref = ref->next)
+      if (ref->next && ref->next->next && !ref->next->next->next
+         && ref->next->next->type == REF_ARRAY
+         && ref->next->type == REF_COMPONENT
+         && strcmp (ref->next->u.c.component->name, "_data") == 0)
+       {
+         gfc_free_ref_list (ref->next);
+         ref->next = NULL;
+       }
+
+  if (expr->ts.type == BT_CLASS)
+    {
+      has_finalizer = gfc_is_finalizable (expr->ts.u.derived, NULL);
+
+      if (!expr2->rank && !expr2->ref && CLASS_DATA (expr2->symtree->n.sym)->as)
+	expr->rank = CLASS_DATA (expr2->symtree->n.sym)->as->rank;
+
+      final_expr = gfc_copy_expr (expr);
+      gfc_add_vptr_component (final_expr);
+      gfc_add_component_ref (final_expr, "_final");
+
+      elem_size = gfc_copy_expr (expr);
+      gfc_add_vptr_component (elem_size);
+      gfc_add_component_ref (elem_size, "_size");
+    }
+
+  gcc_assert (final_expr->expr_type == EXPR_VARIABLE);
+
+  tmp = gfc_build_final_call (expr->ts, final_expr, expr,
+			      false, elem_size);
+
+  if (expr->ts.type == BT_CLASS && !has_finalizer)
+    {
+      tree cond;
+      gfc_se se;
+
+      gfc_init_se (&se, NULL);
+      se.want_pointer = 1;
+      gfc_conv_expr (&se, final_expr);
+      cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+			      se.expr, build_int_cst (TREE_TYPE (se.expr), 0));
+
+      /* For CLASS(*) not only sym->_vtab->_final can be NULL
+	 but already sym->_vtab itself.  */
+      if (UNLIMITED_POLY (expr))
+	{
+	  tree cond2;
+	  gfc_expr *vptr_expr;
+
+	  vptr_expr = gfc_copy_expr (expr);
+	  gfc_add_vptr_component (vptr_expr);
+
+	  gfc_init_se (&se, NULL);
+	  se.want_pointer = 1;
+	  gfc_conv_expr (&se, vptr_expr);
+	  gfc_free_expr (vptr_expr);
+
+	  cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+				   se.expr,
+				   build_int_cst (TREE_TYPE (se.expr), 0));
+	  cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+				  boolean_type_node, cond2, cond);
+	}
+
+      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;
+}
+
 
 /* User-deallocate; we emit the code directly from the front-end, and the
    logic is the same as the previous library function:
@@ -930,6 +1147,7 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
 
   /* When POINTER is not NULL, we free it.  */
   gfc_start_block (&non_null);
+  gfc_add_finalizer_call (&non_null, expr);
   if (!coarray || gfc_option.coarray != GFC_FCOARRAY_LIB)
     {
       tmp = build_call_expr_loc (input_location,
@@ -1022,125 +1240,6 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
 }
 
 
-/* Build a call to a FINAL procedure, which finalizes "var".  */
-
-tree
-gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
-		      bool fini_coarray, gfc_expr *class_size)
-{
-  stmtblock_t block;
-  gfc_se se;
-  tree final_fndecl, array, size, tmp;
-  symbol_attribute attr;
-
-  gcc_assert (final_wrapper->expr_type == EXPR_VARIABLE);
-  gcc_assert (var);
-
-  gfc_init_se (&se, NULL);
-  gfc_conv_expr (&se, final_wrapper);
-  final_fndecl = se.expr;
-  if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
-    final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);
-
-  attr = gfc_expr_attr (var);
-
-  if (ts.type == BT_DERIVED)
-    {
-      tree elem_size;
-
-      gcc_assert (!class_size);
-      elem_size = gfc_typenode_for_spec (&ts);
-      elem_size = TYPE_SIZE_UNIT (elem_size);
-      size = fold_convert (gfc_array_index_type, elem_size);
-
-      gfc_init_se (&se, NULL);
-      se.want_pointer = 1;
-      if (var->rank || attr.dimension
-	  || (attr.codimension && attr.allocatable
-	      && gfc_option.coarray == GFC_FCOARRAY_LIB))
-	{
-	  if (var->rank == 0)
-	    se.want_coarray = 1;
-	  se.descriptor_only = 1;
-	  gfc_conv_expr_descriptor (&se, var);
-	  array = se.expr;
-	  if (!POINTER_TYPE_P (TREE_TYPE (array)))
-	    array = gfc_build_addr_expr (NULL, array);
-	}
-      else
-	{
-	  gfc_clear_attr (&attr);
-	  gfc_conv_expr (&se, var);
-	  gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
-	  array = se.expr;
-	  if (TREE_CODE (array) == ADDR_EXPR
-	      && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array, 0))))
-	    tmp = TREE_OPERAND (array, 0);
-
-	  gfc_init_se (&se, NULL);
-	  array = gfc_conv_scalar_to_descriptor (&se, array, attr);
-	  array = gfc_build_addr_expr (NULL, array);
-	  gcc_assert (se.post.head == NULL_TREE);
-	}
-    }
-  else
-    {
-      gfc_expr *array_expr;
-      gcc_assert (class_size);
-      gfc_init_se (&se, NULL);
-      gfc_conv_expr (&se, class_size);
-      gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
-      size = se.expr;
-
-      array_expr = gfc_copy_expr (var);
-      gfc_init_se (&se, NULL);
-      se.want_pointer = 1;
-      if (array_expr->rank || attr.dimension
-	  || (attr.codimension && attr.allocatable
-	      && gfc_option.coarray == GFC_FCOARRAY_LIB))
-	{
-	  gfc_add_class_array_ref (array_expr);
-	  if (array_expr->rank == 0)
-	    se.want_coarray = 1;
-	  se.descriptor_only = 1;
-	  gfc_conv_expr_descriptor (&se, array_expr);
-	  array = se.expr;
-	  if (! POINTER_TYPE_P (TREE_TYPE (array)))
-	    array = gfc_build_addr_expr (NULL, array);
-	}
-      else
-	{
-	  gfc_clear_attr (&attr);
-	  gfc_add_data_component (array_expr);
-	  gfc_conv_expr (&se, array_expr);
-	  gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
-	  array = se.expr;
-	  if (TREE_CODE (array) == ADDR_EXPR
-	      && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array, 0))))
-	    tmp = TREE_OPERAND (array, 0);
-
-	  /* attr: Argument is neither a pointer/allocatable,
-	     i.e. no copy back needed */
-	  gfc_init_se (&se, NULL);
-	  array = gfc_conv_scalar_to_descriptor (&se, array, attr);
-	  array = gfc_build_addr_expr (NULL, array);
-	  gcc_assert (se.post.head == NULL_TREE);
-	}
-      gfc_free_expr (array_expr);
-    }
-
-  gfc_start_block (&block);
-  gfc_add_block_to_block (&block, &se.pre);
-  tmp = build_call_expr_loc (input_location,
-			     final_fndecl, 3, array,
-			     size, fini_coarray ? boolean_true_node
-						: boolean_false_node);
-  gfc_add_block_to_block (&block, &se.post);
-  gfc_add_expr_to_block (&block, tmp);
-  return gfc_finish_block (&block);
-}
-
-
 /* Generate code for deallocation of allocatable scalars (variables or
    components). Before the object itself is freed, any allocatable
    subcomponents are being deallocated.  */
@@ -1151,6 +1250,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
 {
   stmtblock_t null, non_null;
   tree cond, tmp, error;
+  bool finalizable;
 
   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
 			  build_int_cst (TREE_TYPE (pointer), 0));
@@ -1195,20 +1295,13 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
   gfc_start_block (&non_null);
 
   /* Free allocatable components.  */
-  if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
+  finalizable = gfc_add_finalizer_call (&non_null, expr);
+  if (!finalizable && ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
     {
       tmp = build_fold_indirect_ref_loc (input_location, pointer);
       tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
       gfc_add_expr_to_block (&non_null, tmp);
     }
-  else if (ts.type == BT_CLASS
-	   && ts.u.derived->components->ts.u.derived->attr.alloc_comp)
-    {
-      tmp = build_fold_indirect_ref_loc (input_location, pointer);
-      tmp = gfc_deallocate_alloc_comp (ts.u.derived->components->ts.u.derived,
-				       tmp, 0);
-      gfc_add_expr_to_block (&non_null, tmp);
-    }
 
   tmp = build_call_expr_loc (input_location,
 			     builtin_decl_explicit (BUILT_IN_FREE), 1,
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 0c0fe5d..06cb63d 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -352,8 +352,7 @@ tree gfc_vtable_final_get (tree);
 tree gfc_get_vptr_from_expr (tree);
 tree gfc_get_class_array_ref (tree, tree);
 tree gfc_copy_class_to_class (tree, tree, tree);
-tree gfc_build_final_call (gfc_typespec, gfc_expr *, gfc_expr *, bool,
-			   gfc_expr *);
+bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *);
 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,