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 <pa...@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 <pa...@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.carl...@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
