OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/51972 ([OOP] Wrong code as _copy does not honor CLASS components)

Browse Source 
2012-01-29  Tobias Burnus  <burnus@net-b.de>

        PR fortran/51972
        * trans-array.c (structure_alloc_comps): Fix assignment of
        polymorphic components (polymorphic deep copying).

2012-01-29  Tobias Burnus  <burnus@net-b.de>

        PR fortran/51972
        * gfortran.dg/class_allocate_12.f90: Enable disabled test.
        * gfortran.dg/class_48.f90: New.

From-SVN: r183680
This commit is contained in:
Tobias Burnus 2012-01-29 21:02:19 +01:00 committed by Tobias Burnus
parent 9975a30b5c
commit 4ed1b019f6
5 changed files with 173 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/fortran/ChangeLog
View File

@ -1,3 +1,9 @@
2012-01-29 Tobias Burnus <burnus@net-b.de>
PR fortran/51972
* trans-array.c (structure_alloc_comps): Fix assignment of
polymorphic components (polymorphic deep copying).
2012-01-29 Janne Blomqvist <jb@gcc.gnu.org>
PR fortran/51808

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

@ -7532,6 +7532,57 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
cdecl, NULL_TREE);
dcmp = fold_convert (TREE_TYPE (comp), dcmp);
if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
{
tree ftn_tree;
tree size;
tree dst_data;
tree src_data;
tree null_data;
dst_data = gfc_class_data_get (dcmp);
src_data = gfc_class_data_get (comp);
size = fold_convert (size_type_node, gfc_vtable_size_get (comp));
if (CLASS_DATA (c)->attr.dimension)
{
nelems = gfc_conv_descriptor_size (src_data,
CLASS_DATA (c)->as->rank);
src_data = gfc_conv_descriptor_data_get (src_data);
dst_data = gfc_conv_descriptor_data_get (dst_data);
}
else
nelems = build_int_cst (size_type_node, 1);
gfc_init_block (&tmpblock);
/* We need to use CALLOC as _copy might try to free allocatable
components of the destination. */
ftn_tree = builtin_decl_explicit (BUILT_IN_CALLOC);
tmp = build_call_expr_loc (input_location, ftn_tree, 2, nelems,
size);
gfc_add_modify (&tmpblock, dst_data,
fold_convert (TREE_TYPE (dst_data), tmp));
tmp = gfc_copy_class_to_class (comp, dcmp, nelems);
gfc_add_expr_to_block (&tmpblock, tmp);
tmp = gfc_finish_block (&tmpblock);
gfc_init_block (&tmpblock);
gfc_add_modify (&tmpblock, dst_data,
fold_convert (TREE_TYPE (dst_data),
null_pointer_node));
null_data = gfc_finish_block (&tmpblock);
null_cond = fold_build2_loc (input_location, NE_EXPR,
boolean_type_node, src_data,
null_pointer_node);
gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond,
tmp, null_data));
continue;
}
if (c->attr.allocatable && !cmp_has_alloc_comps)
{
rank = c->as ? c->as->rank : 0;

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
2012-01-29 Tobias Burnus <burnus@net-b.de>
PR fortran/51972
* gfortran.dg/class_allocate_12.f90: Enable disabled test.
* gfortran.dg/class_48.f90: New.
2012-01-29 Janne Blomqvist <jb@gcc.gnu.org>
PR fortran/51808

110
gcc/testsuite/gfortran.dg/class_48.f90 Normal file
View File

@ -0,0 +1,110 @@
! { dg-do run }
!
! PR fortran/51972
!
! Check whether DT assignment with polymorphic components works.
!
subroutine test1 ()
type t
integer :: x
end type t
type t2
class(t), allocatable :: a
end type t2
type(t2) :: one, two
one = two
if (allocated (one%a)) call abort ()
allocate (two%a)
two%a%x = 7890
one = two
if (one%a%x /= 7890) call abort ()
deallocate (two%a)
one = two
if (allocated (one%a)) call abort ()
end subroutine test1
subroutine test2 ()
type t
integer, allocatable :: x(:)
end type t
type t2
class(t), allocatable :: a
end type t2
type(t2) :: one, two
one = two
if (allocated (one%a)) call abort ()
allocate (two%a)
one = two
if (.not.allocated (one%a)) call abort ()
if (allocated (one%a%x)) call abort ()
allocate (two%a%x(2))
two%a%x(:) = 7890
one = two
if (any (one%a%x /= 7890)) call abort ()
deallocate (two%a)
one = two
if (allocated (one%a)) call abort ()
end subroutine test2
subroutine test3 ()
type t
integer :: x
end type t
type t2
class(t), allocatable :: a(:)
end type t2
type(t2) :: one, two
one = two
if (allocated (one%a)) call abort ()
allocate (two%a(2), source=[t(4), t(6)])
one = two
if (.not.allocated (one%a)) call abort ()
! FIXME: Check value
deallocate (two%a)
one = two
if (allocated (one%a)) call abort ()
end subroutine test3
subroutine test4 ()
type t
integer, allocatable :: x(:)
end type t
type t2
class(t), allocatable :: a(:)
end type t2
type(t2) :: one, two
one = two
if (allocated (one%a)) call abort ()
! allocate (two%a(2)) ! ICE: SEGFAULT
! one = two
! if (.not. allocated (one%a)) call abort ()
end subroutine test4
call test1 ()
call test2 ()
call test3 ()
call test4 ()
end

5
gcc/testsuite/gfortran.dg/class_allocate_12.f90
View File

@ -4,10 +4,6 @@
!
! Contributed by Damian Rouson
!
! TODO: Remove the STOP line below after fixing
! The remaining issue of the PR
!
module surrogate_module
type ,abstract :: surrogate
end type
@ -78,7 +74,6 @@ contains
class is (integrand)
allocate (this_half, source=this)
end select
STOP 'SUCESS!' ! See TODO above
end subroutine
end module