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.
2013-05-31 Tobias Burnus <bur...@net-b.de>
PR fortran/37336
* trans-decl.c (init_intent_out_dt): Call finalizer
when approriate.
2013-05-31 Tobias Burnus <bur...@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" } }
