===================================================================
*************** resolve_ordinary_assign (gfc_code *code,
&& 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
===================================================================
*************** gfc_alloc_allocatable_for_assignment (gf
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
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
/* 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)));
/* 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)));
===================================================================
*************** gfc_trans_assignment (gfc_expr * expr1,
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);
===================================================================
***************
+ ! { 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