From: Paul Thomas Date: Thu, 21 Jun 2018 17:34:31 +0000 (+0000) Subject: re PR fortran/83118 (Bad intrinsic assignment of class(*) array component of derived... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=75382a9665aa26d35ed2d5f18b2943223ab07b05;p=gcc.git re PR fortran/83118 (Bad intrinsic assignment of class(*) array component of derived type) 2018-06-21 Paul Thomas 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 PR fortran/83118 * gfortran.dg/unlimited_polymorphic_30.f03: New test. From-SVN: r261857 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 99a311490c5..852f36e8f7c 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,15 @@ +2018-06-21 Paul Thomas + + 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 Thomas Schwinge Cesar Philippidis @@ -38,7 +50,7 @@ 2018-06-13 Steven G. Kargl 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 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index b1d4e032773..1cc31652920 100644 --- a/gcc/fortran/resolve.c +++ b/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 diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 193411c2674..f0f5c1b709e 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))); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index b2a645beba4..f369b1b1be9 100644 --- a/gcc/fortran/trans-expr.c +++ b/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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 977a22d0bf6..60d02cb4b9d 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2018-06-21 Paul Thomas + + PR fortran/83118 + * gfortran.dg/unlimited_polymorphic_30.f03: New test. + 2018-06-21 Tom de Vries * gcc.dg/guality/pr45882.c (a): Add used attribute. diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_30.f03 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_30.f03 new file mode 100644 index 00000000000..4d0c2e7250b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_30.f03 @@ -0,0 +1,38 @@ +! { dg-do run } +! +! Test the fix for PR83318. +! +! Contributed by Neil Carlson +! +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