Hi Mikael,
This looks fine to me. OK for mainline.
Thanks for the fix.
Paul
On Sat, 26 Jul 2025 at 20:31, Mikael Morin <morin-mik...@orange.fr> wrote:
> From: Mikael Morin <mik...@gcc.gnu.org>
>
> Regression-tested on x86_64-pc-linux-gnu.
> OK for master?
>
> -- >8 --
>
> Don't look for a class container too far after an array descriptor.
> This avoids generating a polymorphic array reference, using the virtual
> table of a parent object, to access a non-polymorphic child having a
> type unrelated to that of the parent.
>
> PR fortran/121185
>
> gcc/fortran/ChangeLog:
>
> * trans-expr.cc (gfc_get_class_from_expr): Give up class
> descriptor lookup on the second COMPONENT_REF after an array
> descriptor.
>
> gcc/testsuite/ChangeLog:
>
> * gfortran.dg/assign_13.f90: New test.
> ---
> gcc/fortran/trans-expr.cc | 21 +++++++++++++++++++++
> gcc/testsuite/gfortran.dg/assign_13.f90 | 25 +++++++++++++++++++++++++
> 2 files changed, 46 insertions(+)
> create mode 100644 gcc/testsuite/gfortran.dg/assign_13.f90
>
> diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
> index 7c7621571ad..6cb2b677937 100644
> --- a/gcc/fortran/trans-expr.cc
> +++ b/gcc/fortran/trans-expr.cc
> @@ -714,6 +714,8 @@ gfc_get_class_from_expr (tree expr)
> {
> tree tmp;
> tree type;
> + bool array_descr_found = false;
> + bool comp_after_descr_found = false;
>
> for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
> {
> @@ -725,6 +727,8 @@ gfc_get_class_from_expr (tree expr)
> {
> if (GFC_CLASS_TYPE_P (type))
> return tmp;
> + if (GFC_DESCRIPTOR_TYPE_P (type))
> + array_descr_found = true;
> if (type != TYPE_CANONICAL (type))
> type = TYPE_CANONICAL (type);
> else
> @@ -732,6 +736,23 @@ gfc_get_class_from_expr (tree expr)
> }
> if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL)
> break;
> +
> + /* Avoid walking up the reference chain too far. For class arrays,
> the
> + array descriptor is a direct component (through a pointer) of the
> class
> + container. So there is exactly one COMPONENT_REF between a class
> + container and its child array descriptor. After seeing an array
> + descriptor, we can give up on the second COMPONENT_REF we see, if
> no
> + class container was found until that point. */
> + if (array_descr_found)
> + {
> + if (comp_after_descr_found)
> + {
> + if (TREE_CODE (tmp) == COMPONENT_REF)
> + return NULL_TREE;
> + }
> + else if (TREE_CODE (tmp) == COMPONENT_REF)
> + comp_after_descr_found = true;
> + }
> }
>
> if (POINTER_TYPE_P (TREE_TYPE (tmp)))
> diff --git a/gcc/testsuite/gfortran.dg/assign_13.f90
> b/gcc/testsuite/gfortran.dg/assign_13.f90
> new file mode 100644
> index 00000000000..262ade0997a
> --- /dev/null
> +++ b/gcc/testsuite/gfortran.dg/assign_13.f90
> @@ -0,0 +1,25 @@
> +! { dg-do run }
> +!
> +! PR fortran/121185
> +! The assignment to Y%X in CHECK_T was using a polymorphic array access
> on the
> +! left hand side, using the virtual table of Y.
> +
> +program p
> + implicit none
> + type t
> + complex, allocatable :: x(:)
> + end type t
> + real :: trace = 2.
> + type(t) :: z
> + z%x = [1,2] * trace
> + call check_t (z)
> +contains
> + subroutine check_t (y)
> + class(t) :: y
> + ! print *, y% x
> + if (any(y%x /= [2., 4.])) error stop 11
> + y%x = y%x / trace
> + ! print *, y% x
> + if (any(y%x /= [1., 2.])) error stop 12
> + end subroutine
> +end
> --
> 2.47.2
>
>
