2013-07-15 Tobias Burnus <burnus@net-b.de>

        PR fortran/37336
        * trans.c (gfc_add_comp_finalizer_call): New function.
        * trans.h (gfc_add_comp_finalizer_call): New prototype.
        * trans-array.c (structure_alloc_comps): Call it.

2013-07-15  Tobias Burnus  <burnus@net-b.de>

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

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@200954 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 35c884c..f103a6d 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2013-07-15  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/37336
+       * trans.c (gfc_add_comp_finalizer_call): New function.
+       * trans.h (gfc_add_comp_finalizer_call): New prototype.
+       * trans-array.c (structure_alloc_comps): Call it.
+
 2013-07-14  Thomas Koenig  <tkoenig@gcc.gnu.org>
            Tobias Burnus  <burnus@gcc.gnu.org>
 

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 39bf0dd..513c073 100644 (file)
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -7584,19 +7584,34 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
          called_dealloc_with_status = false;
          gfc_init_block (&tmpblock);
 
-         if (c->attr.allocatable && (c->attr.dimension || c->attr.codimension)
-             && !c->attr.proc_pointer)
+         if ((c->ts.type == BT_DERIVED && !c->attr.pointer)
+             || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer))
            {
              comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
                                      decl, cdecl, NULL_TREE);
+
+             /* The finalizer frees allocatable components.  */
+             called_dealloc_with_status
+               = gfc_add_comp_finalizer_call (&tmpblock, comp, c, true);
+           }
+         else
+           comp = NULL_TREE;
+
+         if (c->attr.allocatable && (c->attr.dimension || c->attr.codimension)
+             && !c->attr.proc_pointer)
+           {
+             if (comp == NULL_TREE)
+               comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+                                       decl, cdecl, NULL_TREE);
              tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension, NULL);
              gfc_add_expr_to_block (&tmpblock, tmp);
            }
          else if (c->attr.allocatable)
            {
              /* Allocatable scalar components.  */
-             comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
-                                     decl, cdecl, NULL_TREE);
+             if (comp == NULL_TREE)
+               comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+                                       decl, cdecl, NULL_TREE);
 
              tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
                                                       c->ts);
@@ -7611,10 +7626,11 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
          else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
            {
              /* Allocatable CLASS components.  */
-             comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
-                                     decl, cdecl, NULL_TREE);
 
              /* Add reference to '_data' component.  */
+             if (comp == NULL_TREE)
+               comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+                                       decl, cdecl, NULL_TREE);
              tmp = CLASS_DATA (c)->backend_decl;
              comp = fold_build3_loc (input_location, COMPONENT_REF,
                                      TREE_TYPE (tmp), comp, tmp, NULL_TREE);

diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index f17eaca..53a0669 100644 (file)
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -948,6 +948,102 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
 }
 
 
