On 8/13/26 7:05 AM, Mikael Morin wrote:
Le 13/08/2026 à 00:27, Jerry DeLisle a écrit :
See below, I added a version number on the patch file name, re-attached.
Err, I double checked again, still the same patch.
The second version patch was in [1], and as followup to my answer, your next
message with a patch [2] and the latest [3] contain the same patch as [1].
[1] https://gcc.gnu.org/pipermail/fortran/2026-August/064457.html
[2] https://gcc.gnu.org/pipermail/fortran/2026-August/064463.html
[3] https://gcc.gnu.org/pipermail/fortran/2026-August/064469.html
On 8/10/26 8:20 AM, Jerry D wrote:
What did go away is the particular part. There is now one check,
gfc_is_span_addressed_dummy (gfc_symbol *)
used by gfc_build_dummy_array_decl, gfc_get_symbol_decl,
This function `gfc_is_span_addressed_dummy' is nowhere in the patch. So the
message must have the wrong patch attached to it?
I made it home late yesterday. Please accept my apologies.
The attached is the correct patch file.
OK for mainline?
Best regards,
Jerry
From f47f69ef29a10a4b0218c504ffef1bc375037323 Mon Sep 17 00:00:00 2001
From: Jerry DeLisle <[email protected]>
Date: Mon, 10 Aug 2026 09:37:01 -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.
Such an actual argument is now passed with a descriptor of its own,
whose element type is that of the subobject and whose span is the
element size of the array, as is already done for a pointer assignment
to a subobject of an array. The dummy addresses its elements through
that span. Passing it on to a dummy that requires contiguous storage
copies it, but only if it turns out not to be contiguous.
PR fortran/53800
gcc/fortran/ChangeLog:
* gfortran.h (gfc_is_span_addressed_dummy): New prototype.
* symbol.cc (gfc_is_span_addressed_dummy): New function.
* expr.cc (is_subref_array): Return true for a span addressed dummy.
* 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.
(span_addressed_array): New function returning the decl that
provides the span of an array.
(gfc_get_array_span): Use it.
(gfc_conv_scalarized_array_ref, gfc_conv_array_ref): Likewise, so
that a descriptorless dummy is addressed by its span.
(gfc_get_dataptr_offset): Likewise and dereference a spanned
character element.
(gfc_conv_expr_descriptor): Describe a subobject of the array
elements by a new descriptor when no temporary is made.
* trans-decl.cc (gfc_build_dummy_array_decl): Use
gfc_is_span_addressed_dummy to mark the dummy as a pointer array.
(gfc_get_symbol_decl): Likewise.
* trans-expr.cc (is_subobject_ref): New function.
(copy_in_out_allowed): Take the actual argument. Use
gfc_is_span_addressed_dummy and keep the copy for an actual
argument with a vector subscript.
(gfc_conv_gfc_desc_to_cfi_desc): Remove the now duplicate offsetting
of the data pointer for a subobject reference.
(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. Pass a spanned descriptor instead and
make the copy of a span addressed dummy conditional on it not being
contiguous.
* trans-intrinsic.cc (gfc_conv_is_contiguous_expr): Check the span
of a span addressed dummy against the element length.
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.
* gfortran.dg/class_to_type_8.f90: New test.
* gfortran.dg/class_to_type_9.f90: New test.
libgomp/ChangeLog:
* testsuite/libgomp.oacc-fortran/host_data-5.F90: Update the
privatization notes for the packing of a TARGET dummy.
---
gcc/fortran/expr.cc | 3 +-
gcc/fortran/gfortran.h | 1 +
gcc/fortran/symbol.cc | 24 +++
gcc/fortran/trans-array.cc | 69 +++++---
gcc/fortran/trans-decl.cc | 22 ++-
gcc/fortran/trans-expr.cc | 92 ++++++++---
gcc/fortran/trans-intrinsic.cc | 7 +-
gcc/fortran/trans.cc | 31 +++-
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 ++++++++++++++++++
gcc/testsuite/gfortran.dg/class_to_type_8.f90 | 47 ++++++
gcc/testsuite/gfortran.dg/class_to_type_9.f90 | 67 ++++++++
.../libgomp.oacc-fortran/host_data-5.F90 | 15 +-
16 files changed, 612 insertions(+), 54 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
create mode 100644 gcc/testsuite/gfortran.dg/class_to_type_8.f90
create mode 100644 gcc/testsuite/gfortran.dg/class_to_type_9.f90
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 20eddbefd57..52945a1db13 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -1222,7 +1222,8 @@ is_subref_array (gfc_expr * e)
sym = e->symtree->n.sym;
- if (sym->attr.subref_array_pointer)
+ if (sym->attr.subref_array_pointer
+ || gfc_is_span_addressed_dummy (sym))
return true;
seen_array = false;
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 5bd8dd50c1c..2a1f1608fba 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3971,6 +3971,7 @@ bool gfc_check_symbol_typed (gfc_symbol*, gfc_namespace*, bool, locus);
gfc_namespace* gfc_find_proc_namespace (gfc_namespace*);
bool gfc_is_associate_pointer (gfc_symbol*);
+bool gfc_is_span_addressed_dummy (gfc_symbol *);
gfc_symbol * gfc_find_dt_in_generic (gfc_symbol *);
gfc_formal_arglist *gfc_sym_get_dummy_args (gfc_symbol *);
diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc
index 36e1262fff5..dde3e92a33d 100644
--- a/gcc/fortran/symbol.cc
+++ b/gcc/fortran/symbol.cc
@@ -5702,6 +5702,30 @@ gfc_is_associate_pointer (gfc_symbol* sym)
}
+/* Check if a dummy argument must be addressed using the span of its
+ descriptor. The actual argument of an assumed shape or assumed rank
+ TARGET dummy is never copied, so its elements can be spaced by more
+ than the element size. CLASS and assumed type entities already carry
+ their element size and are excluded. */
+
+bool
+gfc_is_span_addressed_dummy (gfc_symbol *sym)
+{
+ return sym->attr.dummy
+ && sym->attr.target
+ && sym->attr.dimension
+ && !sym->attr.value
+ && !sym->attr.contiguous
+ && !sym->attr.pointer
+ && !sym->attr.allocatable
+ && sym->ts.type != BT_CLASS
+ && sym->ts.type != BT_ASSUMED
+ && sym->as
+ && (sym->as->type == AS_ASSUMED_SHAPE
+ || sym->as->type == AS_ASSUMED_RANK);
+}
+
+
gfc_symbol *
gfc_find_dt_in_generic (gfc_symbol *sym)
{
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index f3c9b815dd6..348039a0907 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,29 @@ is_pointer_array (tree expr)
}
+/* If the elements of the array are spaced by the span of its descriptor,
+ return the decl that provides that span, otherwise NULL_TREE. This is
+ either a descriptor or the local decl of a descriptorless dummy array,
+ which keeps the descriptor it was built from as the saved one. */
+
+static tree
+span_addressed_array (tree expr)
+{
+ if (is_pointer_array (expr))
+ return expr;
+
+ if (VAR_P (expr)
+ && GFC_DECL_PTR_ARRAY_P (expr)
+ && !GFC_DECL_CLASS (expr)
+ && GFC_ARRAY_TYPE_P (TREE_TYPE (expr))
+ && DECL_LANG_SPECIFIC (expr)
+ && GFC_DECL_SAVED_DESCRIPTOR (expr))
+ return 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
@@ -554,18 +578,13 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
gfc_symbol *sym = (expr && expr->expr_type == EXPR_VARIABLE) ?
expr->symtree->n.sym : NULL;
- if (is_pointer_array (desc)
+ if (span_addressed_array (desc)
|| (get_CFI_desc (NULL, expr, &desc, NULL)
&& (POINTER_TYPE_P (TREE_TYPE (desc))
? 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);
- }
+ /* This will have the span field set. */
+ tmp = gfc_conv_descriptor_span_get (gfc_get_span_descriptor (desc));
else if (expr->ts.type == BT_ASSUMED)
{
if (DECL_LANG_SPECIFIC (desc) && GFC_DECL_SAVED_DESCRIPTOR (desc))
@@ -3964,7 +3983,7 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar,
/* A pointer array component can be detected from its field decl. Fix
the descriptor, mark the resulting variable decl and pass it to
gfc_build_array_ref. */
- if (is_pointer_array (info->descriptor)
+ if (span_addressed_array (info->descriptor)
|| (expr && expr->ts.deferred && info->descriptor
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor))))
{
@@ -4217,11 +4236,9 @@ 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))
+ && span_addressed_array (se->expr))
{
- if (TREE_CODE (se->expr) == COMPONENT_REF)
- decl = se->expr;
- else if (INDIRECT_REF_P (se->expr))
+ if (INDIRECT_REF_P (se->expr))
decl = TREE_OPERAND (se->expr, 0);
else
decl = se->expr;
@@ -7595,7 +7612,13 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
return;
}
- tmp = build_array_ref (desc, offset, NULL, NULL);
+ /* An array whose elements are spaced by the span needs pointer arithmetic
+ to reference an element. */
+ tmp = build_array_ref (desc, offset, span_addressed_array (desc), NULL);
+
+ /* A spanned character element is referenced by a pointer. */
+ if (POINTER_TYPE_P (TREE_TYPE (tmp)) && span_addressed_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. */
@@ -8058,6 +8081,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
subref_array_target = (is_subref_array (expr)
&& (se->direct_byref
+ || se->force_no_tmp
|| expr->ts.type == BT_CHARACTER));
need_tmp = (gfc_ref_needs_temporary_p (expr->ref)
&& !subref_array_target);
@@ -8087,6 +8111,13 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
else
full = gfc_full_array_ref_p (info->ref, NULL);
+ /* A subobject of the array elements is described by a new descriptor,
+ whose element type is that of the subobject and whose span is the
+ element size of the array. */
+ if (subref_array_target && !se->direct_byref
+ && info->ref && info->ref->next)
+ full = 0;
+
if (full && !transposed_dims (ss))
{
if (se->direct_byref && !se->byref_noassign)
@@ -8408,8 +8439,10 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
}
else
{
- /* Otherwise make a new one. */
- if (expr->ts.type == BT_CHARACTER)
+ /* Otherwise make a new one. The element type is that of the
+ subobject for a subreference of the array. */
+ if (expr->ts.type == BT_CHARACTER
+ || (subref_array_target && !se->direct_byref))
parmtype = gfc_typenode_for_spec (&expr->ts);
else
parmtype = gfc_get_element_type (TREE_TYPE (desc));
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 47b28c1d003..715dd1fd5c9 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;
+ /* The elements of the actual argument can be spaced by more than the
+ element size, so the span of the descriptor is used to address them. */
+ if (gfc_is_span_addressed_dummy (sym) && 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,8 @@ 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.pointer && sym->attr.dimension && sym->ts.type != BT_CLASS)
+ || gfc_is_span_addressed_dummy (sym))
GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1;
/* Create a character length variable. */
@@ -2078,6 +2084,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..8a72aafb016 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);
@@ -6233,14 +6235,12 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
else
gfc_conv_expr_descriptor (&se, e);
gfc = se.expr;
- /* For dt(:)%var the elem_len*stride != sm, hence, GFC uses
- elem_len = sizeof(dt) and base_addr = dt(lb) instead.
- gfc_get_dataptr_offset fixes the base_addr; for elem_len, see below.
- While sm is fine as it uses span*stride and not elem_len. */
+ /* For dt(:)%var, the base_addr is that of the subobject and elem_len is
+ its size, see below. The descriptor built for a subreference of the
+ array provides both. While sm is fine as it uses span*stride and not
+ elem_len. */
if (POINTER_TYPE_P (TREE_TYPE (gfc)))
gfc = build_fold_indirect_ref_loc (input_location, gfc);
- else if (is_subref_array (e) && e->ts.type != BT_CHARACTER)
- gfc_get_dataptr_offset (&se.pre, gfc, gfc, NULL, true, e);
}
if (e->ts.type == BT_CHARACTER)
{
@@ -6954,6 +6954,48 @@ conv_null_actual (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym)
}
+/* Return true if a subobject of the elements of an array is referenced. */
+
+static bool
+is_subobject_ref (gfc_expr *e)
+{
+ bool seen_array = false;
+
+ for (gfc_ref *ref = e->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
+ seen_array = true;
+ else if (seen_array)
+ return true;
+ }
+
+ return false;
+}
+
+
+/* Return true if the actual argument E for the dummy FSYM may be passed as a
+ copy-in/copy-out temporary. A pointer associated with a TARGET or POINTER
+ dummy must remain valid after the call, so the actual argument is passed
+ directly, with a descriptor whose span provides the element spacing. An
+ actual argument with a vector subscript is not definable and its pointer
+ association is undefined on return, so it is still copied. */
+
+static bool
+copy_in_out_allowed (gfc_symbol *fsym, gfc_expr *e, bool nodesc_arg)
+{
+ if (fsym == NULL || nodesc_arg || gfc_has_vector_subscript (e))
+ return true;
+
+ if (gfc_is_span_addressed_dummy (fsym))
+ return false;
+
+ return !(fsym->attr.pointer && !fsym->attr.contiguous && fsym->as
+ && (fsym->as->type == AS_ASSUMED_SHAPE
+ || fsym->as->type == AS_ASSUMED_RANK
+ || 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,14 +8027,20 @@ 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, e, 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. */
+ written back after the procedure call. The elements of
+ a span addressed dummy passed on as a whole are usually
+ contiguous, so the copy is made conditional. */
gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
fsym ? fsym->attr.intent : INTENT_INOUT,
- fsym && fsym->attr.pointer);
+ fsym && fsym->attr.pointer, fsym, sym->name,
+ NULL,
+ gfc_is_span_addressed_dummy (e->symtree->n.sym)
+ && !is_subobject_ref (e));
else if (e->ts.type == BT_CLASS && CLASS_DATA (e)->as
&& CLASS_DATA (e)->as->type == AS_ASSUMED_SIZE
@@ -8004,20 +8052,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, e, 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, e, nodesc_arg))
/* See previous comment. For function actual argument,
the write out is not needed so the intent is set as
intent in. */
@@ -8038,10 +8085,17 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
fsym->attr.pointer);
}
else
- /* This is where we introduce a temporary to store the
- result of a non-lvalue array expression. */
- gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
- sym->name, NULL);
+ {
+ /* Having declined copy-in/copy-out above, a subobject of an
+ array is described by a spanned descriptor. */
+ if (e->expr_type == EXPR_VARIABLE && is_subref_array (e))
+ parmse.force_no_tmp = 1;
+
+ /* This is where we introduce a temporary to store the
+ result of a non-lvalue array expression. */
+ gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
+ sym->name, NULL);
+ }
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
allocated on entry, it must be deallocated.
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 5e3681da467..a76d9bb4325 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -2385,9 +2385,10 @@ gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg)
se->expr = cond;
}
- /* A pointer that does not have the CONTIGUOUS attribute needs to be checked
- if it points to an array whose span differs from the element size. */
- if (as && sym && IS_POINTER(sym) && !sym->attr.contiguous)
+ /* An array that is addressed by the span of its descriptor needs to be
+ checked if that span differs from the element size. */
+ if (as && sym && !sym->attr.contiguous
+ && (IS_POINTER (sym) || gfc_is_span_addressed_dummy (sym)))
{
tree span = gfc_conv_descriptor_span_get (desc);
tmp = fold_convert (TREE_TYPE (span),
diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc
index cf37261673c..c2ad65c9a74 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -389,6 +389,27 @@ gfc_build_addr_expr (tree type, tree t)
}
+/* Return the descriptor that carries the span of DECL, which is marked as a
+ pointer array. Such a decl usually is a descriptor. The local decl of a
+ descriptorless dummy array is not, so its span comes from the descriptor it
+ was built from, which 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 +430,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 +472,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
diff --git a/gcc/testsuite/gfortran.dg/class_to_type_8.f90 b/gcc/testsuite/gfortran.dg/class_to_type_8.f90
new file mode 100644
index 00000000000..48851d42cd1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_to_type_8.f90
@@ -0,0 +1,47 @@
+! { dg-do run }
+! PR fortran/53800
+
+! A component of an array of extended derived types, passed to a TARGET
+! dummy, is addressed through the span of its descriptor. This must also
+! hold for a section of such a dummy and for a subobject reference applied
+! to it.
+!
+! Contributed by Mikael Morin <[email protected]>
+
+program p
+ implicit none
+ type :: t
+ integer :: c1, c2
+ end type
+ type, extends(t) :: u
+ integer :: c3
+ end type
+ type, extends(u) :: v
+ integer :: c4
+ end type
+ type(v), target :: x(12)
+ integer :: i
+ x = [(v(i,i*i,i,i), i=1,size(x))]
+ call s1(x(2::3)%c2, 1)
+ call s2(x%u)
+contains
+ subroutine s1(a, error_idx)
+ integer, intent(in) :: error_idx
+ integer, target :: a(:)
+ if (any(a /= [4, 25, 64, 121])) error stop error_idx * 10 + 1
+ end subroutine
+ subroutine s2(a)
+ type(u), target :: a(:)
+ if (any(a%c2 /= [(i*i, i=1,12)])) error stop 2
+ if (any(a(2::3)%c2 /= [4, 25, 64, 121])) error stop 3
+ call s1(a(2::3)%c2, 2)
+ call s3(a(2::3)%c2)
+ if (any(x(2::3)%c2 /= [-4, -25, -64, -121])) error stop 5
+ x = [(v(i,i*i,i,i), i=1,size(x))]
+ end subroutine
+ subroutine s3(a)
+ integer :: a(:) ! copy-in/copy-out
+ if (any(a /= [4, 25, 64, 121])) error stop 4
+ a = -a
+ end subroutine
+end program
diff --git a/gcc/testsuite/gfortran.dg/class_to_type_9.f90 b/gcc/testsuite/gfortran.dg/class_to_type_9.f90
new file mode 100644
index 00000000000..40f4e6a53de
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_to_type_9.f90
@@ -0,0 +1,67 @@
+! { dg-do run }
+! PR fortran/53800
+
+! A TARGET dummy associated with elements that are spaced by more than the
+! element size: pointers to it stay valid after the call, it is written
+! through, it is not contiguous, it is copied when passed on to a dummy
+! without the TARGET attribute and it is transferred element by element.
+
+module m
+ implicit none
+ type :: t
+ integer :: c1, c2
+ end type
+ integer, pointer :: saved(:) => null()
+contains
+ subroutine chk(a, opt)
+ integer, target :: a(:)
+ integer, optional, target :: opt(:)
+ character(24) :: line
+ if (is_contiguous(a)) stop 1
+ if (present(opt)) stop 2
+ write (line, '(4I3)') a
+ if (line(1:12) /= ' 1 4 9 16') stop 3
+ if (sum(a) /= 30) stop 4
+ call packed(a)
+ call assumed_size(a)
+ saved => a
+ a(2) = -a(2)
+ end subroutine
+ subroutine packed(b) ! copy-in/copy-out
+ integer :: b(:)
+ if (any(b /= [1, 4, 9, 16])) stop 5
+ if (.not. is_contiguous(b)) stop 6
+ end subroutine
+ subroutine assumed_size(c) ! no descriptor
+ integer :: c(*)
+ if (any(c(1:4) /= [1, 4, 9, 16])) stop 7
+ end subroutine
+ subroutine rank_any(d)
+ integer, target :: d(..)
+ select rank (d)
+ rank (1)
+ if (any(d /= [1, 2, 3, 4])) stop 8
+ saved => d
+ rank default
+ stop 9
+ end select
+ end subroutine
+end module
+
+program p
+ use m
+ implicit none
+ type(t), target :: x(4)
+ integer :: i
+ x = [(t(i, i*i), i=1,4)]
+
+ call chk(x%c2)
+ if (any(x%c2 /= [1, -4, 9, 16])) stop 10
+ saved = 0
+ if (any(x%c2 /= [0, 0, 0, 0])) stop 11
+ if (any(x%c1 /= [1, 2, 3, 4])) stop 12
+
+ call rank_any(x%c1)
+ saved = 7
+ if (any(x%c1 /= [7, 7, 7, 7])) stop 13
+end program
diff --git a/libgomp/testsuite/libgomp.oacc-fortran/host_data-5.F90 b/libgomp/testsuite/libgomp.oacc-fortran/host_data-5.F90
index c3453a579ae..ae5104beb48 100644
--- a/libgomp/testsuite/libgomp.oacc-fortran/host_data-5.F90
+++ b/libgomp/testsuite/libgomp.oacc-fortran/host_data-5.F90
@@ -74,10 +74,17 @@ subroutine foo (p2, parr, host_p, host_parr, cond)
! { dg-note {variable 'host_p\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-5 }
! { dg-note {variable 'host_parr\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-6 }
! { dg-note {variable 'C\.[0-9]+' declared in block potentially has improper OpenACC privatization level: 'const_decl'} "TODO" { target *-*-* } .-7 }
- ! { dg-note {variable 'parm\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: artificial} "" { target *-*-* } .-8 }
- ! { dg-note {variable 'D\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: artificial} "" { target *-*-* } .-9 }
- ! { dg-note {variable 'transfer\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: artificial} "" { target *-*-* } .-10 }
- ! { dg-note {variable 'parm\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-11 }
+ ! { dg-note {variable 'D\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: artificial} "" { target *-*-* } .-8 }
+ ! { dg-note {variable 'transfer\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: artificial} "" { target *-*-* } .-9 }
+ ! { dg-note {variable 'parm\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-10 }
+ ! The TARGET dummy 'parr' is addressed by the span of its descriptor, so
+ ! passing it to a dummy without a descriptor packs it when it is not
+ ! contiguous.
+ ! { dg-note {variable 'iftmp\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-14 }
+ ! { dg-note {variable 'atmp\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-15 }
+ ! { dg-note {variable 'arg_ptr\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-16 }
+ ! { dg-note {variable 'contiguous\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-17 }
+ ! { dg-note {variable 'S\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-18 }
if (.not. acc_is_present(p, c_sizeof(p))) stop 11
if (.not. acc_is_present(parr, 1)) stop 12
! Not inside a host_data construct, so still the host pointer.
--
2.55.0
