[Patch, Fortran] Finalize nonallocatables with INTENT(out)

[Tobias Burnus <burnus@net-b.de>]

[-- Attachment #1: Type: text/plain, Size: 827 bytes --]

This patch adds finalization support for INTENT(out) for nonallocatable 
dummy arguments.

Additionally, it addresses a missed optimization: The previous code 
tried to deallocate allocatable components even if the dummy argument 
was already an allocatable. That's a missed optimization as gfortran 
deallocates allocatables in the caller.

OK for the trunk?

Note: This patch depends on 
http://gcc.gnu.org/ml/fortran/2013-05/msg00134.html

Tobias

PS: There are many more places where finalization should happen, e.g. 
intrinsic assignment (LHS + RHS func/constructor finalization), 
end-of-scope of nonallocatables. And some issues related coarrays, 
elemental+optional, etc.
However, I stop here for the moment as I run out of time - and writing 
on-top patches of not reviewed/committed patches starts to become a chore.

[-- Attachment #2: final-intentout-v2.diff --]
[-- Type: text/x-patch, Size: 5586 bytes --]

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

	PR fortran/37336
	* trans-decl.c (init_intent_out_dt): Call finalizer
	when approriate.

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

	PR fortran/37336
	* gfortran.dg/finalize_10.f90: New.

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 100ec18..7521dee 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -3501,38 +3503,56 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	&& !f->sym->attr.pointer
 	&& f->sym->ts.type == BT_DERIVED)
       {
-	if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
+	tmp = NULL_TREE;
+
+	/* Note: Allocatables are excluded as they are already handled
+	   by the caller.  */
+	if (!f->sym->attr.allocatable
+	    && gfc_is_finalizable (f->sym->ts.u.derived, NULL))
 	  {
-	    tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
-					     f->sym->backend_decl,
-					     f->sym->as ? f->sym->as->rank : 0);
+	    stmtblock_t block;
+	    gfc_expr *e;
+
+	    f->sym->attr.referenced = 1;
+	    e = gfc_lval_expr_from_sym (f->sym);
+	    gfc_add_finalizer_call (&block, e);
+	    gfc_free_expr (e);
+	    tmp = gfc_finish_block (&block);
+	  }
 
-	    if (f->sym->attr.optional
-		|| f->sym->ns->proc_name->attr.entry_master)
-	      {
-		present = gfc_conv_expr_present (f->sym);
-		tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
-				  present, tmp,
-				  build_empty_stmt (input_location));
-	      }
+	if (tmp == NULL_TREE && !f->sym->attr.allocatable
+	    && f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
+	  tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
+					   f->sym->backend_decl,
+					   f->sym->as ? f->sym->as->rank : 0);
 
-	    gfc_add_expr_to_block (&init, tmp);
+	if (tmp != NULL_TREE && (f->sym->attr.optional
+				 || f->sym->ns->proc_name->attr.entry_master))
+	  {
+	    present = gfc_conv_expr_present (f->sym);
+	    tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+			      present, tmp, build_empty_stmt (input_location));
 	  }
-       else if (f->sym->value)
+
+	if (tmp != NULL_TREE)
+	  gfc_add_expr_to_block (&init, tmp);
+	else if (f->sym->value && !f->sym->attr.allocatable)
 	  gfc_init_default_dt (f->sym, &init, true);
       }
     else if (f->sym && f->sym->attr.intent == INTENT_OUT
 	     && f->sym->ts.type == BT_CLASS
 	     && !CLASS_DATA (f->sym)->attr.class_pointer
-	     && CLASS_DATA (f->sym)->ts.u.derived->attr.alloc_comp)
+	     && !CLASS_DATA (f->sym)->attr.allocatable)
       {
-	tmp = gfc_class_data_get (f->sym->backend_decl);
-	if (CLASS_DATA (f->sym)->as == NULL)
-	  tmp = build_fold_indirect_ref_loc (input_location, tmp);
-	tmp = gfc_deallocate_alloc_comp (CLASS_DATA (f->sym)->ts.u.derived,
-					 tmp,
-					 CLASS_DATA (f->sym)->as ?
-					 CLASS_DATA (f->sym)->as->rank : 0);
+	stmtblock_t block;
+	gfc_expr *e;
+
+	gfc_init_block (&block);
+	f->sym->attr.referenced = 1;
+	e = gfc_lval_expr_from_sym (f->sym);
+	gfc_add_finalizer_call (&block, e);
+	gfc_free_expr (e);
+	tmp = gfc_finish_block (&block);
 
 	if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master)
 	  {
--- /dev/null	2013-05-31 08:03:29.909107813 +0200
+++ gcc/gcc/testsuite/gfortran.dg/finalize_10.f90	2013-05-31 16:23:06.377019214 +0200
@@ -0,0 +1,39 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! PR fortran/37336
+!
+! Finalize nonallocatable INTENT(OUT)
+!
+module m
+  type t
+  end type t
+  type t2
+  contains
+    final :: fini
+  end type t2
+contains
+  elemental subroutine fini(var)
+    type(t2), intent(inout) :: var
+  end subroutine fini
+end module m
+
+subroutine foo(x,y,aa,bb)
+  use m
+  class(t), intent(out) :: x(:),y
+  type(t2), intent(out) :: aa(:),bb
+end subroutine foo
+
+! Finalize CLASS + set default init
+! { dg-final { scan-tree-dump-times "y->_vptr->_final \\(&desc.\[0-9\]+, y->_vptr->_size, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void .\\) y->_data, \\(void .\\) y->_vptr->_def_init, \\(unsigned long\\) y->_vptr->_size\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x->_vptr->_final \\(&x->_data, x->_vptr->_size, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x->_vptr->_copy \\(x->_vptr->_def_init, &x->_data\\);" 1 "original" } }
+
+! FINALIZE TYPE:
+! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void \\*\\) &\\(\\*aa.\[0-9\]+\\)\\\[0\\\];" 1 "original" } }
+! { dg!final { scan-tree-dump-times "__final_m_T2 (&parm.\[0-9\]+, 0, 0);" 1 "original" } }
+! { dg!final { scan-tree-dump-times "desc.\[0-9\]+.data = \\(void \\* restrict\\) bb;" 1 "original" } }
+! { dg!final { scan-tree-dump-times "__final_m_T2 (&desc.\[0-9\]+, 0, 0);" 1 "original" } }
+
+! { dg-final { cleanup-tree-dump "original" } }
diff --git a/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 b/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
index d261973..04ee7f2 100644
--- a/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
+++ b/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
@@ -11,11 +11,12 @@ type :: t
   integer, allocatable :: i(:)
 end type
 
+block ! New block as the main program implies SAVE
 type(t) :: a
 
 call init(a)
 call init(a)
-
+end block
 contains
 
   subroutine init(x)
@@ -25,5 +26,6 @@ contains
 
 end program 
 
-! { dg-final { scan-tree-dump-times "__builtin_free" 5 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free" 4 "original" } }
+! { dg-final { scan-tree-dump-times "x->_vptr->_final \\(" 1 "original" } }
 ! { dg-final { cleanup-tree-dump "original" } }