Hi All,
This patch corrects incorrect results from assignment of unlimited
polymorphic function results both in assignment statements and allocation
with source.
The first chunk in trans-array.cc ensures that the array dtype is set to
the source dtype. The second chunk ensures that the lhs _len field does not
default to zero and so is specific to dynamic types of character.
The addition to trans-stmt.cc transforms the source expression, aka expr3,
from a derived type of type "STAR" into a proper unlimited polymorphic
expression ready for assignment to the newly allocated entity.
OK for mainline?
Paul
Fortran: Fix wrong code in unlimited polymorphic assignment [PR113363]
2024-04-10 Paul Thomas
gcc/fortran
PR fortran/113363
* trans-array.cc (gfc_array_init_size): Use the expr3 dtype so
that the correct element size is used.
(gfc_alloc_allocatable_for_assignment): Set the _len field for
unlimited polymorphic assignments.
* 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.
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 30b84762346..2f9a32dda15 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -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));
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 7997c167bae..c6953033cf4 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -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,
diff --git a/gcc/testsuite/gfortran.dg/pr113363.f90 b/gcc/testsuite/gfortran.dg/pr113363.f90
new file mode 100644
index 000..7701539fdff
--- /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
+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) !
