Hi Mikael,
The patch applies cleanly, regtests and fixes the problem, as advertised.
It does likewise on 15-branch.
Good for mainline and, I would suggest, backporting.
Thanks for the patch.
Paul
On Wed, 30 Jul 2025 at 10:04, Mikael Morin <morin-mik...@orange.fr> wrote:
> From: Mikael Morin <mik...@gcc.gnu.org>
>
> This one may look like a collection of obscure random changes.
> It started with the removal of an isolated array descriptor offset
> update, and the chain of regression fixes that followed completed it to
> the below. I have even found a testcase that is fixed by it.
>
> Regression-tested on x86_64-pc-linux-gnu.
> OK for master?
>
> -- >8 --
>
> There is code in gfc_conv_procedure_call that, for polymorphic
> functions, initializes the scalarization array descriptor
> information and forcedfully sets loop bounds. This code is changing
> the decisions made by the scalarizer behind his back, and the test shows
> an example where the consequences are (badly) visible. In the test, for
> one of the actual arguments to an elemental subroutine, an offset to the
> loop variable is missing to access the array, as it was the one
> originally chosen to set the loop bounds from.
>
> This could theoretically be fixed by just clearing the array of choice
> for the loop bounds. This change takes instead the harder path of
> adding the missing information to the scalarizer's knowledge so that its
> decision doesn't need to be forced to something else after the fact.
> The array descriptor information initialisation for polymorphic
> functions is moved to gfc_add_loop_ss_code (after the function call
> generation), and the loop bounds initialization to a new function called
> after that.
>
> As the array chosen to set the loop bounds from is no longer forced
> to be the polymorphic function result, we have to let the scalarizer set
> a delta for polymorphic function results. For regular non-polymorphic
> function result arrays, they are zero-based and the temporary creation
> makes the loop zero-based as well, so we can continue to skip the delta
> calculation.
>
> In the cases where a temporary is created to store the result of the
> array function, the creation of the temporary shifts the loop bounds
> to be zero-based. As there was no delta for polymorphic result arrays,
> the function result descriptor offset was set to zero in that case for
> a zero-based array reference to be correct. Now that the scalarizer
> sets a delta, those forced offset updates have to go because they can
> make the descriptor invalid and cause erroneous array references.
>
> gcc/fortran/ChangeLog:
>
> * trans-expr.cc (gfc_conv_subref_array_arg): Remove offset
> update.
> (gfc_conv_procedure_call): For polymorphic functions, move the
> scalarizer descriptor information...
> * trans-array.cc (gfc_add_loop_ss_code): ... here, and evaluate
> the bounds to fresh variables.
> (get_class_info_from_ss): Remove offset update.
> (gfc_conv_ss_startstride): Don't set a zero value for function
> result upper bounds.
> (late_set_loop_bounds): New.
> (gfc_conv_loop_setup): If the bounds of a function result have
> been set, and no other array provided loop bounds for a
> dimension, use the function result bounds as loop bounds for
> that dimension.
> (gfc_set_delta): Don't skip delta setting for polymorphic
> function results.
>
> gcc/testsuite/ChangeLog:
>
> * gfortran.dg/class_elemental_1.f90: New test.
> ---
> gcc/fortran/trans-array.cc | 113 ++++++++++++++----
> gcc/fortran/trans-expr.cc | 35 +-----
> .../gfortran.dg/class_elemental_1.f90 | 34 ++++++
> 3 files changed, 128 insertions(+), 54 deletions(-)
> create mode 100644 gcc/testsuite/gfortran.dg/class_elemental_1.f90
>
> diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
> index 0f7637dd535..9a738bd5204 100644
> --- a/gcc/fortran/trans-array.cc
> +++ b/gcc/fortran/trans-array.cc
> @@ -1426,12 +1426,6 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss
> *ss, tree *eltype,
> tmp2 = gfc_class_len_get (class_expr);
> gfc_add_modify (pre, tmp, tmp2);
> }
> -
> - if (rhs_function)
> - {
> - tmp = gfc_class_data_get (class_expr);
> - gfc_conv_descriptor_offset_set (pre, tmp, gfc_index_zero_node);
> - }
> }
> else if (rhs_ss->info->data.array.descriptor)
> {
> @@ -3372,18 +3366,48 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss
> * ss, bool subscript,
> break;
>
> case GFC_SS_FUNCTION:
> - /* Array function return value. We call the function and save
> its
> - result in a temporary for use inside the loop. */
> - gfc_init_se (&se, NULL);
> - se.loop = loop;
> - se.ss = ss;
> - if (gfc_is_class_array_function (expr))
> - expr->must_finalize = 1;
> - gfc_conv_expr (&se, expr);
> - gfc_add_block_to_block (&outer_loop->pre, &se.pre);
> - gfc_add_block_to_block (&outer_loop->post, &se.post);
> - gfc_add_block_to_block (&outer_loop->post, &se.finalblock);
> - ss_info->string_length = se.string_length;
> + {
> + /* Array function return value. We call the function and save
> its
> + result in a temporary for use inside the loop. */
> + gfc_init_se (&se, NULL);
> + se.loop = loop;
> + se.ss = ss;
> + bool class_func = gfc_is_class_array_function (expr);
> + if (class_func)
> + expr->must_finalize = 1;
> + gfc_conv_expr (&se, expr);
> + gfc_add_block_to_block (&outer_loop->pre, &se.pre);
> + if (class_func
> + && se.expr
> + && GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)))
> + {
> + tree tmp = gfc_class_data_get (se.expr);
> + info->descriptor = tmp;
> + info->data = gfc_conv_descriptor_data_get (tmp);
> + info->offset = gfc_conv_descriptor_offset_get (tmp);
> + for (gfc_ss *s = ss; s; s = s->parent)
> + for (int n = 0; n < s->dimen; n++)
> + {
> + int dim = s->dim[n];
> + tree tree_dim = gfc_rank_cst[dim];
> +
> + tree start = gfc_conv_descriptor_lbound_get (tmp,
> tree_dim);
> + start = gfc_evaluate_now (start, &outer_loop->pre);
> + info->start[dim] = start;
> +
> + tree end = gfc_conv_descriptor_ubound_get (tmp,
> tree_dim);
> + end = gfc_evaluate_now (end, &outer_loop->pre);
> + info->end[dim] = end;
> +
> + tree stride = gfc_conv_descriptor_stride_get (tmp,
> tree_dim);
> + stride = gfc_evaluate_now (stride, &outer_loop->pre);
> + info->stride[dim] = stride;
> + }
> + }
> + gfc_add_block_to_block (&outer_loop->post, &se.post);
> + gfc_add_block_to_block (&outer_loop->post, &se.finalblock);
> + ss_info->string_length = se.string_length;
> + }
> break;
>
> case GFC_SS_CONSTRUCTOR:
> @@ -5383,7 +5407,8 @@ done:
> int dim = ss->dim[n];
>
> info->start[dim] = gfc_index_zero_node;
> - info->end[dim] = gfc_index_zero_node;
> + if (ss_info->type != GFC_SS_FUNCTION)
> + info->end[dim] = gfc_index_zero_node;
> info->stride[dim] = gfc_index_one_node;
> }
> break;
> @@ -6068,6 +6093,46 @@ set_loop_bounds (gfc_loopinfo *loop)
> }
>
>
> +/* Last attempt to set the loop bounds, in case they depend on an
> allocatable
> + function result. */
> +
> +static void
> +late_set_loop_bounds (gfc_loopinfo *loop)
> +{
> + int n, dim;
> + gfc_array_info *info;
> + gfc_ss **loopspec;
> +
> + loopspec = loop->specloop;
> +
> + for (n = 0; n < loop->dimen; n++)
> + {
> + /* Set the extents of this range. */
> + if (loop->from[n] == NULL_TREE
> + || loop->to[n] == NULL_TREE)
> + {
> + /* We should have found the scalarization loop specifier. If
> not,
> + that's bad news. */
> + gcc_assert (loopspec[n]);
> +
> + info = &loopspec[n]->info->data.array;
> + dim = loopspec[n]->dim[n];
> +
> + if (loopspec[n]->info->type == GFC_SS_FUNCTION
> + && info->start[dim]
> + && info->end[dim])
> + {
> + loop->from[n] = info->start[dim];
> + loop->to[n] = info->end[dim];
> + }
> + }
> + }
> +
> + for (loop = loop->nested; loop; loop = loop->next)
> + late_set_loop_bounds (loop);
> +}
> +
> +
> /* Initialize the scalarization loop. Creates the loop variables.
> Determines
> the range of the loop variables. Creates a temporary if required.
> Also generates code for scalar expressions which have been
> @@ -6086,6 +6151,8 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus *
> where)
> allocating the temporary. */
> gfc_add_loop_ss_code (loop, loop->ss, false, where);
>
> + late_set_loop_bounds (loop);
> +
> tmp_ss = loop->temp_ss;
> /* If we want a temporary then create it. */
> if (tmp_ss != NULL)
> @@ -6142,9 +6209,11 @@ gfc_set_delta (gfc_loopinfo *loop)
> gfc_ss_type ss_type;
>
> ss_type = ss->info->type;
> - if (ss_type != GFC_SS_SECTION
> - && ss_type != GFC_SS_COMPONENT
> - && ss_type != GFC_SS_CONSTRUCTOR)
> + if (!(ss_type == GFC_SS_SECTION
> + || ss_type == GFC_SS_COMPONENT
> + || ss_type == GFC_SS_CONSTRUCTOR
> + || (ss_type == GFC_SS_FUNCTION
> + && gfc_is_class_array_function (ss->info->expr))))
> continue;
>
> info = &ss->info->data.array;
> diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
> index 0db7ba3fd52..bfc38add72d 100644
> --- a/gcc/fortran/trans-expr.cc
> +++ b/gcc/fortran/trans-expr.cc
> @@ -5485,16 +5485,6 @@ gfc_conv_subref_array_arg (gfc_se *se, gfc_expr *
> expr, int g77,
> /* Translate the expression. */
> gfc_conv_expr (&rse, expr);
>
> - /* Reset the offset for the function call since the loop
> - is zero based on the data pointer. Note that the temp
> - comes first in the loop chain since it is added second. */
> - if (gfc_is_class_array_function (expr))
> - {
> - tmp = loop.ss->loop_chain->info->data.array.descriptor;
> - gfc_conv_descriptor_offset_set (&loop.pre, tmp,
> - gfc_index_zero_node);
> - }
> -
> gfc_conv_tmp_array_ref (&lse);
>
> if (intent != INTENT_OUT)
> @@ -8864,28 +8854,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol *
> sym,
> && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
> && expr->must_finalize)
> {
> - int n;
> - if (se->ss && se->ss->loop)
> - {
> - gfc_add_block_to_block (&se->ss->loop->pre, &se->pre);
> - se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre);
> - tmp = gfc_class_data_get (se->expr);
> - info->descriptor = tmp;
> - info->data = gfc_conv_descriptor_data_get (tmp);
> - info->offset = gfc_conv_descriptor_offset_get (tmp);
> - for (n = 0; n < se->ss->loop->dimen; n++)
> - {
> - tree dim = gfc_rank_cst[n];
> - se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get
> (tmp, dim);
> - se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get
> (tmp, dim);
> - }
> - }
> - else
> - {
> - /* TODO Eliminate the doubling of temporaries. This
> - one is necessary to ensure no memory leakage. */
> - se->expr = gfc_evaluate_now (se->expr, &se->pre);
> - }
> + /* TODO Eliminate the doubling of temporaries. This
> + one is necessary to ensure no memory leakage. */
> + se->expr = gfc_evaluate_now (se->expr, &se->pre);
>
> /* Finalize the result, if necessary. */
> attr = expr->value.function.esym
> diff --git a/gcc/testsuite/gfortran.dg/class_elemental_1.f90
> b/gcc/testsuite/gfortran.dg/class_elemental_1.f90
> new file mode 100644
> index 00000000000..43ebd041917
> --- /dev/null
> +++ b/gcc/testsuite/gfortran.dg/class_elemental_1.f90
> @@ -0,0 +1,34 @@
> +! { dg-do run }
> +!
> +! The polymorphic function result as actual argument used to force the
> loop
> +! bounds around the elemental call, altering access to the other arrays.
> +
> +program p
> + implicit none
> + type :: t
> + integer :: i
> + end type
> + type :: u
> + integer :: i, a
> + end type
> + type(u) :: accum(5)
> + integer :: a(3:7), k
> + a = [ (k*k, k=1,5) ]
> + call s(accum, f(), a)
> + ! print *, accum%i
> + ! print *, accum%a
> + if (any(accum%i /= accum%a)) error stop 1
> +contains
> + elemental subroutine s(l, c, a)
> + type(u) , intent(out) :: l
> + class(t) , intent(in) :: c
> + integer , intent(in) :: a
> + l%i = c%i
> + l%a = a
> + end subroutine
> + function f()
> + class(t), allocatable :: f(:)
> + allocate(f(-1:3))
> + f%i = [ (k*k, k=1,5) ]
> + end function
> +end program
> --
> 2.47.2
>
>
