diff options
author | Tobias Burnus <burnus@net-b.de> | 2012-01-29 21:02:19 +0100 |
---|---|---|
committer | Tobias Burnus <burnus@gcc.gnu.org> | 2012-01-29 21:02:19 +0100 |
commit | 4ed1b019f60ffc7d367baf51dc3cfa36f536a395 (patch) | |
tree | d83aaa3db2f9ca3b7af658301c7d70891984792f | |
parent | 9975a30b5c5cab71620d94ddaec21517da9db12a (diff) | |
download | gcc-4ed1b019f60ffc7d367baf51dc3cfa36f536a395.zip gcc-4ed1b019f60ffc7d367baf51dc3cfa36f536a395.tar.gz gcc-4ed1b019f60ffc7d367baf51dc3cfa36f536a395.tar.bz2 |
re PR fortran/51972 ([OOP] Wrong code as _copy does not honor CLASS components)
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
-rw-r--r-- | gcc/fortran/ChangeLog | 6 | ||||
-rw-r--r-- | gcc/fortran/trans-array.c | 51 | ||||
-rw-r--r-- | gcc/testsuite/ChangeLog | 6 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/class_48.f90 | 110 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/class_allocate_12.f90 | 5 |
5 files changed, 173 insertions, 5 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 447479d..48517f50 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -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 diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index b8516af..d3c81a8 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 39dd3a0..f0ecfab 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -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 diff --git a/gcc/testsuite/gfortran.dg/class_48.f90 b/gcc/testsuite/gfortran.dg/class_48.f90 new file mode 100644 index 0000000..c61a8e5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_48.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/class_allocate_12.f90 b/gcc/testsuite/gfortran.dg/class_allocate_12.f90 index 5cb7ab1..2dce84e 100644 --- a/gcc/testsuite/gfortran.dg/class_allocate_12.f90 +++ b/gcc/testsuite/gfortran.dg/class_allocate_12.f90 @@ -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 |