Re: [PATCH] fortran: [PR53800] Wrong copy-in/out with array actual to, TARGET dummy

From 05f091d95a29d9d467b9a1210292c9d50fda0867 Mon Sep 17 00:00:00 2001
From: Jerry DeLisle <[email protected]>
Date: Sat, 8 Aug 2026 10:47:12 -0700
Subject: [PATCH] fortran: [PR53800] Wrong copy-in/out with array actual to
 TARGET dummy

An actual argument whose elements are spaced by more than the element
size - a CLASS array, or a component of a derived-type array - was
copied in and out when passed to a TARGET or POINTER dummy, so pointers
associated with the dummy went stale on return.

	PR fortran/53800

gcc/fortran/ChangeLog:

	* trans.h (gfc_get_span_descriptor): New prototype.
	* trans.cc (gfc_get_span_descriptor): New function returning the
	descriptor that carries a pointer array decl's span.
	(get_array_span): Use it, including for character types.
	* trans-array.cc (is_pointer_array): Note in the comment that the
	tree must be a descriptor.
	(saved_desc_pointer_array): New function returning the saved
	descriptor that holds a descriptorless pointer array's span.
	(gfc_get_array_span): Read the span from the descriptor of a
	descriptorless dummy, but not for a sub-array reached through a
	component.
	(build_array_ref): Default DECL to DESC for such a dummy.
	(gfc_get_dataptr_offset): Dereference a spanned character element.
	* trans-decl.cc (gfc_build_dummy_array_decl): Mark a TARGET
	assumed-shape dummy as a pointer array, unless it is repacked.
	(gfc_get_symbol_decl): Likewise for a TARGET assumed-rank dummy and
	for a SELECT RANK temporary whose selector is span addressed.
	* trans-expr.cc (copy_in_out_allowed): New function.
	(gfc_class_array_data_assign): Also copy the span field.
	(gfc_conv_procedure_call): Use copy_in_out_allowed to skip
	copy-in/copy-out for a class array reference, a class array function
	result and a subref array.

gcc/testsuite/ChangeLog:

	* gfortran.dg/c_loc_test_22.f90: Update dump patterns for span
	addressing.
	* gfortran.dg/class_to_type_5.f90: New test.
	* gfortran.dg/class_to_type_6.f90: New test.
	* gfortran.dg/class_to_type_7.f90: New test.
---
 gcc/fortran/trans-array.cc                    |  55 ++++++-
 gcc/fortran/trans-decl.cc                     |  24 ++-
 gcc/fortran/trans-expr.cc                     |  36 ++++-
 gcc/fortran/trans.cc                          |  30 +++-
 gcc/fortran/trans.h                           |   3 +
 gcc/testsuite/gfortran.dg/c_loc_test_22.f90   |   6 +-
 gcc/testsuite/gfortran.dg/class_to_type_5.f90 |  35 ++++
 gcc/testsuite/gfortran.dg/class_to_type_6.f90 |  93 +++++++++++
 gcc/testsuite/gfortran.dg/class_to_type_7.f90 | 151 ++++++++++++++++++
 9 files changed, 411 insertions(+), 22 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/class_to_type_5.f90
 create mode 100644 gcc/testsuite/gfortran.dg/class_to_type_6.f90
 create mode 100644 gcc/testsuite/gfortran.dg/class_to_type_7.f90

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 7d23515e5d8..0146cbd318a 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -458,7 +458,8 @@ gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
 }
 
 
-/* Returns true if the expression is an array pointer.  */
+/* Returns true if the expression is an array pointer.  The tree must be a
+   descriptor.  */
 
 static bool
 is_pointer_array (tree expr)
@@ -480,7 +481,7 @@ is_pointer_array (tree expr)
       && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 0)))
     return true;
 
-  /* The field declaration is marked as an pointer array.  */
+  /* The field declaration is marked as a pointer array.  */
   if (TREE_CODE (expr) == COMPONENT_REF
       && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1))
       && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 1))))
