re PR fortran/48351 ([OOP] Realloc on assignment fails if parent component is CLASS)

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.

From-SVN: r183162

gcc/fortran/ChangeLog

+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

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;

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:

gcc/testsuite/ChangeLog

+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

gcc/testsuite/gfortran.dg/alloc_comp_assign_12.f03

+! { 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" } }
+

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" } }