[PATCH] fortran: [PR53800] Wrong copy-in/out with CLASS array to assumed-shape TYPE

commit c31a44e4e831b16f5b509f28d79814c82ce8991b
Author: Jerry DeLisle <[email protected]>
Date:   Sat Jul 25 09:37:18 2026 -0700

    fortran: [PR53800] Wrong copy-in/out with CLASS array to assumed-shape TYPE
    
    A CLASS array actual passed to a plain assumed-shape derived-type dummy
    was always copied in and out, so pointers associated with the dummy went
    stale on return.  F2023 15.5.2.5 paragraph 9 requires the dummy to be
    associated with the actual's storage when it has the TARGET attribute and
    lacks CONTIGUOUS and VALUE; paragraph 8 leaves every other case free to
    use a copy.  Pass such a dummy by reference and address its elements with
    the descriptor's runtime span.
    
            PR fortran/53800
    
    gcc/fortran/ChangeLog:
    
            * trans-array.cc (need_span): New function.
            (gfc_get_array_span): Read the span from the saved descriptor of a
            span-array dummy, but not for a sub-array reached through a
            component.
            (gfc_conv_scalarized_array_ref): Use need_span.
            (gfc_conv_array_ref): Likewise.
            (build_array_ref): Default DECL to DESC for a span-array decl.
            * trans-decl.cc (gfc_build_dummy_array_decl): Mark a TARGET
            assumed-shape derived-type dummy as needing runtime span
            addressing, unless it is repacked.
            * trans-expr.cc (class_actual_aliases_type_dummy): New function.
            (gfc_class_array_data_assign): Also copy the span field.
            (gfc_conv_procedure_call): Use class_actual_aliases_type_dummy to
            skip copy-in/copy-out for both the class array reference and the
            class array function actual argument.
            * trans.cc (get_array_span): Read the span from the dummy's saved
            descriptor for span-array decls.
            * trans.h (struct lang_decl): Add span_array bitfield.
            (GFC_DECL_SPAN_ARRAY_P): New macro.
            (GFC_DECL_GET_SPAN_ARRAY_P): New macro.
    
    gcc/testsuite/ChangeLog:
    
            * gfortran.dg/class_to_type_5.f90: New test.
            * gfortran.dg/class_to_type_6.f90: New test.

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index cf7eddf6e1d..0daa3f2ddad 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -490,6 +490,19 @@ is_pointer_array (tree expr)
 }
 
 
+/* Helper functon to identify when span is needed.  */
+
+static bool
+need_span (tree expr)
+{
+  if (expr == NULL_TREE || !VAR_P (expr))
+    return false;
+
+  return GFC_ARRAY_TYPE_P (TREE_TYPE (expr))
+	 && GFC_DECL_GET_SPAN_ARRAY_P (expr);
+}
+
+
 /* If the symbol or expression reference a CFI descriptor, return the
    pointer to the converted gfc descriptor. If an array reference is
    present as the last argument, check that it is the one applied to
@@ -588,6 +601,29 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
     /* Having escaped the above, this can only be a class array dummy.  */
     tmp = class_array_element_size (sym->backend_decl,
 				    UNLIMITED_POLY (sym));
+  else if (sym && sym->backend_decl
+	   && GFC_DECL_GET_SPAN_ARRAY_P (sym->backend_decl)
+	   && (expr->ref == NULL
+	       || (expr->ref->type == REF_ARRAY && expr->ref->next == NULL)))
+    {
+      /* A assumed-shape derived-type dummy re-passed to another
+	 procedure; read its runtime span from the saved descriptor rather
+	 than using the compile-time element size.  The span applies to the
+	 dummy itself, not to a sub-array reached through a component.  */
+      tree saved_desc = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
+      if (POINTER_TYPE_P (TREE_TYPE (saved_desc)))
+	saved_desc = build_fold_indirect_ref_loc (input_location, saved_desc);
+      tmp = gfc_conv_descriptor_span_get (saved_desc);
+
+      /* An absent optional dummy has no valid saved descriptor to read;
+	 avoid dereferencing it and fall back to the static element size. */
+      if (sym->attr.dummy && sym->attr.optional)
+	tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+			   gfc_conv_expr_present (sym), tmp,
+			   fold_convert (TREE_TYPE (tmp),
+					 TYPE_SIZE_UNIT (
+					   gfc_get_element_type (TREE_TYPE (desc)))));
+    }
   else
     {
       /* If none of the fancy stuff works, the span is the element
@@ -3980,6 +4016,7 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar,
      the descriptor, mark the resulting variable decl and pass it to
      gfc_build_array_ref.  */
   if (is_pointer_array (info->descriptor)
+      || need_span (info->descriptor)
       || (expr && expr->ts.deferred && info->descriptor
 	  && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor))))
     {
@@ -4066,6 +4103,13 @@ build_array_ref (tree desc, tree offset, tree decl, tree vptr)
 	}
     }
 
+  /* Fall back to DESC itself so get_array_span can recognize a
+     span_array-marked dummy re-passed as a section actual argument.  */
+  if (decl == NULL_TREE
+      && (VAR_P (desc) || TREE_CODE (desc) == PARM_DECL)
+      && GFC_DECL_GET_SPAN_ARRAY_P (desc))
+    decl = desc;
+
   tmp = gfc_conv_array_data (desc);
   tmp = build_fold_indirect_ref_loc (input_location, tmp);
   tmp = gfc_build_array_ref (tmp, offset, decl,
@@ -4232,7 +4276,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
   if (get_CFI_desc (sym, expr, &decl, ar))
     decl = build_fold_indirect_ref_loc (input_location, decl);
   if (!expr->ts.deferred && !sym->attr.codimension
-      && is_pointer_array (se->expr))
+      && (is_pointer_array (se->expr) || need_span (se->expr)))
     {
       if (TREE_CODE (se->expr) == COMPONENT_REF)
 	decl = se->expr;
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 1632556ae40..68e06a03cce 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -1408,6 +1408,15 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
 
   GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
 
+  /* Mark dummies that may alias a CLASS actual's storage and so address
+     elements by the descriptor's runtime span.  A repacked dummy is a
+     contiguous local copy, so it is excluded.  */
+  if (sym->ts.type == BT_DERIVED && !is_classarray
+      && sym->attr.target && !sym->attr.pointer && !sym->attr.value
+      && !sym->attr.contiguous && as->type == AS_ASSUMED_SHAPE
+      && packed == PACKED_NO)
+    GFC_DECL_SPAN_ARRAY_P (decl) = 1;
+
   if (sym->ns->proc_name->backend_decl == current_function_decl
       || sym->attr.contained)
     gfc_add_decl_to_function (decl);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 585d27fa5a2..c9e1f66edb1 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -837,6 +837,8 @@ gfc_class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
 
   gfc_conv_descriptor_dtype_set (block, lhs_desc,
 				 gfc_conv_descriptor_dtype_get (rhs_desc));
+  gfc_conv_descriptor_span_set (block, lhs_desc,
+				gfc_conv_descriptor_span_get (rhs_desc));
 
   /* Assign the dimension as range-ref.  */
   lhs_dim = gfc_get_descriptor_dimension (lhs_desc);
@@ -7222,6 +7224,26 @@ conv_null_actual (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym)
 }
 
 
