On May 22, 2013 23:28Tobias Burnus wrote:
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.
Actually, it turned out to be a bit more complicated: I forgot to test
whether resetting the _vtab worked. Result (as to be expected): It
didn't. I also found out that DEALLOCATE also didn't properly reset the
_vtab. That's now fixed (and tested for) in the attached follow up patch.
(Recall that the standard mandates that an unallocated polymorphic
variable has the declared type.)
Build and regtested on x86-64-gnu-linux.
OK for the trunk?
Tobias
2013-05-22 Tobias Burnus <bur...@net-b.de>
* trans-expr.c (gfc_conv_procedure_call): Deallocate
polymorphic arrays for allocatable intent(out) dummies.
(gfc_reset_vptr): New function, moved from trans-stmt.c
and extended.
* trans-stmt.c (reset_vptr): Remove.
(gfc_trans_deallocate): Update calls.
* trans.h (gfc_reset_vptr): New prototype.
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..650f829 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -214,6 +214,55 @@ gfc_vtable_final_get (tree decl)
#undef VTABLE_FINAL_FIELD
+/* Reset the vptr to the declared type, e.g. after deallocation. */
+
+void
+gfc_reset_vptr (stmtblock_t *block, gfc_expr *e)
+{
+ gfc_expr *rhs, *lhs = gfc_copy_expr (e);
+ gfc_symbol *vtab;
+ tree tmp;
+ gfc_ref *ref;
+
+ /* If we have a class array, we need go back to the class
+ container. */
+ if (lhs->ref && lhs->ref->next && !lhs->ref->next->next
+ && lhs->ref->next->type == REF_ARRAY
+ && lhs->ref->next->u.ar.type == AR_FULL
+ && lhs->ref->type == REF_COMPONENT
+ && strcmp (lhs->ref->u.c.component->name, "_data") == 0)
+ {
+ gfc_free_ref_list (lhs->ref);
+ lhs->ref = NULL;
+ }
+ else
+ for (ref = lhs->ref; ref; ref = ref->next)
+ if (ref->next && ref->next->next && !ref->next->next->next
+ && ref->next->next->type == REF_ARRAY
+ && ref->next->next->u.ar.type == AR_FULL
+ && ref->next->type == REF_COMPONENT
+ && strcmp (ref->next->u.c.component->name, "_data") == 0)
+ {
+ gfc_free_ref_list (ref->next);
+ ref->next = NULL;
+ }
+
+ gfc_add_vptr_component (lhs);
+
+ if (UNLIMITED_POLY (e))
+ rhs = gfc_get_null_expr (NULL);
+ else
+ {
+ vtab = gfc_find_derived_vtab (e->ts.u.derived);
+ rhs = gfc_lval_expr_from_sym (vtab);
+ }
+ tmp = gfc_trans_pointer_assignment (lhs, rhs);
+ gfc_add_expr_to_block (block, tmp);
+ gfc_free_expr (lhs);
+ gfc_free_expr (rhs);
+}
+
+
/* Obtain the vptr of the last class reference in an expression.
Return NULL_TREE if no class reference is found. */
@@ -4334,6 +4383,49 @@ 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);
+ gfc_reset_vptr (&block, e);
+
+ 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,
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 6c5f557..7812934 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5339,30 +5339,6 @@ gfc_trans_allocate (gfc_code * code)
}
-/* Reset the vptr after deallocation. */
-
-static void
-reset_vptr (stmtblock_t *block, gfc_expr *e)
-{
- gfc_expr *rhs, *lhs = gfc_copy_expr (e);
- gfc_symbol *vtab;
- tree tmp;
-
- if (UNLIMITED_POLY (e))
- rhs = gfc_get_null_expr (NULL);
- else
- {
- vtab = gfc_find_derived_vtab (e->ts.u.derived);
- rhs = gfc_lval_expr_from_sym (vtab);
- }
- gfc_add_vptr_component (lhs);
- tmp = gfc_trans_pointer_assignment (lhs, rhs);
- gfc_add_expr_to_block (block, tmp);
- gfc_free_expr (lhs);
- gfc_free_expr (rhs);
-}
-
-
/* Translate a DEALLOCATE statement. */
tree
@@ -5443,8 +5419,8 @@ gfc_trans_deallocate (gfc_code *code)
tmp = gfc_array_deallocate (se.expr, pstat, errmsg, errlen,
label_finish, expr);
gfc_add_expr_to_block (&se.pre, tmp);
- if (UNLIMITED_POLY (al->expr))
- reset_vptr (&se.pre, al->expr);
+ if (al->expr->ts.type == BT_CLASS)
+ gfc_reset_vptr (&se.pre, al->expr);
}
else
{
@@ -5459,7 +5435,7 @@ gfc_trans_deallocate (gfc_code *code)
gfc_add_expr_to_block (&se.pre, tmp);
if (al->expr->ts.type == BT_CLASS)
- reset_vptr (&se.pre, al->expr);
+ gfc_reset_vptr (&se.pre, al->expr);
}
if (code->expr1)
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index ad6a105..0c0fe5d 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -341,6 +341,7 @@ gfc_wrapped_block;
/* Class API functions. */
tree gfc_class_data_get (tree);
tree gfc_class_vptr_get (tree);
+void gfc_reset_vptr (stmtblock_t *, gfc_expr *);
tree gfc_class_set_static_fields (tree, tree, tree);
tree gfc_vtable_hash_get (tree);
tree gfc_vtable_size_get (tree);
--- /dev/null 2013-05-24 09:56:39.975075106 +0200
+++ gcc/gcc/testsuite/gfortran.dg/class_array_16.f90 2013-05-24 11:48:24.534844394 +0200
@@ -0,0 +1,71 @@
+! { dg-do run }
+! { dg-options "-fdump-tree-original" }
+!
+module m
+ implicit none
+ type t
+ end type t
+
+ type, extends(t) :: t2
+ end type t2
+
+ type(t) :: var_t
+ type(t2) :: var_t2
+contains
+ subroutine sub(x)
+ class(t), allocatable, intent(out) :: x(:)
+
+ if (allocated (x)) call abort()
+ if (.not. same_type_as(x, var_t)) call abort()
+
+ allocate (t2 :: x(5))
+ end subroutine sub
+
+ subroutine sub2(x)
+ class(t), allocatable, OPTIONAL, intent(out) :: x(:)
+
+ if (.not. present(x)) return
+ if (allocated (x)) call abort()
+ if (.not. same_type_as(x, var_t)) call abort()
+
+ allocate (t2 :: x(5))
+ end subroutine sub2
+end module m
+
+use m
+implicit none
+class(t), save, allocatable :: y(:)
+
+if (allocated (y)) call abort()
+if (.not. same_type_as(y,var_t)) call abort()
+
+call sub(y)
+if (.not.allocated(y)) call abort()
+if (.not. same_type_as(y, var_t2)) call abort()
+if (size (y) /= 5) call abort()
+
+call sub(y)
+if (.not.allocated(y)) call abort()
+if (.not. same_type_as(y, var_t2)) call abort()
+if (size (y) /= 5) call abort()
+
+deallocate (y)
+if (allocated (y)) call abort()
+if (.not. same_type_as(y,var_t)) call abort()
+
+call sub2()
+
+call sub2(y)
+if (.not.allocated(y)) call abort()
+if (.not. same_type_as(y, var_t2)) call abort()
+if (size (y) /= 5) call abort()
+
+call sub2(y)
+if (.not.allocated(y)) call abort()
+if (.not. same_type_as(y, var_t2)) call abort()
+if (size (y) /= 5) call abort()
+end
+
+! { dg-final { scan-tree-dump-times "__builtin_free" 5 "original" } }
+! { dg-final { scan-tree-dump-times "finally" 0 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