@@ -490,6 +491,23 @@ is_pointer_array (tree expr)
 }
 
 
+/* If EXPR is a decl flagged as a pointer array but has no descriptor of its
+   own, return the saved descriptor that holds its span,
+   otherwise NULL_TREE.  */
+
+static tree
+saved_desc_pointer_array (tree expr)
+{
+  if (VAR_P (expr)
+      && GFC_DECL_PTR_ARRAY_P (expr)
+      && GFC_ARRAY_TYPE_P (TREE_TYPE (expr))
+      && DECL_LANG_SPECIFIC (expr))
+    return GFC_DECL_SAVED_DESCRIPTOR (expr);
+
+  return NULL_TREE;
+}
+
+
 /* 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
@@ -553,6 +571,8 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
   tree tmp;
   gfc_symbol *sym = (expr && expr->expr_type == EXPR_VARIABLE) ?
 		    expr->symtree->n.sym : NULL;
+  tree span_desc = (sym && sym->backend_decl)
+		   ? saved_desc_pointer_array (sym->backend_decl) : NULL_TREE;
 
   if (is_pointer_array (desc)
       || (get_CFI_desc (NULL, expr, &desc, NULL)
@@ -560,11 +580,8 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
 	      ? GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (desc)))
 	      : GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))))
     {
-      if (POINTER_TYPE_P (TREE_TYPE (desc)))
-	desc = build_fold_indirect_ref_loc (input_location, desc);
-
       /* This will have the span field set.  */
-      tmp = gfc_conv_descriptor_span_get (desc);
+      tmp = gfc_conv_descriptor_span_get (gfc_get_span_descriptor (desc));
     }
   else if (expr->ts.type == BT_ASSUMED)
     {
@@ -588,6 +605,25 @@ 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 (span_desc
+	   && (expr->ref == NULL
+	       || (expr->ref->type == REF_ARRAY && expr->ref->next == NULL)))
+    {
+      /* A descriptorless dummy re-passed to another procedure. Read its
+	 span from the saved descriptor.  */
+      if (POINTER_TYPE_P (TREE_TYPE (span_desc)))
+	span_desc = build_fold_indirect_ref_loc (input_location, span_desc);
+      tmp = gfc_conv_descriptor_span_get (span_desc);
+
+      /* An absent optional dummy has no valid saved descriptor to read;
+	 avoid trying to use 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
@@ -4051,6 +4087,9 @@ build_array_ref (tree desc, tree offset, tree decl, tree vptr)
 	}
     }
 
+  if (decl == NULL_TREE && saved_desc_pointer_array (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,
@@ -7591,6 +7630,10 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
 
   tmp = build_array_ref (desc, offset, NULL, NULL);
 
+  /* If there is a saved descriptor, use it.  */
+  if (POINTER_TYPE_P (TREE_TYPE (tmp)) && saved_desc_pointer_array (desc))
+    tmp = build_fold_indirect_ref_loc (input_location, tmp);
+
   /* Offset the data pointer for pointer assignments from arrays with
      subreferences; e.g. my_integer => my_type(:)%integer_component.  */
   if (subref)
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 47b28c1d003..621899b3dbe 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -1408,6 +1408,11 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
 
   GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
 
+  if (!is_classarray && sym->attr.target && !sym->attr.value
+      && !sym->attr.contiguous && as->type == AS_ASSUMED_SHAPE
+      && packed == PACKED_NO)
+    GFC_DECL_PTR_ARRAY_P (decl) = 1;
+
   if (sym->ns->proc_name->backend_decl == current_function_decl
       || sym->attr.contained)
     gfc_add_decl_to_function (decl);
@@ -1786,7 +1791,10 @@ gfc_get_symbol_decl (gfc_symbol * sym)
 	  && sym->attr.allocatable)
 	gfc_defer_symbol_init (sym);
 
-      if (sym->attr.pointer && sym->attr.dimension && sym->ts.type != BT_CLASS)
+      if (sym->attr.dimension && sym->ts.type != BT_CLASS
+	  && (sym->attr.pointer
+	      || (sym->attr.target && !sym->attr.contiguous
+		  && sym->as && sym->as->type == AS_ASSUMED_RANK)))
 	GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1;
 
       /* Create a character length variable.  */
@@ -2078,6 +2086,20 @@ gfc_get_symbol_decl (gfc_symbol * sym)
 	   && !sym->attr.subref_array_pointer))
     GFC_DECL_PTR_ARRAY_P (decl) = 1;
 
