Commit ea8b72e6 by Tobias Burnus Committed by Tobias Burnus

trans-array.c (gfc_trans_deferred_array): Call the finalizer for nonallocatable local variables.

2013-06-21  Tobias Burnus  <burnus@net-b.de>

        * trans-array.c (gfc_trans_deferred_array): Call the
        finalizer for nonallocatable local variables.
        * trans-decl.c (gfc_get_symbol_decl): Add local
        finalizable vars to the deferred list.
        (gfc_trans_deferred_vars): Call gfc_trans_deferred_array
        for those.

2013-06-21  Tobias Burnus  <burnus@net-b.de>

        * gfortran.dg/finalize_17.f90: New.

From-SVN: r200321
parent 6f556b07
2013-06-21 Tobias Burnus <burnus@net-b.de> 2013-06-21 Tobias Burnus <burnus@net-b.de>
* trans-array.c (gfc_trans_deferred_array): Call the
finalizer for nonallocatable local variables.
* trans-decl.c (gfc_get_symbol_decl): Add local
finalizable vars to the deferred list.
(gfc_trans_deferred_vars): Call gfc_trans_deferred_array
for those.
2013-06-21 Tobias Burnus <burnus@net-b.de>
* trans-array.c (gfc_alloc_allocatable_for_assignment): Allocate * trans-array.c (gfc_alloc_allocatable_for_assignment): Allocate
at least one byte. at least one byte.
* trans-expr.c (alloc_scalar_allocatable_for_assignment): Ditto. * trans-expr.c (alloc_scalar_allocatable_for_assignment): Ditto.
......
...@@ -8309,12 +8309,12 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) ...@@ -8309,12 +8309,12 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
sym_has_alloc_comp = (sym->ts.type == BT_DERIVED sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
|| sym->ts.type == BT_CLASS) || sym->ts.type == BT_CLASS)
&& sym->ts.u.derived->attr.alloc_comp; && sym->ts.u.derived->attr.alloc_comp;
has_finalizer = sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED
? gfc_is_finalizable (sym->ts.u.derived, NULL) : false;
/* Make sure the frontend gets these right. */ /* Make sure the frontend gets these right. */
if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp)) gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp
fatal_error ("Possible front-end bug: Deferred array size without pointer, " || has_finalizer);
"allocatable attribute or derived type without allocatable "
"components.");
gfc_save_backend_locus (&loc); gfc_save_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at); gfc_set_backend_locus (&sym->declared_at);
...@@ -8343,7 +8343,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) ...@@ -8343,7 +8343,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
/* Although static, derived types with default initializers and /* Although static, derived types with default initializers and
allocatable components must not be nulled wholesale; instead they allocatable components must not be nulled wholesale; instead they
are treated component by component. */ are treated component by component. */
if (TREE_STATIC (descriptor) && !sym_has_alloc_comp) if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer)
{ {
/* SAVEd variables are not freed on exit. */ /* SAVEd variables are not freed on exit. */
gfc_trans_static_array_pointer (sym); gfc_trans_static_array_pointer (sym);
...@@ -8356,7 +8356,8 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) ...@@ -8356,7 +8356,8 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
/* Get the descriptor type. */ /* Get the descriptor type. */
type = TREE_TYPE (sym->backend_decl); type = TREE_TYPE (sym->backend_decl);
if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable)) if ((sym_has_alloc_comp || (has_finalizer && sym->ts.type != BT_CLASS))
&& !(sym->attr.pointer || sym->attr.allocatable))
{ {
if (!sym->attr.save if (!sym->attr.save
&& !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program)) && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
...@@ -8391,9 +8392,17 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) ...@@ -8391,9 +8392,17 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
/* Allocatable arrays need to be freed when they go out of scope. /* Allocatable arrays need to be freed when they go out of scope.
The allocatable components of pointers must not be touched. */ The allocatable components of pointers must not be touched. */
has_finalizer = sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED if (!sym->attr.allocatable && has_finalizer && sym->ts.type != BT_CLASS
? gfc_is_finalizable (sym->ts.u.derived, NULL) : false; && !sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
if ((!sym->attr.allocatable || !has_finalizer) && !sym->ns->proc_name->attr.is_main_program)
{
gfc_expr *e;
sym->attr.referenced = 1;
e = gfc_lval_expr_from_sym (sym);
gfc_add_finalizer_call (&cleanup, e);
gfc_free_expr (e);
}
else if ((!sym->attr.allocatable || !has_finalizer)
&& sym_has_alloc_comp && !(sym->attr.function || sym->attr.result) && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
&& !sym->attr.pointer && !sym->attr.save && !sym->attr.pointer && !sym->attr.save
&& !sym->ns->proc_name->attr.is_main_program) && !sym->ns->proc_name->attr.is_main_program)
......
...@@ -1420,7 +1420,11 @@ gfc_get_symbol_decl (gfc_symbol * sym) ...@@ -1420,7 +1420,11 @@ gfc_get_symbol_decl (gfc_symbol * sym)
|| (sym->ts.type == BT_CLASS && || (sym->ts.type == BT_CLASS &&
(CLASS_DATA (sym)->attr.dimension (CLASS_DATA (sym)->attr.dimension
|| CLASS_DATA (sym)->attr.allocatable)) || CLASS_DATA (sym)->attr.allocatable))
|| (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp) || (sym->ts.type == BT_DERIVED
&& (sym->ts.u.derived->attr.alloc_comp
|| (!sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
&& !sym->ns->proc_name->attr.is_main_program
&& gfc_is_finalizable (sym->ts.u.derived, NULL))))
/* This applies a derived type default initializer. */ /* This applies a derived type default initializer. */
|| (sym->ts.type == BT_DERIVED || (sym->ts.type == BT_DERIVED
&& sym->attr.save == SAVE_NONE && sym->attr.save == SAVE_NONE
...@@ -3668,8 +3672,10 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) ...@@ -3668,8 +3672,10 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink) for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
{ {
bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED) bool alloc_comp_or_fini = (sym->ts.type == BT_DERIVED)
&& sym->ts.u.derived->attr.alloc_comp; && (sym->ts.u.derived->attr.alloc_comp
|| gfc_is_finalizable (sym->ts.u.derived,
NULL));
if (sym->assoc) if (sym->assoc)
continue; continue;
...@@ -3754,7 +3760,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) ...@@ -3754,7 +3760,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
gfc_save_backend_locus (&loc); gfc_save_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at); gfc_set_backend_locus (&sym->declared_at);
if (sym_has_alloc_comp) if (alloc_comp_or_fini)
{ {
seen_trans_deferred_array = true; seen_trans_deferred_array = true;
gfc_trans_deferred_array (sym, block); gfc_trans_deferred_array (sym, block);
...@@ -3802,7 +3808,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) ...@@ -3802,7 +3808,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
default: default:
gcc_unreachable (); gcc_unreachable ();
} }
if (sym_has_alloc_comp && !seen_trans_deferred_array) if (alloc_comp_or_fini && !seen_trans_deferred_array)
gfc_trans_deferred_array (sym, block); gfc_trans_deferred_array (sym, block);
} }
else if ((!sym->attr.dummy || sym->ts.deferred) else if ((!sym->attr.dummy || sym->ts.deferred)
...@@ -3998,7 +4004,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) ...@@ -3998,7 +4004,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
} }
else if (sym->ts.deferred) else if (sym->ts.deferred)
gfc_fatal_error ("Deferred type parameter not yet supported"); gfc_fatal_error ("Deferred type parameter not yet supported");
else if (sym_has_alloc_comp) else if (alloc_comp_or_fini)
gfc_trans_deferred_array (sym, block); gfc_trans_deferred_array (sym, block);
else if (sym->ts.type == BT_CHARACTER) else if (sym->ts.type == BT_CHARACTER)
{ {
......
2013-06-21 Tobias Burnus <burnus@net-b.de> 2013-06-21 Tobias Burnus <burnus@net-b.de>
* gfortran.dg/finalize_17.f90: New.
2013-06-21 Tobias Burnus <burnus@net-b.de>
* gfortran.dg/realloc_on_assign_18.f90: New. * gfortran.dg/realloc_on_assign_18.f90: New.
2013-06-21 Balaji V. Iyer <balaji.v.iyer@intel.com> 2013-06-21 Balaji V. Iyer <balaji.v.iyer@intel.com>
......
! { dg-do run }
!
! PR fortran/37336
!
! Test for finalization of nonallocatable variables
!
module m
implicit none
type t
integer :: i
contains
final :: finit
end type t
integer, save :: called_final = -1
contains
impure elemental subroutine finit(x)
type(t), intent(in) :: x
if (called_final == -1) call abort ()
called_final = called_final + 1
if (called_final /= x%i) call abort ()
end subroutine finit
end module m
use m
implicit none
type(t) :: x2, y2(2)
block
type(t) :: xx, yy(2)
type(t), save :: x3, y3(2)
yy%i = [1, 2]
xx%i = 3
y3%i = [-4, -5]
x3%i = -6
called_final = 0
end block
if (called_final /= 3) call abort
called_final = -1
y2%i = [-7, -8]
x2%i = -9
end
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment