aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/ChangeLog9
-rw-r--r--gcc/fortran/trans-array.c27
-rw-r--r--gcc/fortran/trans-decl.c18
-rw-r--r--gcc/testsuite/ChangeLog4
-rw-r--r--gcc/testsuite/gfortran.dg/finalize_17.f9040
5 files changed, 83 insertions, 15 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 8e4b7a1..7667dc2 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,14 @@
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
at least one byte.
* trans-expr.c (alloc_scalar_allocatable_for_assignment): Ditto.
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index dc9637a..96162e5 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -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->ts.type == BT_CLASS)
&& 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. */
- if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
- fatal_error ("Possible front-end bug: Deferred array size without pointer, "
- "allocatable attribute or derived type without allocatable "
- "components.");
+ gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp
+ || has_finalizer);
gfc_save_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
@@ -8343,7 +8343,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
/* Although static, derived types with default initializers and
allocatable components must not be nulled wholesale; instead they
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. */
gfc_trans_static_array_pointer (sym);
@@ -8356,7 +8356,8 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
/* Get the descriptor type. */
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
&& !(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)
/* Allocatable arrays need to be freed when they go out of scope.
The allocatable components of pointers must not be touched. */
- has_finalizer = sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED
- ? gfc_is_finalizable (sym->ts.u.derived, NULL) : false;
- if ((!sym->attr.allocatable || !has_finalizer)
+ if (!sym->attr.allocatable && has_finalizer && sym->ts.type != BT_CLASS
+ && !sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
+ && !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->attr.pointer && !sym->attr.save
&& !sym->ns->proc_name->attr.is_main_program)
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 4e3bf48..fc3a725 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -1420,7 +1420,11 @@ gfc_get_symbol_decl (gfc_symbol * sym)
|| (sym->ts.type == BT_CLASS &&
(CLASS_DATA (sym)->attr.dimension
|| 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. */
|| (sym->ts.type == BT_DERIVED
&& sym->attr.save == SAVE_NONE
@@ -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)
{
- bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
- && sym->ts.u.derived->attr.alloc_comp;
+ bool alloc_comp_or_fini = (sym->ts.type == BT_DERIVED)
+ && (sym->ts.u.derived->attr.alloc_comp
+ || gfc_is_finalizable (sym->ts.u.derived,
+ NULL));
if (sym->assoc)
continue;
@@ -3754,7 +3760,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
gfc_save_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
- if (sym_has_alloc_comp)
+ if (alloc_comp_or_fini)
{
seen_trans_deferred_array = true;
gfc_trans_deferred_array (sym, block);
@@ -3802,7 +3808,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
default:
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);
}
else if ((!sym->attr.dummy || sym->ts.deferred)
@@ -3998,7 +4004,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
}
else if (sym->ts.deferred)
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);
else if (sym->ts.type == BT_CHARACTER)
{
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index aca4074..b5ab534 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,9 @@
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.
2013-06-21 Balaji V. Iyer <balaji.v.iyer@intel.com>
diff --git a/gcc/testsuite/gfortran.dg/finalize_17.f90 b/gcc/testsuite/gfortran.dg/finalize_17.f90
new file mode 100644
index 0000000..ce2306c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_17.f90
@@ -0,0 +1,40 @@
+! { 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
generated by cgit v1.1 at 2025-02-23 15:12:25 +0000