https://gcc.gnu.org/g:d15664f71c150a1b0e6cc07c0534b356b111344d
commit r14-10478-gd15664f71c150a1b0e6cc07c0534b356b111344d
Author: Paul Thomas <pa...@gcc.gnu.org>
Date: Mon May 13 07:27:20 2024 +0100
Fortran: Fix wrong code in unlimited polymorphic assignment [PR113363]
2024-05-13 Paul Thomas <pa...@gcc.gnu.org>
gcc/fortran
PR fortran/113363
* trans-array.cc (gfc_array_init_size): Use the expr3 dtype so
that the correct element size is used.
* trans-expr.cc (gfc_conv_procedure_call): Remove restriction
that ss and ss->loop be present for the finalization of class
array function results.
(trans_class_assignment): Use free and malloc, rather than
realloc, for character expressions assigned to unlimited poly
entities.
* trans-stmt.cc (gfc_trans_allocate): Build a correct rhs for
the assignment of an unlimited polymorphic 'source'.
gcc/testsuite/
PR fortran/113363
* gfortran.dg/pr113363.f90: New test.
(cherry picked from commit 2d0eeb529d400e61197a09c56011be976dd81ef0)
Diff:
---
gcc/fortran/trans-array.cc | 5 ++
gcc/fortran/trans-expr.cc | 34 ++++++++------
gcc/fortran/trans-stmt.cc | 40 ++++++++++++++++
gcc/testsuite/gfortran.dg/pr113363.f90 | 86 ++++++++++++++++++++++++++++++++++
4 files changed, 151 insertions(+), 14 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index d69a437980bc..b621f42917c9 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -5964,6 +5964,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);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 114e7629182a..dfc5b8e9b4a5 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -8249,8 +8249,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
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)
@@ -12032,18 +12031,25 @@ trans_class_assignment (stmtblock_t *block, gfc_expr
*lhs, gfc_expr *rhs,
/* 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);
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 59237b8cdfb5..703a705e7caf 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -7229,6 +7229,46 @@ 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);
+ 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,
diff --git a/gcc/testsuite/gfortran.dg/pr113363.f90
b/gcc/testsuite/gfortran.dg/pr113363.f90
new file mode 100644
index 000000000000..99d4f2076d88
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr113363.f90
@@ -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 <anl...@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
