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);
call the finalization function of the temporary. Note that the
nullification of allocatable components needed by the result
is done in gfc_trans_assignment_1. */
- if (expr && ((gfc_is_class_array_function (expr)
- && se->ss && se->ss->loop)
+ if (expr && (gfc_is_class_array_function (expr)
|| gfc_is_alloc_class_scalar_function (expr))
&& se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
&& expr->must_finalize)
/* Reallocate if dynamic types are different. */
gfc_init_block (&re_alloc);
- tmp = fold_convert (pvoid_type_node, class_han);
- re = build_call_expr_loc (input_location,
- builtin_decl_explicit (BUILT_IN_REALLOC), 2,
- tmp, size);
- re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp), tmp,
- re);
- tmp = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node, rhs_vptr, old_vptr);
- re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
- tmp, re, build_empty_stmt (input_location));
- gfc_add_expr_to_block (&re_alloc, re);
-
+ if (UNLIMITED_POLY (lhs) && rhs->ts.type == BT_CHARACTER)
+ {
+ gfc_add_expr_to_block (&re_alloc, gfc_call_free (class_han));
+ gfc_allocate_using_malloc (&re_alloc, class_han, size, NULL_TREE);
+ }
+ else
+ {
+ tmp = fold_convert (pvoid_type_node, class_han);
+ re = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_REALLOC),
+ 2, tmp, size);
+ re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp),
+ tmp, re);
+ tmp = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node, rhs_vptr, old_vptr);
+ re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ tmp, re, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&re_alloc, re);
+ }
tree realloc_expr = lhs->ts.type == BT_CLASS ?
gfc_finish_block (&re_alloc) :
build_empty_stmt (input_location);
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);
+ break;
+ }
+ else if ((init_expr->rank && !code->expr3->rank
+ && ref && ref->next && !ref->next->next)
+ || (ref && !ref->next))
+ {
+ rhs->ref = gfc_copy_ref (ref);
+ gfc_free_ref_list (rhs->ref->next);
+ rhs->ref->next = NULL;
+ 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,
--- /dev/null
+! { 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"
+ character(10) :: const
+
+! 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")
+ const = "hijklmnopq"
+ y = const
+ 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(*))
+ 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(*))
+ if (x .ne. carg) stop 3
+ class default
+ stop 4
+ end select
+ end subroutine check2
+end
projects / thirdparty / gcc.git / commitdiff
