re PR fortran/83118 (Bad intrinsic assignment of class(*) array component of derived...

2018-06-21  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/83118
	* resolve.c (resolve_ordinary_assign): Force the creation of a
	vtable for assignment of non-polymorphic expressions to an
	unlimited polymorphic object.
	* trans-array.c (gfc_alloc_allocatable_for_assignment): Use the
	size of the rhs type for such assignments. Set the dtype, _len
	and vptrs appropriately.
	* trans-expr.c (gfc_trans_assignment): Force the use of the
	_copy function for these assignments.

2018-06-21  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/83118
	* gfortran.dg/unlimited_polymorphic_30.f03: New test.

From-SVN: r261857

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 99a311490c558aea9f29658219af37d6c5caa57f..852f36e8f7cf66728ac92b06e270dd607982ebb8 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,15 @@
+2018-06-21  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/83118
+       * resolve.c (resolve_ordinary_assign): Force the creation of a
+       vtable for assignment of non-polymorphic expressions to an
+       unlimited polymorphic object.
+       * trans-array.c (gfc_alloc_allocatable_for_assignment): Use the
+       size of the rhs type for such assignments. Set the dtype, _len
+       and vptrs appropriately.
+       * trans-expr.c (gfc_trans_assignment): Force the use of the
+       _copy function for these assignments.
+
 2018-06-20  Chung-Lin Tang <cltang@codesourcery.com>
            Thomas Schwinge <thomas@codesourcery.com>
            Cesar Philippidis  <cesar@codesourcery.com>
@@ -38,7 +50,7 @@
 2018-06-13  Steven G. Kargl  <kargl@gcc.gnu.org>
 
        PR fortran/86110
-       * array.c (gfc_resolve_character_array_constructor): Avoid NULL 
+       * array.c (gfc_resolve_character_array_constructor): Avoid NULL
        pointer dereference.
 
 2018-06-13  Cesar Philippidis  <cesar@codesourcery.com>

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index b1d4e0327739aaa7d5443ab6e5f3f250d1146d02..1cc31652920eafda93edbf868826410f7df2df09 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -10385,6 +10385,11 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
       && rhs->expr_type != EXPR_ARRAY)
     gfc_add_data_component (rhs);
 
+  /* Make sure there is a vtable and, in particular, a _copy for the
+     rhs type.  */
+  if (UNLIMITED_POLY (lhs) && lhs->rank && rhs->ts.type != BT_CLASS)
+    gfc_find_vtab (&rhs->ts);
+
   bool caf_convert_to_send = flag_coarray == GFC_FCOARRAY_LIB
       && (lhs_coindexed
          || (code->expr2->expr_type == EXPR_FUNCTION

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 193411c2674c827291887c9dddc3155123a35d58..f0f5c1b709ee2841174a2aadf49dac453bb45ad5 100644 (file)
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -9951,6 +9951,8 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
                             gfc_array_index_type, tmp,
                             expr1->ts.u.cl->backend_decl);
     }
+  else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
+    tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
   else
     tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
   tmp = fold_convert (gfc_array_index_type, tmp);
@@ -9977,6 +9979,28 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
       gfc_add_modify (&fblock, tmp,
                      gfc_get_dtype_rank_type (expr1->rank,type));
     }
+  else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
+    {
+      tree type;
+      tmp = gfc_conv_descriptor_dtype (desc);
+      type = gfc_typenode_for_spec (&expr2->ts);
+      gfc_add_modify (&fblock, tmp,
+                     gfc_get_dtype_rank_type (expr2->rank,type));
+      /* Set the _len field as well...  */
+      tmp = gfc_class_len_get (TREE_OPERAND (desc, 0));
+      if (expr2->ts.type == BT_CHARACTER)
+       gfc_add_modify (&fblock, tmp,
+                       fold_convert (TREE_TYPE (tmp),
+                                     TYPE_SIZE_UNIT (type)));
+      else
+       gfc_add_modify (&fblock, tmp,
+                       build_int_cst (TREE_TYPE (tmp), 0));
+      /* ...and the vptr.  */
+      tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0));
+      tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
+      tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
+      gfc_add_modify (&fblock, tmp, tmp2);
+    }
   else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
     {
       gfc_add_modify (&fblock, gfc_conv_descriptor_dtype (desc),
@@ -10082,10 +10106,11 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
 
 
   /* We already set the dtype in the case of deferred character
-     length arrays.  */
+     length arrays and unlimited polymorphic arrays.  */
   if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
        && ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
-           || coarray)))
+           || coarray))
+      && !UNLIMITED_POLY (expr1))
     {
       tmp = gfc_conv_descriptor_dtype (desc);
       gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index b2a645beba48bcfea0047dee1fc3a1fce2775bad..f369b1b1be961a6285c2f82a855bdc21ab195c8f 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -10437,6 +10437,10 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
        return tmp;
     }
 
+  if (UNLIMITED_POLY (expr1) && expr1->rank
+      && expr2->ts.type != BT_CLASS)
+    use_vptr_copy = true;
+
   /* Fallback to the scalarizer to generate explicit loops.  */
   return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
                                 use_vptr_copy, may_alias);

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 977a22d0bf6995b1b15f5d03b409d7b43d5715f1..60d02cb4b9d4466c32a86dd8ab068c348ed201aa 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2018-06-21  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/83118
+       * gfortran.dg/unlimited_polymorphic_30.f03: New test.
+
 2018-06-21  Tom de Vries  <tdevries@suse.de>
 
        * gcc.dg/guality/pr45882.c (a): Add used attribute.

diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_30.f03 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_30.f03
new file mode 100644 (file)
index 0000000..4d0c2e7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_30.f03
@@ -0,0 +1,38 @@
+! { dg-do run }
+!
+! Test the fix for PR83318.
+!
+! Contributed by Neil Carlson  <neil.n.carlson@gmail.com>
+!
+type :: any_vector
+  class(*), allocatable :: v(:)
+end type
+type(any_vector) :: x, y
+
+! This did not work correctly
+  x%v = ['foo','bar']
+  call foo (x, 1)
+
+! This was reported as not working correctly but was OK before the above was fixed
+  y = x
+  call foo (y, 2)
+
+  x%v = [1_4,2_4]
+  call foo (x, 3)
+
+  y = x
+  call foo (y, 4)
+
+contains
+
+  subroutine foo (arg, n)
+    type (any_vector) :: arg
+    integer :: n
+    select type (v => arg%v)
+        type is (character(*))
+           if (any (v .ne. ["foo","bar"])) stop n
+        type is (integer(4))
+           if (any (v .ne. [1_4,2_4])) stop n
+    end select
+  end subroutine
+end