Revised patch attached. See below. OK for mainline?
On 8/10/26 8:20 AM, Jerry D wrote:
Excellent comments! That new test case passes on 16 so a regression hiding on
me.
I am working on this.
Jerry
On 8/10/26 7:32 AM, Mikael Morin wrote:
Le 08/08/2026 à 21:31, Jerry D a écrit :
See the attached patch. This is several iterations after Mikael's comments
which were very helpful. I took a different approach on the use of macros and
this addresses the non derived type examples Mikael provided in the previous
review.
I have added additional test cases.
Regression tested on x86_64.
OK for mainline?
There is one important thing that I missed in the first review, it's that
gfc_build_dummy_array_decl creates array declarations like:
integer(kind=4)[0:D.4797] * a.0;
i.e. a pointer to an array. For the target dummy arguments we are interested
in with this patch, this is lying to the middle-end, as those arguments can
only be used with span and pointer arithmetics. I think the decl should be
instead:
integer(kind=4) * a.0;
i.e. the array type should be unwrapped. But the easiest is probably to
return early in gfc_build_dummy_array_decl and drop the variable decl
completely. That's already what is done for pointers, classes, and a few
others. And then, all the GFC_DECL_SAVED_DESCRIPTOR business disappears, ...
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;
+
... and this needs to be moved ...
I tried that and it did not work. I got other fails.
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;
... here, ...
/* Create a character length variable. */
... and the couple of new utilility functions need to be updated as well.
See the patch. I had to beat my head on the wall a bit. Regression tests fine
here and more tests included.
I have one more comment, and one additional testcase.
Included test case plus some.
---snip ---
It doesn't seem to be correct to check the absence of any subreference.
The span is a property of the array; it doesn't depend on subreferences.
Even if there is a subreference after it, the array reference should
continue to use spanned array indexing. The program below regresses for
example (not sure it's related to this condition). Surprisingly it
doesn't seem to be covered by the testsuite.
I think I have it covered now.
The sub-reference condition in gfc_get_array_span covered up the real bug. This
caused the copy in/out to be skipped in the test case you provided.
Thanks for the review and the test case.
I hope its OK now.
Regards,
Jerry
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
