[Patch, fortran] PR83118 - [7/8/9 Regression] Bad intrinsic assignment of class(*) array component of derived type

[Paul Richard Thomas <paul dot richard dot thomas at gmail dot com>]

The original problem was fixed by the patch for PR84546. This patch
fixes a variant that appears in comment #6.

The fix is completely straightforward and described by the comments
and ChangeLogs.

Bootstrapped and regtested on FC28/x86_64 - OK for trunk?

I am not sure that this problem is a regression on 7-branch and have
not yet checked if the patch is even compatible with it. However, I
can certainly fix 8-branch and will have a go at 7-branch.

Cheers

Paul

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.

Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 261126)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_ordinary_assign (gfc_code *code,
*** 10374,10379 ****
--- 10387,10397 ----
        && 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
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 261126)
--- gcc/fortran/trans-array.c	(working copy)
*************** gfc_alloc_allocatable_for_assignment (gf
*** 9948,9953 ****
--- 9948,9955 ----
  			     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);
*************** gfc_alloc_allocatable_for_assignment (gf
*** 9974,9979 ****
--- 9976,10003 ----
        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),
*************** gfc_alloc_allocatable_for_assignment (gf
*** 10079,10088 ****


    /* We already set the dtype in the case of deferred character
!      length arrays.  */
    if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
  	&& ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
! 	    || coarray)))
      {
        tmp = gfc_conv_descriptor_dtype (desc);
        gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
--- 10103,10113 ----


    /* We already set the dtype in the case of deferred character
!      length arrays and unlimited polymorphic arrays.  */
    if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
  	&& ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
! 	    || coarray))
!       && !UNLIMITED_POLY (expr1))
      {
        tmp = gfc_conv_descriptor_dtype (desc);
        gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 261126)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_trans_assignment (gfc_expr * expr1,
*** 10431,10436 ****
--- 10431,10440 ----
  	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);
Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_30.f03
===================================================================
*** gcc/testsuite/gfortran.dg/unlimited_polymorphic_30.f03	(nonexistent)
--- gcc/testsuite/gfortran.dg/unlimited_polymorphic_30.f03	(working copy)
***************
*** 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