Commit d6430d9a by Paul Thomas

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
parent 04771457
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> 2012-01-13 Tobias Burnus <burnus@net-b.de>
PR fortran/51842 PR fortran/51842
......
...@@ -432,6 +432,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, ...@@ -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.extension = ts->u.derived->attr.extension + 1;
fclass->attr.alloc_comp = ts->u.derived->attr.alloc_comp;
fclass->attr.is_class = 1; fclass->attr.is_class = 1;
ts->u.derived = fclass; ts->u.derived = fclass;
attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0; attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0;
......
...@@ -7238,6 +7238,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, ...@@ -7238,6 +7238,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
gfc_loopinfo loop; gfc_loopinfo loop;
stmtblock_t fnblock; stmtblock_t fnblock;
stmtblock_t loopbody; stmtblock_t loopbody;
stmtblock_t tmpblock;
tree decl_type; tree decl_type;
tree tmp; tree tmp;
tree comp; tree comp;
...@@ -7249,6 +7250,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, ...@@ -7249,6 +7250,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
tree ctype; tree ctype;
tree vref, dref; tree vref, dref;
tree null_cond = NULL_TREE; tree null_cond = NULL_TREE;
bool called_dealloc_with_status;
gfc_init_block (&fnblock); gfc_init_block (&fnblock);
...@@ -7359,17 +7361,12 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, ...@@ -7359,17 +7361,12 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
switch (purpose) switch (purpose)
{ {
case DEALLOCATE_ALLOC_COMP: case DEALLOCATE_ALLOC_COMP:
if (cmp_has_alloc_comps && !c->attr.pointer)
{ /* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp
/* Do not deallocate the components of ultimate pointer (ie. this function) so generate all the calls and suppress the
components. */ recursion from here, if necessary. */
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, called_dealloc_with_status = false;
decl, cdecl, NULL_TREE); gfc_init_block (&tmpblock);
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 if (c->attr.allocatable
&& (c->attr.dimension || c->attr.codimension)) && (c->attr.dimension || c->attr.codimension))
...@@ -7377,7 +7374,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, ...@@ -7377,7 +7374,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE); decl, cdecl, NULL_TREE);
tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension); 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) else if (c->attr.allocatable)
{ {
...@@ -7387,12 +7384,13 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, ...@@ -7387,12 +7384,13 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL, tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
c->ts); 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, tmp = fold_build2_loc (input_location, MODIFY_EXPR,
void_type_node, comp, void_type_node, comp,
build_int_cst (TREE_TYPE (comp), 0)); 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) 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, ...@@ -7412,14 +7410,33 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
{ {
tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL, tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
CLASS_DATA (c)->ts); 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, tmp = fold_build2_loc (input_location, MODIFY_EXPR,
void_type_node, comp, void_type_node, comp,
build_int_cst (TREE_TYPE (comp), 0)); 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); gfc_add_expr_to_block (&fnblock, tmp);
} }
/* Now add the deallocation of this component. */
gfc_add_block_to_block (&fnblock, &tmpblock);
break; break;
case NULLIFY_ALLOC_COMP: case NULLIFY_ALLOC_COMP:
......
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> 2012-01-13 Jason Merrill <jason@redhat.com>
PR c++/20681 PR c++/20681
......
! { 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" } }
...@@ -49,7 +49,7 @@ if(allocated(na3%b3)) call abort() ...@@ -49,7 +49,7 @@ if(allocated(na3%b3)) call abort()
if(allocated(na4%b4)) call abort() if(allocated(na4%b4)) call abort()
end 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-tree-dump "original" } }
! { dg-final { cleanup-modules "m" } } ! { dg-final { cleanup-modules "m" } }
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment