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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 447479d631d6a2042ee132d4838143c5a0338bb7..48517f504499dab8821a712a4d66462c75ff49c1 100644 (file)
--- 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 b8516afc5346cc4bb00df423595ad8f98a994cc9..d3c81a82ab8381ab02143267d02606e1a7bd0b4c 100644 (file)
--- 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 39dd3a00f07a4537983ffb6e8deeafc6c9a53228..f0ecfab3f25805fdf309b72485ded6c7d7bc872f 100644 (file)
--- 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 (file)
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 5cb7ab177f224c74264692370dd941cdbc118d7f..2dce84e6133b300850d79869bdcc661a36ab84e5 100644 (file)
--- 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