https://gcc.gnu.org/g:ad4a4ac92b9e9e76af970ed32f0cba91cc25f225
commit ad4a4ac92b9e9e76af970ed32f0cba91cc25f225
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Fri Jul 25 11:54:03 2025 +0200
fortran: Bound class container lookup after array descriptor [PR121185]
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.
Diff:
---
gcc/fortran/trans-expr.cc | 21 +++++++++++++++++++++
gcc/testsuite/gfortran.dg/assign_13.f90 | 25 +++++++++++++++++++++++++
2 files changed, 46 insertions(+)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 7c7621571ad0..f2b88c64d5d1 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
+ descriptor. 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 000000000000..262ade0997aa
--- /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
