OSDN Git Service

2009-10-19 Janus Weil <janus@gcc.gnu.org>
authorjanus <janus@138bc75d-0d04-0410-961f-82ee72b054a4>
Mon, 19 Oct 2009 19:21:18 +0000 (19:21 +0000)
committerjanus <janus@138bc75d-0d04-0410-961f-82ee72b054a4>
Mon, 19 Oct 2009 19:21:18 +0000 (19:21 +0000)
PR fortran/41586
* parse.c (parse_derived): Correctly set 'alloc_comp' and 'pointer_comp'
for CLASS variables.
* trans-array.c (structure_alloc_comps): Handle deallocation and
nullification of allocatable scalar components.
* trans-decl.c (gfc_get_symbol_decl): Remember allocatable scalars for
automatic deallocation.
(gfc_trans_deferred_vars): Automatically deallocate allocatable scalars.

2009-10-19  Janus Weil  <janus@gcc.gnu.org>

PR fortran/41586
* gfortran.dg/auto_dealloc_1.f90: New test case.

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

gcc/fortran/ChangeLog
gcc/fortran/parse.c
gcc/fortran/trans-array.c
gcc/fortran/trans-decl.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/auto_dealloc_1.f90 [new file with mode: 0644]

index 3f07da5..ce18d2d 100644 (file)
@@ -1,3 +1,14 @@
+2009-10-19  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/41586
+       * parse.c (parse_derived): Correctly set 'alloc_comp' and 'pointer_comp'
+       for CLASS variables.
+       * trans-array.c (structure_alloc_comps): Handle deallocation and
+       nullification of allocatable scalar components.
+       * trans-decl.c (gfc_get_symbol_decl): Remember allocatable scalars for
+       automatic deallocation.
+       (gfc_trans_deferred_vars): Automatically deallocate allocatable scalars.
+
 2009-10-19  Tobias Burnus  <burnus@net-b.de>
            Steven G. Kargl  <kargl@gcc.gnu.org>
 
index c168c52..95a327b 100644 (file)
@@ -2068,11 +2068,15 @@ endType:
     {
       /* Look for allocatable components.  */
       if (c->attr.allocatable
+         || (c->ts.type == BT_CLASS
+             && c->ts.u.derived->components->attr.allocatable)
          || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.alloc_comp))
        sym->attr.alloc_comp = 1;
 
       /* Look for pointer components.  */
       if (c->attr.pointer
+         || (c->ts.type == BT_CLASS
+             && c->ts.u.derived->components->attr.pointer)
          || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
        sym->attr.pointer_comp = 1;
 
index e162000..4e94373 100644 (file)
@@ -5906,6 +5906,36 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
              tmp = gfc_trans_dealloc_allocated (comp);
              gfc_add_expr_to_block (&fnblock, tmp);
            }
+         else if (c->attr.allocatable)
+           {
+             /* Allocatable scalar components.  */
+             comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+
+             tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
+             gfc_add_expr_to_block (&fnblock, tmp);
+
+             tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
+                                build_int_cst (TREE_TYPE (comp), 0));
+             gfc_add_expr_to_block (&fnblock, tmp);
+           }
+         else if (c->ts.type == BT_CLASS
+                  && c->ts.u.derived->components->attr.allocatable)
+           {
+             /* Allocatable scalar CLASS components.  */
+             comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+             
+             /* Add reference to '$data' component.  */
+             tmp = c->ts.u.derived->components->backend_decl;
+             comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
+                                 comp, tmp, NULL_TREE);
+
+             tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
+             gfc_add_expr_to_block (&fnblock, tmp);
+
+             tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
+                                build_int_cst (TREE_TYPE (comp), 0));
+             gfc_add_expr_to_block (&fnblock, tmp);
+           }
          break;
 
        case NULLIFY_ALLOC_COMP:
@@ -5917,6 +5947,27 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
                                  decl, cdecl, NULL_TREE);
              gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
            }