+/* Return true if a CLASS array actual may alias the derived-type dummy
+   FSYM rather than be passed through a copy-in/copy-out temporary.  F2023
+   15.5.2.5 paragraph 9 requires the association only for a TARGET
+   assumed-shape dummy without CONTIGUOUS or VALUE.  */
+
+static bool
+class_actual_aliases_type_dummy (gfc_symbol *fsym, bool nodesc_arg)
+{
+  return fsym != NULL
+	 && fsym->ts.type == BT_DERIVED
+	 && fsym->attr.target
+	 && !fsym->attr.pointer
+	 && !fsym->attr.value
+	 && !fsym->attr.contiguous
+	 && !nodesc_arg
+	 && fsym->as != NULL
+	 && fsym->as->type == AS_ASSUMED_SHAPE;
+}
+
+
 /* Generate code for a procedure call.  Note can return se->post != NULL.
    If se->direct_byref is set then se->expr contains the return parameter.
    Return nonzero, if the call has alternate specifiers.
@@ -8301,20 +8323,19 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		parmse.expr = e->symtree->n.sym->backend_decl;
 
 	      else if (gfc_is_class_array_ref (e, NULL)
-		       && fsym && fsym->ts.type == BT_DERIVED)
+		       && fsym && fsym->ts.type == BT_DERIVED
+		       && !class_actual_aliases_type_dummy (fsym, nodesc_arg))
 		/* The actual argument is a component reference to an
 		   array of derived types.  In this case, the argument
 		   is converted to a temporary, which is passed and then
-		   written back after the procedure call.
-		   OOP-TODO: Insert code so that if the dynamic type is
-		   the same as the declared type, copy-in/copy-out does
-		   not occur.  */
+		   written back after the procedure call.  */
 		gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
 					   fsym->attr.intent,
 					   fsym->attr.pointer);
 
 	      else if (gfc_is_class_array_function (e)
-		       && fsym && fsym->ts.type == BT_DERIVED)
+		       && fsym && fsym->ts.type == BT_DERIVED
+		       && !class_actual_aliases_type_dummy (fsym, nodesc_arg))
 		/* See previous comment.  For function actual argument,
 		   the write out is not needed so the intent is set as
 		   intent in.  */
diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc
index cf37261673c..fd3df702dbb 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -454,6 +454,17 @@ get_array_span (tree type, tree decl)
 	    decl = build_fold_indirect_ref_loc (input_location, decl);
 	  span = gfc_conv_descriptor_span_get (decl);
 	}
+      else if (GFC_DECL_GET_SPAN_ARRAY_P (decl))
+	{
+	  /* The descriptor for the dummy is stored in the saved
+	     descriptor of its nodesc array decl.  */
+	  tree saved_desc = decl;
+	  if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
+	    saved_desc = GFC_DECL_SAVED_DESCRIPTOR (decl);
+	  if (POINTER_TYPE_P (TREE_TYPE (saved_desc)))
+	    saved_desc = build_fold_indirect_ref_loc (input_location, saved_desc);
+	  span = gfc_conv_descriptor_span_get (saved_desc);
+	}
       else
 	span = NULL_TREE;
     }
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 7b28ecfce47..4063bbe70c4 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -1070,6 +1070,7 @@ struct GTY(()) lang_decl {
   unsigned int scalar_pointer : 1;
   unsigned int scalar_target : 1;
   unsigned int optional_arg : 1;
+  unsigned int span_array : 1;
 };
 
 
