@@ -5957,6 +5957,11 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
tmp = gfc_conv_descriptor_dtype (descriptor);
gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
}
+ else if (expr3_desc && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr3_desc)))
+ {
+ tmp = gfc_conv_descriptor_dtype (descriptor);
+ gfc_add_modify (pblock, tmp, gfc_conv_descriptor_dtype (expr3_desc));
+ }
else
{
tmp = gfc_conv_descriptor_dtype (descriptor);
@@ -11324,6 +11329,9 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
gfc_add_modify (&fblock, tmp,
fold_convert (TREE_TYPE (tmp),
TYPE_SIZE_UNIT (type)));
+ else if (UNLIMITED_POLY (expr2))
+ gfc_add_modify (&fblock, tmp,
+ gfc_class_len_get (TREE_OPERAND (desc, 0)));
else
gfc_add_modify (&fblock, tmp,
build_int_cst (TREE_TYPE (tmp), 0));
@@ -7187,6 +7187,45 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3);
flag_realloc_lhs = 0;
+ /* The handling of code->expr3 above produces a derived type of
+ type "STAR", whose size defaults to size(void*). In order to
+ have the right type information for the assignment, we must
+ reconstruct an unlimited polymorphic rhs. */
+ if (UNLIMITED_POLY (code->expr3)
+ && e3rhs && e3rhs->ts.type == BT_DERIVED
+ && !strcmp (e3rhs->ts.u.derived->name, "STAR"))
+ {
+ gfc_ref *ref;
+ gcc_assert (TREE_CODE (expr3_vptr) == COMPONENT_REF);
+ tmp = gfc_create_var (gfc_typenode_for_spec (&code->expr3->ts),
+ "e3");
+ gfc_add_modify (&block, tmp,
+ gfc_get_class_from_expr (expr3_vptr));
+ rhs->symtree->n.sym->backend_decl = tmp;
+ rhs->ts = code->expr3->ts;
+ rhs->symtree->n.sym->ts = rhs->ts;
+ for (ref = init_expr->ref; ref; ref = ref->next)
+ {
+ /* Copy over the lhs _data component ref followed by the
+ full array reference for source expressions with rank.
+ Otherwise, just copy the _data component ref. */
+ if (code->expr3->rank
+ && ref && ref->next && !ref->next->next)
+ {
+ rhs->ref = gfc_copy_ref (ref);
+ rhs->ref->next = gfc_copy_ref (ref->next);
+ break;
+ }
+ else if ((init_expr->rank && !code->expr3->rank
+ && ref && ref->next && !ref->next->next)
+ || (ref && !ref->next))
+ {
+ rhs->ref = gfc_copy_ref (ref);
+ break;
+ }
+ }
+ }
+
/* Set the symbol to be artificial so that the result is not finalized. */
init_expr->symtree->n.sym->attr.artificial = 1;
tmp = gfc_trans_assignment (init_expr, rhs, true, false, true,
new file mode 100644
@@ -0,0 +1,86 @@
+! { dg-do run }
+! Test the fix for comment 1 in PR113363, which failed as in comments below.
+! Contributed by Harald Anlauf <anlauf@gcc.gnu.org>
+program p
+ implicit none
+ class(*), allocatable :: x(:), y
+ character(*), parameter :: arr(2) = ["hello ","bye "], &
+ sca = "Have a nice day"
+
+! Bug was detected in polymorphic array function results
+ allocate(x, source = foo ())
+ call check1 (x, arr) ! Wrong output "6 hello e"
+ deallocate (x)
+ x = foo ()
+ call check1 (x, arr) ! Wrong output "0 "
+ associate (var => foo ()) ! OK after r14-9489-g3fd46d859cda10
+ call check1 (var, arr) ! Now OK - outputs: "6 hello bye "
+ end associate
+
+! Check scalar function results ! All OK
+ allocate (y, source = bar())
+ call check2 (y, sca)
+ deallocate (y)
+ y = bar ()
+ call check2 (y, sca)
+ deallocate (y)
+ associate (var => bar ())
+ call check2 (var, sca)
+ end associate
+
+! Finally variable expressions...
+ allocate (y, source = x(1)) ! Gave zero length here
+ call check2 (y, "hello")
+ y = x(2) ! Segfaulted here
+ call check2 (y, "bye ")
+ associate (var => x(2)) ! Gave zero length here
+ call check2 (var, "bye ")
+ end associate
+
+! ...and constant expressions ! All OK
+ deallocate(y)
+ allocate (y, source = "abcde")
+ call check2 (y, "abcde")
+ y = "hijklmnopq"
+ call check2 (y, "hijklmnopq")
+ associate (var => "mnopq")
+ call check2 (var, "mnopq")
+ end associate
+ deallocate (x, y)
+
+contains
+
+ function foo() result(res)
+ class(*), allocatable :: res(:)
+ res = arr
+ end function foo
+
+ function bar() result(res)
+ class(*), allocatable :: res
+ res = sca
+ end function bar
+
+ subroutine check1 (x, carg)
+ class(*), intent(in) :: x(:)
+ character(*) :: carg(:)
+ select type (x)
+ type is (character(*))
+! print *, len(x), x
+ if (any (x .ne. carg)) stop 1
+ class default
+ stop 2
+ end select
+ end subroutine check1
+
+ subroutine check2 (x, carg)
+ class(*), intent(in) :: x
+ character(*) :: carg
+ select type (x)
+ type is (character(*))
+! print *, len(x), x
+ if (x .ne. carg) stop 3
+ class default
+ stop 4
+ end select
+ end subroutine check2
+end