+  /* A SELECT RANK temporary uses a copy of the selector's descriptor.
+     Its elements may be spaced by more than the element size,
+     so use copied span as well.  */
+  if (sym->attr.select_rank_temporary && sym->attr.dimension
+      && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
+      && sym->assoc && sym->assoc->target
+      && sym->assoc->target->expr_type == EXPR_VARIABLE)
+    {
+      gfc_symbol *sel = sym->assoc->target->symtree->n.sym;
+      if (!sel->attr.contiguous
+	  && (sel->attr.target || sel->attr.pointer || sel->ts.type == BT_CLASS))
+	GFC_DECL_PTR_ARRAY_P (decl) = 1;
+    }
+
   if (sym->ts.type == BT_CLASS)
     GFC_DECL_CLASS(decl) = 1;
 
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 33b7838f74a..ce04b4e1ccd 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);
@@ -6954,6 +6956,26 @@ conv_null_actual (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym)
 }
 
 
+/* Return true if the actual argument for the dummy FSYM may be passed as a
+   copy-in/copy-out temporary.  */
+
+static bool
+copy_in_out_allowed (gfc_symbol *fsym, bool nodesc_arg)
+{
+  if (fsym == NULL || nodesc_arg || fsym->as == NULL)
+    return true;
+
+  if ((!fsym->attr.target && !fsym->attr.pointer)
+      || fsym->attr.value
+      || fsym->attr.contiguous)
+    return true;
+
+  return fsym->as->type != AS_ASSUMED_SHAPE
+	 && fsym->as->type != AS_ASSUMED_RANK
+	 && !(fsym->attr.pointer && fsym->as->type == AS_DEFERRED);
+}
+
+
 /* 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.
@@ -7985,7 +8007,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
 	      else if (e->expr_type == EXPR_VARIABLE
 		    && is_subref_array (e)
-		    && !(fsym && fsym->attr.pointer))
+		    && !(fsym && fsym->attr.pointer)
+		    && copy_in_out_allowed (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
@@ -8004,20 +8027,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
+		       && copy_in_out_allowed (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
+		       && copy_in_out_allowed (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..f484303adb7 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -389,6 +389,26 @@ gfc_build_addr_expr (tree type, tree t)
 }
 
 
+/* Return the descriptor that carries the span of a decl marked as a pointer
+   array.  Most decls are descriptors.  A descriptorless dummy
+   array decl is not.  The descriptor it was built from is the saved one.  */
+
+tree
+gfc_get_span_descriptor (tree decl)
+{
+  if (DECL_P (decl)
+      && GFC_ARRAY_TYPE_P (TREE_TYPE (decl))
+      && DECL_LANG_SPECIFIC (decl)
+      && GFC_DECL_SAVED_DESCRIPTOR (decl))
+    decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
+
+  if (POINTER_TYPE_P (TREE_TYPE (decl)))
+    decl = build_fold_indirect_ref_loc (input_location, decl);
+
+  return decl;
+}
+
+
 static tree
 get_array_span (tree type, tree decl)
 {
@@ -409,7 +429,9 @@ get_array_span (tree type, tree decl)
       && (TREE_CODE (type) == ARRAY_TYPE || TREE_CODE (type) == INTEGER_TYPE)
       && TYPE_STRING_FLAG (type))
     {
-      if (TREE_CODE (decl) == PARM_DECL)
+      if (DECL_P (decl) && GFC_DECL_PTR_ARRAY_P (decl))
+	decl = gfc_get_span_descriptor (decl);
+      else if (TREE_CODE (decl) == PARM_DECL)
 	decl = build_fold_indirect_ref_loc (input_location, decl);
       if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
 	span = gfc_conv_descriptor_span_get (decl);
@@ -449,11 +471,7 @@ get_array_span (tree type, tree decl)
 	  span = gfc_resize_class_size_with_len (NULL, decl, span);
 	}
       else if (GFC_DECL_PTR_ARRAY_P (decl))
