diff options
| author | Paul Thomas <pault@gcc.gnu.org> | 2018-06-21 17:34:31 +0000 |
|---|---|---|
| committer | Paul Thomas <pault@gcc.gnu.org> | 2018-06-21 17:34:31 +0000 |
| commit | 75382a9665aa26d35ed2d5f18b2943223ab07b05 (patch) | |
| tree | b16d6362bc01c10d44f13604f3b352d4176cd089 /gcc/fortran/trans-array.c | |
| parent | 7792f13c845a8dc97e6b0a8023d81c67e8d650d2 (diff) | |
| download | gcc-75382a9665aa26d35ed2d5f18b2943223ab07b05.zip gcc-75382a9665aa26d35ed2d5f18b2943223ab07b05.tar.gz gcc-75382a9665aa26d35ed2d5f18b2943223ab07b05.tar.bz2 | |
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
Diffstat (limited to 'gcc/fortran/trans-array.c')
| -rw-r--r-- | gcc/fortran/trans-array.c | 29 |
1 files changed, 27 insertions, 2 deletions
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 193411c..f0f5c1b 100644 --- a/gcc/fortran/trans-array.c +++ b/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))); |