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

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 8e4b7a16bcb27955676d447b220abada3299baf9..7667dc25b675bd5d5ce8d9e1c898cbf3442e505c 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,12 @@
+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

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index dc9637ae2f8d87d9e8a1357db4f695f124cad350..96162e5496bcc1b6b6d33ee6bef02ecdcbb0edd7 100644 (file)
--- 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 4e3bf48f1279c35fb9ea15fb048b538383e8ece8..fc3a725aa3db396df5141693cc994f58a3addd08 100644 (file)
--- 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 aca407482b3cbf9fc4987f19067d8dbec388e19a..b5ab534818d61d016cb67f2b06a41019de9d44d5 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+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.

diff --git a/gcc/testsuite/gfortran.dg/finalize_17.f90 b/gcc/testsuite/gfortran.dg/finalize_17.f90
new file mode 100644 (file)
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