trans-expr.c (gfc_conv_procedure_call): Deallocate polymorphic arrays for allocatable...

2013-05-28  Tobias Burnus  <burnus@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-28  Tobias Burnus  <burnus@net-b.de>

        * gfortran.dg/class_array_16.f90: New.

From-SVN: r199383

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a8116b03c2b4521977a787db8e16360e76cebf19..b9a4a6998df84e8e3e0862d82c35054ca8fa742b 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+2013-05-28  Tobias Burnus  <burnus@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-28  Dominique d'Humieres  <dominiq@lps.ens.fr>
 
        PR fortran/57435

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index de851a26c03ecce643f263e6574a843c1eb473d1..07b0fa6125ee50ac36ed1aab13854e6580edc6fd 100644 (file)
--- 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.  */
 
@@ -4320,6 +4369,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 1b65f2ca78b3f0cf663d950195cd234d522e4b19..058fd99a14cba9dcdf7d7e2dbb9ec1974d2ff6a8 100644 (file)
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5349,30 +5349,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
@@ -5453,8 +5429,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
        {
@@ -5469,7 +5445,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 ad6a1053a423944c5a669128bab3787013421953..0c0fe5d2058db4c2feba5ffdb13038f06c310298 100644 (file)
--- 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);

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index d89b5be50bec20e9ac97295fb83120548a02c483..fa8802eb2e2e6499792fecb058571afce933d3e4 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2013-05-28  Tobias Burnus  <burnus@net-b.de>
+
+       * gfortran.dg/class_array_16.f90: New.
+
 2013-05-28  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/57435

diff --git a/gcc/testsuite/gfortran.dg/class_array_16.f90 b/gcc/testsuite/gfortran.dg/class_array_16.f90
new file mode 100644 (file)
index 0000000..fc8edbf
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_array_16.f90
@@ -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" } }