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

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

gcc/fortran/ChangeLog

+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>

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

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)));

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);

gcc/testsuite/ChangeLog

+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.

gcc/testsuite/gfortran.dg/unlimited_polymorphic_30.f03

+! { 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