+         else if (c->attr.allocatable)
+           {
+             /* Allocatable scalar components.  */
+             comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+             tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
+                                build_int_cst (TREE_TYPE (comp), 0));
+             gfc_add_expr_to_block (&fnblock, tmp);
+           }
+         else if (c->ts.type == BT_CLASS
+                  && c->ts.u.derived->components->attr.allocatable)
+           {
+             /* Allocatable scalar CLASS components.  */
+             comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+             /* Add reference to '$data' component.  */
+             tmp = c->ts.u.derived->components->backend_decl;
+             comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
+                                 comp, tmp, NULL_TREE);
+             tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
+                                build_int_cst (TREE_TYPE (comp), 0));
+             gfc_add_expr_to_block (&fnblock, tmp);
+           }
           else if (cmp_has_alloc_comps)
            {
              comp = fold_build3 (COMPONENT_REF, ctype,
index ee38efb..8812675 100644 (file)
@@ -1187,22 +1187,23 @@ gfc_get_symbol_decl (gfc_symbol * sym)
       /* Create variables to hold the non-constant bits of array info.  */
       gfc_build_qualified_array (decl, sym);
 
-      /* Remember this variable for allocation/cleanup.  */
-      gfc_defer_symbol_init (sym);
-
       if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
        GFC_DECL_PACKED_ARRAY (decl) = 1;
     }
 
-  if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
-    gfc_defer_symbol_init (sym);
-  /* This applies a derived type default initializer.  */
-  else if (sym->ts.type == BT_DERIVED
-            && sym->attr.save == SAVE_NONE
-            && !sym->attr.data
-            && !sym->attr.allocatable
-            && (sym->value && !sym->ns->proc_name->attr.is_main_program)
-            && !sym->attr.use_assoc)
+  /* Remember this variable for allocation/cleanup.  */
+  if (sym->attr.dimension || sym->attr.allocatable
+      || (sym->ts.type == BT_CLASS &&
+         (sym->ts.u.derived->components->attr.dimension
+          || sym->ts.u.derived->components->attr.allocatable))
+      || (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
+      /* This applies a derived type default initializer.  */
+      || (sym->ts.type == BT_DERIVED
+         && sym->attr.save == SAVE_NONE
+         && !sym->attr.data
+         && !sym->attr.allocatable
+         && (sym->value && !sym->ns->proc_name->attr.is_main_program)
+         && !sym->attr.use_assoc))
     gfc_defer_symbol_init (sym);
 
   gfc_finish_var_decl (decl, sym);
@@ -3054,7 +3055,8 @@ init_intent_out_dt (gfc_symbol * proc_sym, tree body)
     Allocation and initialization of array variables.
     Allocation of character string variables.
     Initialization and possibly repacking of dummy arrays.
-    Initialization of ASSIGN statement auxiliary variable.  */
+    Initialization of ASSIGN statement auxiliary variable.
+    Automatic deallocation.  */
 
 tree
 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
@@ -3182,6 +3184,37 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
        }
       else if (sym_has_alloc_comp)
        fnbody = gfc_trans_deferred_array (sym, fnbody);
+      else if (sym->attr.allocatable
+              || (sym->ts.type == BT_CLASS
+                  && sym->ts.u.derived->components->attr.allocatable))
+       {
+         /* Automatic deallocatation of allocatable scalars.  */
+         tree tmp;
+         gfc_expr *e;
+         gfc_se se;
+         stmtblock_t block;
+         
+         e = gfc_lval_expr_from_sym (sym);
+         if (sym->ts.type == BT_CLASS)
+           gfc_add_component_ref (e, "$data");
+
+         gfc_init_se (&se, NULL);
+         se.want_pointer = 1;
+         gfc_conv_expr (&se, e);
+         gfc_free_expr (e);
+
+         gfc_start_block (&block);
+         gfc_add_expr_to_block (&block, fnbody);
+
+         tmp = gfc_deallocate_with_status (se.expr, NULL_TREE, true, NULL);
+         gfc_add_expr_to_block (&block, tmp);
+
+         tmp = fold_build2 (MODIFY_EXPR, void_type_node,
+                            se.expr, build_int_cst (TREE_TYPE (se.expr), 0));
+         gfc_add_expr_to_block (&block, tmp);
+
+         fnbody = gfc_finish_block (&block);
+       }
       else if (sym->ts.type == BT_CHARACTER)
        {
          gfc_get_backend_locus (&loc);
index cddfb39..6490c97 100644 (file)
@@ -1,3 +1,8 @@
+2009-10-19  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/41586
+       * gfortran.dg/auto_dealloc_1.f90: New test case.
+
 2009-10-18  Jakub Jelinek  <jakub@redhat.com>
 
        Port from redhat/gcc-4_4-branch:
diff --git a/gcc/testsuite/gfortran.dg/auto_dealloc_1.f90 b/gcc/testsuite/gfortran.dg/auto_dealloc_1.f90
new file mode 100644 (file)
index 0000000..176f87a
--- /dev/null
@@ -0,0 +1,59 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! PR 41586: Allocatable _scalars_ are never auto-deallocated
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+module automatic_deallocation
+
+  type t0
+    integer :: i
+  end type
+
+  type t1
+    real :: pi = 3.14
+    integer, allocatable :: j
+  end type
+
+  type t2
+    class(t0), allocatable :: k
+  end type t2
+
+contains
+
+  ! (1) simple allocatable scalars
+  subroutine a
+    integer, allocatable :: m
+    allocate (m)
+    m = 42
+  end subroutine
+
+  ! (2) allocatable scalar CLASS variables
+  subroutine b
+    class(t0), allocatable :: m
+    allocate (t0 :: m)
+    m%i = 43
+  end subroutine
+
+  ! (3) allocatable scalar components
+  subroutine c
+    type(t1) :: m
+    allocate (m%j)
+    m%j = 44
+  end subroutine
+
+  ! (4) allocatable scalar CLASS components
+  subroutine d
+    type(t2) :: m
+    allocate (t0 :: m%k)
+    m%k%i = 45
+  end subroutine
+
+end module 
+
+
+! { dg-final { scan-tree-dump-times "__builtin_free" 5 "original" } }
+
+! { dg-final { cleanup-modules "automatic_deallocation" } }
+! { dg-final { cleanup-tree-dump "original" } }