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

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

	PR fortran/83118
	Back port from trunk
	* 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-25  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/83118
	Back port from trunk
	* gfortran.dg/unlimited_polymorphic_30.f03: New test.

From-SVN: r262005

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 95d622a7a21b231b9a72c3e6b662e4b7050dd785..448203f0bc922d056ffb6b89ba6d792bf42623cc 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,16 @@
+2018-06-25  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/83118
+       Back port from trunk
+       * 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-22  Jakub Jelinek  <jakub@redhat.com>
 
        Backported from mainline
@@ -10,7 +23,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-12  Steven G. Kargl  <kargl@gcc.gnu.org>

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index d5e74823c714e87a235348017523bc2a8b0d3750..483f3b2a7b703dba5e7d5ae421e7f4893896a1d0 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -10151,6 +10151,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 6be9c70a67814636e230898385f8a3fc167caf7c..cc9eb74f2fad160450c68d945f708308bf25e87c 100644 (file)
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -9382,6 +9382,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);
@@ -9408,6 +9410,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),
@@ -9513,10 +9537,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 e1205e36b97c9d4bfb4ec11f856d65e33f62a6b8..d7cab27e6ee2874bdd20d78c3abd1aefec85800c 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -10330,6 +10330,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 9e900c54b18062bc1e33828ed5462564ba0e22b5..c426ecb256cb02f95734ecb3b44a91ea577e894d 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2018-06-25  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/83118
+       Back port from trunk
+       * gfortran.dg/unlimited_polymorphic_30.f03: New test.
+
 2018-06-23  Richard Sandiford  <richard.sandiford@linaro.org>
 
        PR tree-optimization/85989

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