https://gcc.gnu.org/g:7a163edf7795c80e9a983f45cdd888b79a470b5f
commit 7a163edf7795c80e9a983f45cdd888b79a470b5f
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Thu Jul 24 22:20:56 2025 +0200
fortran: Bound class container lookup after array descriptor
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.
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.
Diff:
---
gcc/fortran/trans-expr.cc | 21 +++++++++++++++++++++
1 file changed, 21 insertions(+)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 7c7621571ad0..5280bdefbae6 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 descriptor 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)))
