[PATCH 1/3] fortran: Bound class container lookup after array descriptor [PR121185]

[Mikael Morin]

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