git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

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
This commit is contained in:
Paul Thomas 2012-01-13 20:42:01 +00:00
parent 04771457dc
commit d6430d9a0c
6 changed files with 94 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
gcc/fortran/ChangeLog
View File

@ -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

1
gcc/fortran/class.c
View File

@ -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;

47
gcc/fortran/trans-array.c
View File

@ -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:

7
gcc/testsuite/ChangeLog
View File

@ -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

44
gcc/testsuite/gfortran.dg/alloc_comp_assign_12.f03 Normal file
View File

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

2
gcc/testsuite/gfortran.dg/allocatable_scalar_9.f90
View File

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