A rather simple patch found while testing the draft finalization patch.
For a "class(...), allocatable, intent(out)" dummy argument, the actual
argument has to be deallocated. That worked for scalar polymorphic vars,
but not for polymorphic arrays.
Build and regtested on x86-64-gnu-linux.
OK for the trunk?
Tobias
PS: I think there is also a related issue for polymorphic arrays and
end-of-scope. I will handle it in a follow-up patch.
2013-05-22 Tobias Burnus <bur...@net-b.de>
* trans-expr.c (gfc_conv_procedure_call): Deallocate
polymorphic arrays for allocatable intent(out) dummies.
2013-05-22 Tobias Burnus <bur...@net-b.de>
* gfortran.dg/class_array_16.f90: New.
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index f8d99fd..ba878e0 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -4334,6 +4334,64 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
{
/* Pass a class array. */
gfc_conv_expr_descriptor (&parmse, e);
+
+ /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
+ allocated on entry, it must be deallocated. */
+ if (fsym->attr.intent == INTENT_OUT
+ && CLASS_DATA (fsym)->attr.allocatable)
+ {
+ stmtblock_t block;
+ tree ptr;
+
+ gfc_init_block (&block);
+ ptr = parmse.expr;
+ ptr = gfc_class_data_get (ptr);
+
+ tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
+ NULL_TREE, NULL_TREE,
+ NULL_TREE, true, e,
+ false);
+ gfc_add_expr_to_block (&block, tmp);
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ void_type_node, ptr,
+ null_pointer_node);
+ gfc_add_expr_to_block (&block, tmp);
+
+ if (UNLIMITED_POLY (fsym))
+ gfc_add_modify (&block, ptr,
+ fold_convert (TREE_TYPE (ptr),
+ null_pointer_node));
+ else
+ {
+ gfc_symbol *vtab;
+ vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
+ tmp = gfc_get_symbol_decl (vtab);
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+ ptr = gfc_class_vptr_get (parmse.expr);
+ gfc_add_modify (&block, ptr,
+ fold_convert (TREE_TYPE (ptr), tmp));
+ }
+ gfc_add_expr_to_block (&block, tmp);
+
+ if (fsym->attr.optional
+ && e->expr_type == EXPR_VARIABLE
+ && (!e->ref
+ || (e->ref->type == REF_ARRAY
+ && !e->ref->u.ar.type != AR_FULL))
+ && e->symtree->n.sym->attr.optional)
+ {
+ tmp = fold_build3_loc (input_location, COND_EXPR,
+ void_type_node,
+ gfc_conv_expr_present (e->symtree->n.sym),
+ gfc_finish_block (&block),
+ build_empty_stmt (input_location));
+ }
+ else
+ tmp = gfc_finish_block (&block);
+
+ gfc_add_expr_to_block (&se->pre, tmp);
+}
+
/* The conversion does not repackage the reference to a class
array - _data descriptor. */
gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
--- /dev/null 2013-05-22 07:37:12.475061900 +0200
+++ gcc/gcc/testsuite/gfortran.dg/class_array_16.f90 2013-05-22 23:12:43.271073681 +0200
@@ -0,0 +1,20 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+module m
+ type t
+ end type t
+contains
+ subroutine sub(x)
+ class(t), allocatable, intent(out) :: x(:)
+ end subroutine sub
+end module m
+
+use m
+class(t), save, allocatable :: y(:)
+call sub(y)
+end
+
+! { dg-final { scan-tree-dump-times "__builtin_free" 1 "original" } }
+! { dg-final { scan-tree-dump-times "finally" 0 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
