See attached 4 of 5 patch
Regression tested on x86_64
Regards,
Jerry
---
fortran: [PR49802]-4 Sequence association of a scalar
actual with a VALUE array dummy
A scalar actual argument may be sequence associated with an
explicit-shape array dummy (F2023, 15.5.2.12). When that dummy has the
VALUE attribute the scalar reached conv_dummy_value, which handles only
scalar dummies, and gfortran ICEd.
conv_seq_assoc_value_arg copies as many elements as the dummy declares
into a temporary and passes that. The element count comes from the
bounds of the dummy, which may refer to other dummy arguments, so they
are evaluated on the caller side through the interface mapping;
gfc_conv_procedure_call now requests a mapping when any dummy is an
explicit-shape VALUE array. For a CHARACTER dummy the element sequence
is grouped by the character length of the dummy, while the hidden
length argument stays that of the actual argument, as it is for a dummy
without VALUE. A memcpy would leave the temporary sharing the actual
argument's allocatable components, so those are given copies of their
own and freed again after the call.
PR fortran/49802
gcc/fortran/ChangeLog:
* trans-expr.cc (has_value_array_dummy): New function.
(conv_seq_assoc_value_arg): New function. Copy the element
sequence declared by a VALUE array dummy when the actual argument
is a sequence associated scalar.
(gfc_conv_procedure_call): Request an interface mapping when a
dummy is an explicit-shape VALUE array, and call
conv_seq_assoc_value_arg for a scalar actual argument passed to a
VALUE array dummy.
gcc/testsuite/ChangeLog:
* gfortran.dg/value_15.f90: New test.
---From 060b7daa85d17311d461c72041752355693e5da6 Mon Sep 17 00:00:00 2001
From: Jerry DeLisle <[email protected]>
Date: Sun, 23 Aug 2026 18:29:54 -0700
Subject: [PATCH 4/5] fortran: [PR49802]-4 Sequence association of a scalar
actual with a VALUE array dummy
A scalar actual argument may be sequence associated with an
explicit-shape array dummy (F2023, 15.5.2.12). When that dummy has the
VALUE attribute the scalar reached conv_dummy_value, which handles only
scalar dummies, and gfortran ICEd.
conv_seq_assoc_value_arg copies as many elements as the dummy declares
into a temporary and passes that. The element count comes from the
bounds of the dummy, which may refer to other dummy arguments, so they
are evaluated on the caller side through the interface mapping;
gfc_conv_procedure_call now requests a mapping when any dummy is an
explicit-shape VALUE array. For a CHARACTER dummy the element sequence
is grouped by the character length of the dummy, while the hidden
length argument stays that of the actual argument, as it is for a dummy
without VALUE. A memcpy would leave the temporary sharing the actual
argument's allocatable components, so those are given copies of their
own and freed again after the call.
PR fortran/49802
gcc/fortran/ChangeLog:
* trans-expr.cc (has_value_array_dummy): New function.
(conv_seq_assoc_value_arg): New function. Copy the element
sequence declared by a VALUE array dummy when the actual argument
is a sequence associated scalar.
(gfc_conv_procedure_call): Request an interface mapping when a
dummy is an explicit-shape VALUE array, and call
conv_seq_assoc_value_arg for a scalar actual argument passed to a
VALUE array dummy.
gcc/testsuite/ChangeLog:
* gfortran.dg/value_15.f90: New test.
---
gcc/fortran/trans-expr.cc | 212 ++++++++++++++++++++++++-
gcc/testsuite/gfortran.dg/value_15.f90 | 90 +++++++++++
2 files changed, 300 insertions(+), 2 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/value_15.f90
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 32972d9c84a..ff09a0f0f1f 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6717,6 +6717,207 @@ gfc_const_length_character_type_p (gfc_typespec *ts)
}
+/* Returns true if FORMAL contains an explicit-shape array dummy with the
+ VALUE attribute. The bounds of such a dummy may have to be evaluated
+ on the caller side, which needs an interface mapping. */
+
+static bool
+has_value_array_dummy (gfc_formal_arglist *formal)
+{
+ for (; formal; formal = formal->next)
+ if (formal->sym && formal->sym->attr.value && formal->sym->attr.dimension
+ && formal->sym->as && formal->sym->as->type == AS_EXPLICIT)
+ return true;
+
+ return false;
+}
+
+
+/* Sequence association (F2023, 15.5.2.12) of a scalar actual argument E with
+ an explicit-shape array dummy FSYM that has the VALUE attribute. Copy as
+ many elements as the dummy declares into a temporary and pass that.
+ MAPPING supplies the caller-side values of any dummy arguments appearing
+ in the bounds or the character length of FSYM. */
+
+static void
+conv_seq_assoc_value_arg (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym,
+ gfc_interface_mapping *mapping)
+{
+ tree nelems, eltype, eltsize, tmpvar, src, tmp;
+ gfc_se se;
+ int n;
+
+ gcc_assert (fsym->as && fsym->as->type == AS_EXPLICIT);
+
+ /* Address of the first element of the actual argument's sequence. */
+ gfc_init_se (&se, NULL);
+ if (e->ts.type == BT_CHARACTER)
+ {
+ gfc_conv_expr (&se, e);
+ gfc_conv_string_parameter (&se);
+ /* The hidden length argument is that of the actual argument, as it
+ is for a dummy that does not have the VALUE attribute. */
+ parmse->string_length = se.string_length;
+ }
+ else
+ gfc_conv_expr_reference (&se, e);
+ gfc_add_block_to_block (&parmse->pre, &se.pre);
+ gfc_add_block_to_block (&parmse->post, &se.post);
+ src = se.expr;
+
+ /* Number of elements of the dummy. */
+ nelems = gfc_index_one_node;
+ for (n = 0; n < fsym->as->rank; n++)
+ {
+ tree lbound, ubound, extent;
+
+ gfc_init_se (&se, NULL);
+ gfc_apply_interface_mapping (mapping, &se, fsym->as->upper[n]);
+ gfc_add_block_to_block (&parmse->pre, &se.pre);
+ gfc_add_block_to_block (&parmse->post, &se.post);
+ ubound = fold_convert (gfc_array_index_type, se.expr);
+
+ if (fsym->as->lower[n])
+ {
+ gfc_init_se (&se, NULL);
+ gfc_apply_interface_mapping (mapping, &se, fsym->as->lower[n]);
+ gfc_add_block_to_block (&parmse->pre, &se.pre);
+ gfc_add_block_to_block (&parmse->post, &se.post);
+ lbound = fold_convert (gfc_array_index_type, se.expr);
+ }
+ else
+ lbound = gfc_index_one_node;
+
+ extent = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, ubound, lbound);
+ extent = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, extent,
+ gfc_index_one_node);
+ extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
+ extent, gfc_index_zero_node);
+ nelems = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, nelems, extent);
+ }
+ nelems = gfc_evaluate_now (nelems, &parmse->pre);
+
+ /* Element type and size of the dummy. For characters the element
+ sequence is grouped by the character length of the dummy. */
+ if (fsym->ts.type == BT_CHARACTER)
+ {
+ tree len;
+
+ if (fsym->ts.u.cl->length)
+ {
+ gfc_init_se (&se, NULL);
+ gfc_apply_interface_mapping (mapping, &se, fsym->ts.u.cl->length);
+ gfc_add_block_to_block (&parmse->pre, &se.pre);
+ gfc_add_block_to_block (&parmse->post, &se.post);
+ len = fold_convert (gfc_charlen_type_node, se.expr);
+ }
+ else
+ len = fold_convert (gfc_charlen_type_node, parmse->string_length);
+
+ eltype = gfc_get_character_type_len (fsym->ts.kind, len);
+ eltsize = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+ fold_convert (size_type_node, len),
+ fold_convert (size_type_node,
+ TYPE_SIZE_UNIT (gfc_get_char_type
+ (fsym->ts.kind))));
+ }
+ else
+ {
+ eltype = gfc_typenode_for_spec (&fsym->ts);
+ eltsize = fold_convert (size_type_node, TYPE_SIZE_UNIT (eltype));
+ }
+
+ /* The temporary holding the copy. Allocate at least one element so that
+ a zero-sized dummy does not produce a degenerate array type. */
+ tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
+ nelems, gfc_index_one_node);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ tmp = build_array_type (eltype, build_range_type (gfc_array_index_type,
+ gfc_index_zero_node, tmp));
+ tmpvar = gfc_create_var (tmp, "seq_copy");
+ gfc_add_expr_to_block (&parmse->pre,
+ fold_build1_loc (input_location, DECL_EXPR, tmp,
+ tmpvar));
+
+ tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+ fold_convert (size_type_node, nelems), eltsize);
+ tmp = gfc_build_memcpy_call (fold_convert (pvoid_type_node,
+ gfc_build_addr_expr (NULL_TREE,
+ tmpvar)),
+ fold_convert (pvoid_type_node, src), tmp);
+ gfc_add_expr_to_block (&parmse->pre, tmp);
+
+ /* The memcpy also copied the component pointers of a derived type, which
+ would leave the temporary sharing the actual argument's allocatable
+ components. Give the copy components of its own and free them again
+ once the call has returned. */
+ if (fsym->ts.type == BT_DERIVED && fsym->ts.u.derived->attr.alloc_comp)
+ {
+ tree srcp = fold_convert (build_pointer_type (eltype), src);
+
+ for (n = 0; n < 2; n++)
+ {
+ stmtblock_t loop_block, body;
+ tree idx, exit_label, delt;
+
+ idx = gfc_create_var (gfc_array_index_type, "idx");
+ exit_label = gfc_build_label_decl (NULL_TREE);
+ TREE_USED (exit_label) = 1;
+
+ gfc_start_block (&loop_block);
+ gfc_add_modify (&loop_block, idx, gfc_index_zero_node);
+
+ gfc_start_block (&body);
+ tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
+ idx, nelems);
+ tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, exit_label),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&body, tmp);
+
+ delt = gfc_build_array_ref (tmpvar, idx, NULL_TREE);
+ if (n == 0)
+ {
+ tree off = fold_build2_loc (input_location, MULT_EXPR, sizetype,
+ fold_convert (sizetype, idx), eltsize);
+ tree selt
+ = build_fold_indirect_ref_loc (input_location,
+ fold_build_pointer_plus_loc
+ (input_location, srcp, off));
+ tmp = gfc_copy_alloc_comp (fsym->ts.u.derived, selt, delt, 0, 0);
+ }
+ else
+ tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived, delt, 0);
+ gfc_add_expr_to_block (&body, tmp);
+
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+ idx, gfc_index_one_node);
+ gfc_add_modify (&body, idx, tmp);
+
+ gfc_add_expr_to_block (&loop_block,
+ build1_v (LOOP_EXPR, gfc_finish_block (&body)));
+ gfc_add_expr_to_block (&loop_block, build1_v (LABEL_EXPR, exit_label));
+
+ tmp = gfc_finish_block (&loop_block);
+ if (n == 0)
+ gfc_add_expr_to_block (&parmse->pre, tmp);
+ else
+ gfc_add_expr_to_block (&parmse->post, tmp);
+ }
+ }
+
+ if (fsym->ts.type == BT_CHARACTER)
+ parmse->expr
+ = gfc_build_addr_expr (build_pointer_type (gfc_get_char_type
+ (fsym->ts.kind)), tmpvar);
+ else
+ parmse->expr = gfc_build_addr_expr (build_pointer_type (eltype), tmpvar);
+}
+
+
/* Helper function for the handling of (currently) scalar dummy variables
with the VALUE attribute. Argument parmse should already be set up. */
static void
@@ -7162,7 +7363,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
(sym->ts.type == BT_CHARACTER
&& sym->ts.u.cl->length
&& sym->ts.u.cl->length->expr_type
- != EXPR_CONSTANT);
+ != EXPR_CONSTANT) ||
+ has_value_array_dummy (formal);
}
else
{
@@ -7171,7 +7373,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
(comp->ts.type == BT_CHARACTER
&& comp->ts.u.cl->length
&& comp->ts.u.cl->length->expr_type
- != EXPR_CONSTANT);
+ != EXPR_CONSTANT) ||
+ has_value_array_dummy (formal);
}
base_object = NULL_TREE;
@@ -7510,6 +7713,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* Implement F2018, 18.3.6, list item (5), bullet point 2. */
gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
+ else if (fsym && fsym->attr.value && fsym->attr.dimension)
+ /* Scalar actual argument sequence associated with a VALUE
+ array dummy. */
+ conv_seq_assoc_value_arg (&parmse, e, fsym, &mapping);
+
else if (fsym && fsym->attr.value)
{
if (fsym->ts.type == BT_CHARACTER
diff --git a/gcc/testsuite/gfortran.dg/value_15.f90 b/gcc/testsuite/gfortran.dg/value_15.f90
new file mode 100644
index 00000000000..46bd8794420
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/value_15.f90
@@ -0,0 +1,90 @@
+! { dg-do run }
+! PR 49802
+! Sequence association (F2023, 15.5.2.12) of a scalar actual argument
+! with an explicit-shape array dummy that has the VALUE attribute used
+! to ICE in conv_dummy_value. The dummy receives a private copy of as
+! many elements as it declares.
+
+program test
+ implicit none
+ type :: dt
+ integer, allocatable :: d(:)
+ end type
+ integer :: a(20), i
+ character(len=12) :: s
+ type(dt) :: t(3)
+
+ a = [(i, i=1,20)]
+ s = "abcdefghijkl"
+
+ call const_bound (a(3))
+ if (any (a /= [(i, i=1,20)])) stop 1
+
+ call dummy_bound (4, a(3))
+ if (any (a /= [(i, i=1,20)])) stop 2
+
+ call rank_two (a(5))
+ if (any (a /= [(i, i=1,20)])) stop 3
+
+ call char_elems (s)
+ if (s /= "abcdefghijkl") stop 4
+
+ call char_dummy_len (3, s)
+ if (s /= "abcdefghijkl") stop 5
+
+ do i = 1, 3
+ allocate (t(i)%d(2), source=[i,i])
+ end do
+ call alloc_comp (t(1))
+ if (any (t(1)%d /= [1,1])) stop 6
+ if (any (t(2)%d /= [2,2])) stop 7
+
+contains
+
+ subroutine const_bound (x)
+ integer, value :: x(5)
+ if (any (x /= [3,4,5,6,7])) stop 11
+ x = -1
+ end subroutine
+
+ subroutine dummy_bound (n, x)
+ integer, intent(in) :: n
+ integer, value :: x(n)
+ if (size (x) /= 4) stop 21
+ if (any (x /= [3,4,5,6])) stop 22
+ x = -1
+ end subroutine
+
+ subroutine rank_two (x)
+ integer, value :: x(2,3)
+ if (any (reshape (x, [6]) /= [5,6,7,8,9,10])) stop 31
+ x = -1
+ end subroutine
+
+ subroutine char_elems (x)
+ character(len=3), value :: x(4)
+ if (x(1) /= "abc" .or. x(4) /= "jkl") stop 41
+ x = "ZZZ"
+ end subroutine
+
+ ! The copy is deep: the callee must not reach the actual argument's
+ ! data through a shared component pointer.
+ subroutine alloc_comp (x)
+ type(dt), value :: x(2)
+ if (any (x(1)%d /= [1,1])) stop 61
+ if (any (x(2)%d /= [2,2])) stop 62
+ x(1)%d = [-1,-1]
+ x(2)%d = [-9,-9]
+ if (any (x(1)%d /= [-1,-1])) stop 63
+ if (any (x(2)%d /= [-9,-9])) stop 64
+ end subroutine
+
+ subroutine char_dummy_len (n, x)
+ integer, intent(in) :: n
+ character(len=n), value :: x(4)
+ if (len (x) /= 3) stop 51
+ if (x(1) /= "abc" .or. x(4) /= "jkl") stop 52
+ x = "ZZZ"
+ end subroutine
+
+end program
--
2.55.0
