diff mbox

[fortran] PR48351 - [OOP] Realloc on assignment fails if parent component is CLASS

Message ID CAGkQGiLHWu=jQ-gFZTz8py7EkwL5cQK=6vk=s6QxOLE-TvC8uw@mail.gmail.com
State New
Headers show

Commit Message

Paul Richard Thomas Jan. 13, 2012, 3:29 p.m. UTC 
Dear All,

When the only modification was to set the attribute alloc_comp for
class containers, I was going to commit this patch as obvious.
However, it caused a regression in class-19.f03 by increasing the
count of BUILTIN_FREE from 11 to 23!  Whilst the extra calls did no
harm, this offended my sensibilities excessively :-)  The fix to
trans-array.c (structure_alloc_comps) is a bit more invasive, so I
thought that I had better come to the list for approval.  Note that
this 'bug'  applied to other cases and was the cause of the
proliferation of free's in allocatable_scalar_9.f90.  I have checked
the code for this case and everything that should be freed is
freed.... just once .

Bootstrapped and regtested on i686/Ubuntu10.04 - OK for trunk?

Paul

2012-01-12  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-12  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.

Comments

Tobias Burnus Jan. 13, 2012, 3:50 p.m. UTC | #1 
On 01/13/2012 04:29 PM, Paul Richard Thomas wrote:
> Bootstrapped and regtested on i686/Ubuntu10.04 - OK for trunk?

OK. Thanks for the patch!

Good that we have __builtin_free counting test cases, which helps to 
detect such issues.

Tobias

> 2012-01-12  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-12  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.
Paul Richard Thomas Jan. 13, 2012, 8:43 p.m. UTC | #2 
Committed as revision 183162.

Thanks Tobias - I'll look at yours first thing tomorrow.

Paul

On Fri, Jan 13, 2012 at 4:50 PM, Tobias Burnus <burnus@net-b.de> wrote:
> On 01/13/2012 04:29 PM, Paul Richard Thomas wrote:
>>
>> Bootstrapped and regtested on i686/Ubuntu10.04 - OK for trunk?
>
>
> OK. Thanks for the patch!
>
> Good that we have __builtin_free counting test cases, which helps to detect
> such issues.
>
> Tobias
>
>
>> 2012-01-12  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-12  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.
>
>
diff mbox

Patch

Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 183125)
--- gcc/fortran/trans-array.c	(working copy)
*************** structure_alloc_comps (gfc_symbol * der_
*** 7238,7243 ****
--- 7238,7244 ----
    gfc_loopinfo loop;
    stmtblock_t fnblock;
    stmtblock_t loopbody;
+   stmtblock_t tmpblock;
    tree decl_type;
    tree tmp;
    tree comp;
*************** structure_alloc_comps (gfc_symbol * der_
*** 7249,7254 ****
--- 7250,7256 ----
    tree ctype;
    tree vref, dref;
    tree null_cond = NULL_TREE;
+   bool called_dealloc_with_status;
  
    gfc_init_block (&fnblock);
  
*************** structure_alloc_comps (gfc_symbol * der_
*** 7359,7375 ****
        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);
! 	    }
  
  	  if (c->attr.allocatable
  	      && (c->attr.dimension || c->attr.codimension))
--- 7361,7372 ----
        switch (purpose)
  	{
  	case DEALLOCATE_ALLOC_COMP:
! 
! 	  /* 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))
*************** structure_alloc_comps (gfc_symbol * der_
*** 7377,7383 ****
  	      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);
  	    }
  	  else if (c->attr.allocatable)
  	    {
--- 7374,7380 ----
  	      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 (&tmpblock, tmp);
  	    }
  	  else if (c->attr.allocatable)
  	    {
*************** structure_alloc_comps (gfc_symbol * der_
*** 7387,7398 ****
  
  	      tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
  						       c->ts);
! 	      gfc_add_expr_to_block (&fnblock, tmp);
  
  	      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);
  	    }
  	  else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
  	    {
--- 7384,7396 ----
  
  	      tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
  						       c->ts);
! 	      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);
  	    }
  	  else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
  	    {
*************** structure_alloc_comps (gfc_symbol * der_
*** 7412,7425 ****
  		{
  		  tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
  							   CLASS_DATA (c)->ts);
! 		  gfc_add_expr_to_block (&fnblock, tmp);
  
  		  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);
  	    }
  	  break;
  
  	case NULLIFY_ALLOC_COMP:
--- 7410,7442 ----
  		{
  		  tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
  							   CLASS_DATA (c)->ts);
! 		  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:
Index: gcc/fortran/class.c
===================================================================
*** gcc/fortran/class.c	(revision 183125)
--- gcc/fortran/class.c	(working copy)
*************** gfc_build_class_symbol (gfc_typespec *ts
*** 432,437 ****
--- 432,438 ----
      }
      
    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;
Index: gcc/testsuite/gfortran.dg/alloc_comp_assign_12.f03
===================================================================
*** gcc/testsuite/gfortran.dg/alloc_comp_assign_12.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/alloc_comp_assign_12.f03	(revision 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" } }
+ 
Index: gcc/testsuite/gfortran.dg/allocatable_scalar_9.f90
===================================================================
*** gcc/testsuite/gfortran.dg/allocatable_scalar_9.f90	(revision 183125)
--- gcc/testsuite/gfortran.dg/allocatable_scalar_9.f90	(working copy)
*************** if(allocated(na3%b3)) call abort()
*** 49,55 ****
  if(allocated(na4%b4)) call abort()
  end
  
! ! { dg-final { scan-tree-dump-times "__builtin_free" 38 "original" } }
  ! { dg-final { cleanup-tree-dump "original" } }
  
  ! { dg-final { cleanup-modules "m" } }
--- 49,55 ----
  if(allocated(na4%b4)) call abort()
  end
  
! ! { dg-final { scan-tree-dump-times "__builtin_free" 32 "original" } }
  ! { dg-final { cleanup-tree-dump "original" } }
  
  ! { dg-final { cleanup-modules "m" } }