2012-01-13 Paul Thomas <pault@gcc.gnu.org>

	PR fortran/48351
	* trans-array.c (structure_alloc_comps): Suppress interative
	call to self, when current component is deallocated using
	gfc_trans_dealloc_allocated.
	* class.c (gfc_build_class_symbol): Copy the 'alloc_comp'
	attribute from the declared type to the class structure.

2012-01-13  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/48351
	* gfortran.dg/alloc_comp_assign.f03: New.
	* gfortran.dg/allocatable_scalar_9.f90: Reduce count of
	__BUILTIN_FREE from 38 to 32.

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 9a38216..3fe6d9d 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,12 @@
+2012-01-13  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/48351
+       * trans-array.c (structure_alloc_comps): Suppress interative
+       call to self, when current component is deallocated using
+       gfc_trans_dealloc_allocated.
+       * class.c (gfc_build_class_symbol): Copy the 'alloc_comp'
+       attribute from the declared type to the class structure.
+
 2012-01-13  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/51842

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 37c653a..a17fc0a 100644 (file)
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -432,6 +432,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
     }
     
   fclass->attr.extension = ts->u.derived->attr.extension + 1;
+  fclass->attr.alloc_comp = ts->u.derived->attr.alloc_comp;
   fclass->attr.is_class = 1;
   ts->u.derived = fclass;
   attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0;

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 1fd8dcb..57793ce 100644 (file)
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -7238,6 +7238,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
   gfc_loopinfo loop;
   stmtblock_t fnblock;
   stmtblock_t loopbody;
+  stmtblock_t tmpblock;
   tree decl_type;
   tree tmp;
   tree comp;
@@ -7249,6 +7250,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
   tree ctype;
   tree vref, dref;
   tree null_cond = NULL_TREE;
+  bool called_dealloc_with_status;
 
   gfc_init_block (&fnblock);
 
@@ -7359,17 +7361,12 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
       switch (purpose)
        {
        case DEALLOCATE_ALLOC_COMP:
-         if (cmp_has_alloc_comps && !c->attr.pointer)
-           {
-             /* Do not deallocate the components of ultimate pointer
-                components.  */
-             comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
-                                     decl, cdecl, NULL_TREE);
-             rank = c->as ? c->as->rank : 0;
-             tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
-                                          rank, purpose);
-             gfc_add_expr_to_block (&fnblock, tmp);
-           }
+
+         /* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp
+            (ie. this function) so generate all the calls and suppress the
+            recursion from here, if necessary.  */
+         called_dealloc_with_status = false;
+         gfc_init_block (&tmpblock);
 
          if (c->attr.allocatable
              && (c->attr.dimension || c->attr.codimension))
@@ -7377,7 +7374,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
              comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
                                      decl, cdecl, NULL_TREE);
              tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension);
-             gfc_add_expr_to_block (&fnblock, tmp);
+             gfc_add_expr_to_block (&tmpblock, tmp);
            }
          else if (c->attr.allocatable)
            {
@@ -7387,12 +7384,13 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 
              tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
                                                       c->ts);
-             gfc_add_expr_to_block (&fnblock, tmp);
+             gfc_add_expr_to_block (&tmpblock, tmp);
+             called_dealloc_with_status = true;
 
              tmp = fold_build2_loc (input_location, MODIFY_EXPR,
                                     void_type_node, comp,
                                     build_int_cst (TREE_TYPE (comp), 0));
-             gfc_add_expr_to_block (&fnblock, tmp);
+             gfc_add_expr_to_block (&tmpblock, tmp);
            }
          else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
            {
@@ -7412,14 +7410,33 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
                {
                  tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
                                                           CLASS_DATA (c)->ts);
-                 gfc_add_expr_to_block (&fnblock, tmp);
+                 gfc_add_expr_to_block (&tmpblock, tmp);
+                 called_dealloc_with_status = true;
 
                  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
                                         void_type_node, comp,
                                         build_int_cst (TREE_TYPE (comp), 0));
                }
+             gfc_add_expr_to_block (&tmpblock, tmp);
+           }
+
+         if (cmp_has_alloc_comps
+               && !c->attr.pointer
+               && !called_dealloc_with_status)
+           {
+             /* Do not deallocate the components of ultimate pointer
+                components or iteratively call self if call has been made
+                to gfc_trans_dealloc_allocated  */
+             comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+                                     decl, cdecl, NULL_TREE);
+             rank = c->as ? c->as->rank : 0;
+             tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
+                                          rank, purpose);
              gfc_add_expr_to_block (&fnblock, tmp);
            }
+
+         /* Now add the deallocation of this component.  */
+         gfc_add_block_to_block (&fnblock, &tmpblock);
          break;
 
        case NULLIFY_ALLOC_COMP:

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index a007b23..44cf019 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2012-01-13  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/48351
+       * gfortran.dg/alloc_comp_assign.f03: New.
+       * gfortran.dg/allocatable_scalar_9.f90: Reduce count of
+       __BUILTIN_FREE from 38 to 32.
+
 2012-01-13  Jason Merrill  <jason@redhat.com>
 
        PR c++/20681

diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_assign_12.f03 b/gcc/testsuite/gfortran.dg/alloc_comp_assign_12.f03
new file mode 100644 (file)
index 0000000..b44769d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/alloc_comp_assign_12.f03
@@ -0,0 +1,44 @@
+! { dg-do run }
+! PR48351 - automatic (re)allocation of allocatable components of class objects
+!
+! Contributed by Nasser M. Abbasi on comp.lang.fortran
+!
+module foo
+  implicit none
+  type :: foo_t
+    private
+    real, allocatable :: u(:)
+  contains
+    procedure :: make
+    procedure :: disp
+  end type foo_t
+contains
+  subroutine make(this,u)
+    implicit none
+    class(foo_t) :: this
+    real, intent(in) :: u(:)
+    this%u = u(int (u))       ! The failure to allocate occurred here.
+    if (.not.allocated (this%u)) call abort
+  end subroutine make
+  function disp(this)
+    implicit none
+    class(foo_t) :: this
+    real, allocatable :: disp (:)
+    if (allocated (this%u)) disp = this%u
+  end function
+end module foo
+
+program main2
+  use foo
+  implicit none
+  type(foo_t) :: o
+  real, allocatable :: u(:)
+  u=real ([3,2,1,4])
+  call o%make(u)
+  if (any (int (o%disp()) .ne. [1,2,3,4])) call abort
+  u=real ([2,1])
+  call o%make(u)
+  if (any (int (o%disp()) .ne. [1,2])) call abort
+end program main2
+! { dg-final { cleanup-modules "foo" } }
+

diff --git a/gcc/testsuite/gfortran.dg/allocatable_scalar_9.f90 b/gcc/testsuite/gfortran.dg/allocatable_scalar_9.f90
index fef9b05..f4c6599 100644 (file)
--- a/gcc/testsuite/gfortran.dg/allocatable_scalar_9.f90
+++ b/gcc/testsuite/gfortran.dg/allocatable_scalar_9.f90
@@ -49,7 +49,7 @@ if(allocated(na3%b3)) call abort()
 if(allocated(na4%b4)) call abort()
 end
 
-! { dg-final { scan-tree-dump-times "__builtin_free" 38 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free" 32 "original" } }
 ! { dg-final { cleanup-tree-dump "original" } }
 
 ! { dg-final { cleanup-modules "m" } }