Patchwork [Fortran] Deallocate CLASS(...),INTENT(OUT),allocatable arrays

login
register
mail settings
Submitter Tobias Burnus
Date May 22, 2013, 9:28 p.m.
Message ID <519D3886.5050303@net-b.de>
Download mbox | patch
Permalink /patch/245722/
State New
Headers show

Comments

Tobias Burnus - May 22, 2013, 9:28 p.m.
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.

Patch

2013-05-22  Tobias Burnus  <burnus@net-b.de>

	* trans-expr.c (gfc_conv_procedure_call): Deallocate
	polymorphic arrays for allocatable intent(out) dummies.

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..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" } }