Re: [Patch, Fortran] Deallocate CLASS(...),INTENT(OUT),allocatable arrays

[Tobias Burnus <burnus at net-b dot de>]

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  <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-22  Tobias Burnus  <burnus@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" } }