@@ -1087,12 +1088,16 @@ struct GTY(()) lang_decl {
   (DECL_LANG_SPECIFIC (node)->scalar_target)
 #define GFC_DECL_OPTIONAL_ARGUMENT(node) \
   (DECL_LANG_SPECIFIC (node)->optional_arg)
+#define GFC_DECL_SPAN_ARRAY_P(node) \
+  (DECL_LANG_SPECIFIC (node)->span_array)
 #define GFC_DECL_GET_SCALAR_ALLOCATABLE(node) \
   (DECL_LANG_SPECIFIC (node) ? GFC_DECL_SCALAR_ALLOCATABLE (node) : 0)
 #define GFC_DECL_GET_SCALAR_POINTER(node) \
   (DECL_LANG_SPECIFIC (node) ? GFC_DECL_SCALAR_POINTER (node) : 0)
 #define GFC_DECL_GET_SCALAR_TARGET(node) \
   (DECL_LANG_SPECIFIC (node) ? GFC_DECL_SCALAR_TARGET (node) : 0)
+#define GFC_DECL_GET_SPAN_ARRAY_P(node) \
+  (DECL_LANG_SPECIFIC (node) ? GFC_DECL_SPAN_ARRAY_P (node) : 0)
 #define GFC_DECL_PACKED_ARRAY(node) DECL_LANG_FLAG_0(node)
 #define GFC_DECL_PARTIAL_PACKED_ARRAY(node) DECL_LANG_FLAG_1(node)
 #define GFC_DECL_ASSIGN(node) DECL_LANG_FLAG_2(node)
diff --git a/gcc/testsuite/gfortran.dg/class_to_type_5.f90 b/gcc/testsuite/gfortran.dg/class_to_type_5.f90
new file mode 100644
index 00000000000..ad299db514d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_to_type_5.f90
@@ -0,0 +1,35 @@
+! { dg-do run }
+! PR 53800
+
+! Check that a CLASS array with an extended dynamic type passed to an
+! assumed-shape TYPE dummy aliases the original storage, rather
+! than a copy-in/copy-out temporary that goes stale after return.
+!
+! Reported by Tobias Burnus  <[email protected]>
+
+program class_to_type
+  implicit none
+  type t
+    integer :: i
+  end type t
+  type, extends(t) :: t2
+    integer :: j
+  end type t2
+  class(t), target, allocatable :: a(:,:)
+  type(t), pointer :: ptr
+
+  allocate (t2 :: a(5,5))
+  a(:,:)%i = 53
+  a(3,3)%i = 42
+  a(4,4)%i = 74
+
+  call f (a)
+  if (ptr%i /= 42) stop 1
+  a(3,3)%i = 999
+  if (ptr%i /= 999) stop 2
+contains
+  subroutine f(x)
+    type(t), target :: x(:,:)
+    ptr => x(3,3)
+  end subroutine f
+end program class_to_type
diff --git a/gcc/testsuite/gfortran.dg/class_to_type_6.f90 b/gcc/testsuite/gfortran.dg/class_to_type_6.f90
new file mode 100644
index 00000000000..67d02c67fb8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_to_type_6.f90
@@ -0,0 +1,93 @@
+! { dg-do run }
+! PR53800
+
+! A CLASS array actual passed to an assumed-shape TYPE dummy only
+! aliases the actual's storage when the dummy has the TARGET attribute.
+!
+module m
+  implicit none
+  type :: t
+    integer :: i
+  end type
+  type, extends(t) :: t2
+    integer :: pad(4)
+  end type
+  type :: u
+    integer :: k
+  end type
+  type :: c
+    integer  :: i
+    type(u)  :: sub(3)
+  end type
+  type, extends(c) :: c2
+    integer :: pad(4)
+  end type
+contains
+  ! A dummy (non-target): copy-in/copy-out,
+  subroutine plain (x)
+    type(t) :: x(:)
+    if (any (x%i /= [1,2,3,4,5])) stop 1
+    call expl (x)
+    if (any (cshift (x%i, 1) /= [2,3,4,5,1])) stop 3
+    if (any (pack (x%i, [.true.,.false.,.true.,.false.,.true.]) &
+             /= [1,3,5])) stop 4
+    if (any (reshape (x%i, [1,5]) /= reshape ([1,2,3,4,5], [1,5]))) stop 5
+    call to_class (x)
+  end subroutine
+
+  subroutine expl (y)
+    type(t) :: y(5)
+    if (any (y%i /= [1,2,3,4,5])) stop 2
+  end subroutine
+
+  subroutine to_class (z)
+    class(t) :: z(:)
+    if (any (z%i /= [1,2,3,4,5])) stop 6
+  end subroutine
+
+  ! A component sub-array of a span-carrying dummy has its own element
+  ! size and must not inherit the parent's span.
+  subroutine comp (x)
+    type(c), target :: x(:)
+    call inner (x(2)%sub)
+  end subroutine
+
+  subroutine inner (s)
+    type(u) :: s(:)
+    if (any (s%k /= [21,22,23])) stop 7
+  end subroutine
+end module
+
+program class_to_type_6
+  use m
+  implicit none
+  class(t), target, allocatable :: a(:)
+  class(c), target, allocatable :: b(:)
+  type(t), pointer :: p
+  integer :: n
+
+  allocate (t2 :: a(5))
+  do n = 1, 5
+    a(n)%i = n
+  end do
+  call plain (a)
+
+  allocate (c2 :: b(3))
+  do n = 1, 3
+    b(n)%i = 10 * n
+    b(n)%sub(:)%k = [10*n+1, 10*n+2, 10*n+3]
+  end do
+  call comp (b)
+
+  ! A TARGET assumed-shape dummy without CONTIGUOUS does alias.
+  call aliased (a)
+  if (p%i /= 3) stop 8
+  a(3)%i = 999
+  if (p%i /= 999) stop 9
+
+contains
+  subroutine aliased (x)
+    type(t), target :: x(:)
+    p => x(3)
+  end subroutine
+end program