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
	container lookup on the second COMPONENT_REF after an array
	descriptor.

gcc/testsuite/ChangeLog:

	* gfortran.dg/assign_13.f90: New test.

2 files changed, 46 insertions, 0 deletions

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 7c76215..6cb2b67 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 0000000..262ade0
--- /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