-	{
-	  if (TREE_CODE (decl) == PARM_DECL)
-	    decl = build_fold_indirect_ref_loc (input_location, decl);
-	  span = gfc_conv_descriptor_span_get (decl);
-	}
+	span = gfc_conv_descriptor_span_get (gfc_get_span_descriptor (decl));
       else
 	span = NULL_TREE;
     }
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 0bdee5820fd..408acf081f1 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -641,6 +641,9 @@ tree gfc_build_array_ref (tree, tree, tree,
 /* Build an array ref using pointer arithmetic.  */
 tree gfc_build_spanned_array_ref (tree base, tree offset, tree span);
 
+/* Return the descriptor holding the span of a pointer array decl.  */
+tree gfc_get_span_descriptor (tree);
+
 /* Creates a label.  Decl is artificial if label_id == NULL_TREE.  */
 tree gfc_build_label_decl (tree);
 
diff --git a/gcc/testsuite/gfortran.dg/c_loc_test_22.f90 b/gcc/testsuite/gfortran.dg/c_loc_test_22.f90
index 7b1149aaa45..91547e8e337 100644
--- a/gcc/testsuite/gfortran.dg/c_loc_test_22.f90
+++ b/gcc/testsuite/gfortran.dg/c_loc_test_22.f90
@@ -17,7 +17,9 @@ end
 ! { dg-final { scan-tree-dump-not " _gfortran_internal_pack" "original" } }
 ! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) &\\(.xxx.\[0-9\]+\\)\\\[0\\\];" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) &\\(.xxx.\[0-9\]+\\)\\\[D.\[0-9\]+ \\* 4\\\];" 1 "original" } }
-! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) yyy.\[0-9\]+;" 1 "original" } }
-! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) yyy.\[0-9\]+ \\+ \\(sizetype\\) \\(D.\[0-9\]+ \\* 16\\);" 1 "original" } }
+! A TARGET assumed-shape dummy is addressed with the descriptor's runtime
+! span, so the element offset is span-scaled instead of a constant 16.
+! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) &\\(.yyy.\[0-9\]+\\)\\\[0\\\];" 1 "original" } }
+! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) yyy.\[0-9\]+ \\+ \\(sizetype\\) \\(\\(yyy->span \\* D.\[0-9\]+\\) \\* 4\\);" 1 "original" } }
 
 ! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = parm.\[0-9\]+.data;\[^;]+ptr\[1-4\] = D.\[0-9\]+;" 4 "original" } }
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
diff --git a/gcc/testsuite/gfortran.dg/class_to_type_7.f90 b/gcc/testsuite/gfortran.dg/class_to_type_7.f90
new file mode 100644
index 00000000000..c5f74809c46
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_to_type_7.f90
@@ -0,0 +1,151 @@
+! { dg-do run }
+! PR fortran/53800
+
+! Further cases in which a dummy must be associated with the actual
+! argument's storage rather than a copy-in/copy-out temporary: an
+! intrinsic-type component of a CLASS array, a POINTER dummy and an
+! assumed-rank TARGET dummy.
+!
+! Variations contributed by Mikael Morin  <[email protected]>
+
+module m
+  implicit none
+  type t
+    integer :: i
+  end type t
+  type, extends(t) :: t2
+    integer :: j
+  end type t2
+end module m
+
+! An intrinsic-type component of a CLASS array to an INTEGER TARGET dummy.
+subroutine test_integer_component ()
+  use m
+  implicit none
+  class(t), target, allocatable :: a(:,:)
+  integer, pointer :: ptr
+
+  allocate (t2 :: a(5,5))
+  a(:,:)%i = 53
+  a(3,3)%i = 42
+
+  call f (a%i)
+  if (ptr /= 42) stop 1
+  a(3,3)%i = 999
+  if (ptr /= 999) stop 2
+contains
+  subroutine f(x)
+    integer, target :: x(:,:)
+    ptr => x(3,3)
+  end subroutine f
+end subroutine test_integer_component
+
+! A component of a plain derived-type array to an INTEGER TARGET dummy.
+subroutine test_subref_component ()
+  implicit none
+  type u
+    integer :: i
+    integer :: pad
+  end type u
+  type(u), target :: a(5,5)
+  integer, pointer :: ptr
+
+  a(:,:)%i = 53
+  a(3,3)%i = 42
+
+  call f (a%i)
+  if (ptr /= 42) stop 3
+  a(3,3)%i = 999
+  if (ptr /= 999) stop 4
+contains
+  subroutine f(x)
+    integer, target :: x(:,:)
+    ptr => x(3,3)
+  end subroutine f
+end subroutine test_subref_component
+
+! A character component of a derived-type array to a CHARACTER TARGET dummy.
+subroutine test_character_component ()
+  implicit none
+  type u
+    character(len=4) :: c
+    integer :: pad
+  end type u
+  type(u), target :: a(6)
+  character(len=4), pointer :: ptr
+  integer :: k
+
+  do k = 1, 6
+    a(k)%c = "ab00"
+  end do
+  a(4)%c = "zzzz"
+
+  call f (a%c)
+  if (ptr /= "zzzz") stop 10
+  a(4)%c = "qqqq"
+  if (ptr /= "qqqq") stop 11
+contains
+  subroutine f(x)
+    character(len=4), target :: x(:)
+    ptr => x(4)
+  end subroutine f
+end subroutine test_character_component
+
+! A CLASS POINTER array to a TYPE POINTER dummy.
+subroutine test_pointer_dummy ()
+  use m
+  implicit none
+  class(t), pointer :: a(:,:)
+  type(t), pointer :: ptr
+
+  allocate (t2 :: a(5,5))
+  a(:,:)%i = 53
+  a(3,3)%i = 42
+
+  call f (a)
+  if (ptr%i /= 42) stop 5
+  a(3,3)%i = 999
+  if (ptr%i /= 999) stop 6
+  deallocate (a)
+contains
+  subroutine f(x)
+    type(t), pointer :: x(:,:)
+    ptr => x(3,3)
+  end subroutine f
+end subroutine test_pointer_dummy
+
+! A CLASS array to an assumed-rank TARGET dummy, selected with SELECT RANK.
+subroutine test_assumed_rank ()
+  use m
+  implicit none
+  class(t), target, allocatable :: a(:,:)
+  type(t), pointer :: ptr
+
+  allocate (t2 :: a(5,5))
+  a(:,:)%i = 53
+  a(3,3)%i = 42
+
+  call f (a)
+  if (ptr%i /= 42) stop 7
+  a(3,3)%i = 999
+  if (ptr%i /= 999) stop 8
+contains
+  subroutine f(x)
+    type(t), target :: x(..)
+    select rank (x)
+      rank (2)
+        ptr => x(3,3)
+      rank default
+        error stop 9
+    end select
+  end subroutine f
+end subroutine test_assumed_rank
+
+program class_to_type_7
+  implicit none
+  call test_integer_component ()
+  call test_subref_component ()
+  call test_character_component ()
+  call test_pointer_dummy ()
+  call test_assumed_rank ()
+end program class_to_type_7
-- 
2.55.0