+bool
+gfc_add_comp_finalizer_call (stmtblock_t *block, tree decl, gfc_component *comp,
+                            bool fini_coarray)
+{
+  gfc_se se;
+  stmtblock_t block2;
+  tree final_fndecl, size, array, tmp, cond;
+  symbol_attribute attr;
+  gfc_expr *final_expr = NULL;
+
+  if (comp->ts.type != BT_DERIVED && comp->ts.type != BT_CLASS)
+    return false;
+
+  gfc_init_block (&block2);
+
+  if (comp->ts.type == BT_DERIVED)
+    {
+      if (comp->attr.pointer)
+       return false;
+
+      gfc_is_finalizable (comp->ts.u.derived, &final_expr);
+      if (!final_expr)
+        return false;
+
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr (&se, final_expr);
+      final_fndecl = se.expr;
+      size = gfc_typenode_for_spec (&comp->ts);
+      size = TYPE_SIZE_UNIT (size);
+      size = fold_convert (gfc_array_index_type, size);
+
+      array = decl;
+    }
+  else /* comp->ts.type == BT_CLASS.  */
+    {
+      if (CLASS_DATA (comp)->attr.class_pointer)
+       return false;
+
+      gfc_is_finalizable (CLASS_DATA (comp)->ts.u.derived, &final_expr);
+      final_fndecl = gfc_vtable_final_get (decl);
+      size = gfc_vtable_size_get (decl);
+      array = gfc_class_data_get (decl);
+    }
+
+  if (comp->attr.allocatable
+      || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable))
+    {
+      tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array))
+           ?  gfc_conv_descriptor_data_get (array) : array;
+      cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+                           tmp, fold_convert (TREE_TYPE (tmp),
+                                                null_pointer_node));
+    }
+  else
+    cond = boolean_true_node;
+
+  if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array)))
+    {
+      gfc_clear_attr (&attr);
+      gfc_init_se (&se, NULL);
+      array = gfc_conv_scalar_to_descriptor (&se, array, attr);
+      gfc_add_block_to_block (&block2, &se.pre);
+      gcc_assert (se.post.head == NULL_TREE);
+    }
+
+  if (!POINTER_TYPE_P (TREE_TYPE (array)))
+    array = gfc_build_addr_expr (NULL, array);
+
+  if (!final_expr)
+    {
+      tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+                            final_fndecl,
+                            fold_convert (TREE_TYPE (final_fndecl),
+                                          null_pointer_node));
+      cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+                             boolean_type_node, cond, tmp);
+    }
+
+  if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
+    final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);
+
+  tmp = build_call_expr_loc (input_location,
+                            final_fndecl, 3, array,
+                            size, fini_coarray ? boolean_true_node
+                                               : boolean_false_node);
+  gfc_add_expr_to_block (&block2, tmp);
+  tmp = gfc_finish_block (&block2);
+
+  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
+                        build_empty_stmt (input_location));
+  gfc_add_expr_to_block (block, tmp);
+
+  return true;
+}
+
+
 /* Add a call to the finalizer, using the passed *expr. Returns
    true when a finalizer call has been inserted.  */
 

diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 06cb63d..424ce7a 100644 (file)
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -353,6 +353,8 @@ tree gfc_get_vptr_from_expr (tree);
 tree gfc_get_class_array_ref (tree, tree);
 tree gfc_copy_class_to_class (tree, tree, tree);
 bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *);
+bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool);
+
 void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree, bool,
                                bool);
 void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool, bool,

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 2e609ed..beececc 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2013-07-15  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/37336
+       * gfortran.dg/finalize_18.f90: New.
+
 2013-07-14  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
        PR fortran/52669

diff --git a/gcc/testsuite/gfortran.dg/finalize_18.f90 b/gcc/testsuite/gfortran.dg/finalize_18.f90
new file mode 100644 (file)
index 0000000..f018ae2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_18.f90
@@ -0,0 +1,47 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! PR fortran/37336
+!
+module m
+  type t
+  contains
+    final :: fini
+  end type t
+  type t2
+    integer :: ii
+    type(t), allocatable :: aa
+    type(t), allocatable :: bb(:)
+    class(t), allocatable :: cc
+    class(t), allocatable :: dd(:)
+  end type t2
+  integer, save :: cnt = -1
+contains
+  subroutine fini(x)
+     type(t) :: x
+     if (cnt == -1) call abort ()
+     cnt = cnt + 1
+  end subroutine fini
+end module m
+
+use m
+block
+  type(t2) :: y
+  y%ii = 123
+end block
+end
+
+! { dg-final { scan-tree-dump-times "if \\(y.aa != 0B\\)" 2 "original" } }
+! { dg-final { scan-tree-dump-times "if \\(y.cc._data != 0B\\)" 2 "original" } }
+! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.bb.data != 0B\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.dd._data.data != 0B\\)" 1 "original" } }
+
+! { dg-final { scan-tree-dump-times "desc.\[0-9\]+.data = \\(void . restrict\\) y.aa;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "desc.\[0-9\]+.data = \\(void . restrict\\) y.cc._data;" 1 "original" } }
+
+! { dg-final { scan-tree-dump-times "__final_m_T \\(&desc.\[0-9\]+, 0, 1\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__final_m_T \\(&y.bb, 0, 1\\);" 1 "original" } }
+! { dg-final { scan-tree-dump "y.cc._vptr->_final \\(&desc.\[0-9\]+, (\\(integer\\(kind=8\\)\\) )?y.cc._vptr->_size, 1\\);" "original" } }
+! { dg-final { scan-tree-dump "y.dd._vptr->_final \\(&y.dd._data, (\\(integer\\(kind=8\\)\\) )?y.dd._vptr->_size, 1\\);" "original" } }
+
+! { dg-final { cleanup-tree-dump "original" } }