Dear all,
for derived type assignment one needs to call "vtab->_copy" for
polymorphic components. Currently, this does not happen.
The attached draft patch adds support for this, fixing the
gfortran.dg/class_allocate_12.f90 test case (with STOP removed),
chapter07/strategy_surrogate_f2003 of Damian's book, and the example of
comment 3 of the PR - as well as the more extended attached test case.
With this patch, all examples of Damian's book* now compile and run with
gfortran. The only exception failures with polymorphic coarrays (PR
51947) and those examples which use unimplemented features
(deferred-length character components and finalization subroutines). [*
see http://www.cambridge.org/rouson]
Test case issues:
- I failed to check the result of test3 as couldn't find a way to test
for the result without hitting PR46356 / PR51754.
- For test4, I get an ICE for the allocate statement, cf. PR 52044.
Build and regtested on x86-64-linux.
OK for the trunk?
Tobias
<http://www.cambridge.org/rouson>
PS: Other patches which have still to be reviewed:
- http://gcc.gnu.org/ml/fortran/2012-01/msg00197.html (default init ICE)
- http://gcc.gnu.org/ml/fortran/2012-01/msg00241.html (ambiguity check fix)
- http://gcc.gnu.org/ml/fortran/2012-01/msg00247.html (FE optimization)
<http://www.cambridge.org/rouson>
2012-01-29 Tobias Burnus <bur...@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 <bur...@net-b.de>
PR fortran/51972
* gfortran.dg/class_allocate_12.f90: Enable disabled test.
* gfortran.dg/class_48.f90: New.
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c (Revision 183676)
+++ gcc/fortran/trans-array.c (Arbeitskopie)
@@ -7532,6 +7532,57 @@ structure_alloc_comps (gfc_symbol * der_type, tree
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;
Index: gcc/testsuite/gfortran.dg/class_allocate_12.f90
===================================================================
--- gcc/testsuite/gfortran.dg/class_allocate_12.f90 (Revision 183676)
+++ gcc/testsuite/gfortran.dg/class_allocate_12.f90 (Arbeitskopie)
@@ -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
Index: gcc/testsuite/gfortran.dg/class_48.f90
===================================================================
--- gcc/testsuite/gfortran.dg/class_48.f90 (Revision 0)
+++ gcc/testsuite/gfortran.dg/class_48.f90 (Arbeitskopie)
@@ -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
