See the attached patch.
As stated in the PR we were missing the stride multiplier (ie span)
I will note as a useful tool: I had an initial patch for this but wanted to
exercise it. I prompted Claude Pro Opus 5 to create numerous variations on the
original test case provided by Tobias Burnus in the original report. The result
was 25 to 30 variations which were helpful in identifying code paths I would not
have otherwise found. I am not using those test cases here.
I flagged out this one to work on as it has been around a long time and we were
giving wrong results without any idea it was happening.
I also wanted to mention that the fortran standardese is difficult to interpret
but I think I got this right.
Regression tested on x86_64.
OK for mainline?
Comments appreciated.
Regards,
Jerry
---
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.
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
