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 <pa...@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 <pa...@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.
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" } }
