See attached 5 of 5 patch
Regression tested on x86_64
Regards,
Jerry
---
fortran: [PR49802]-5 Absent optional actual argument
passed to a VALUE dummy
The private copy made for a VALUE dummy dereferenced the actual
argument unconditionally, so passing an absent optional actual argument
to an optional VALUE dummy segfaulted. Both the array copy and the
copy made for a CHARACTER dummy of assumed or non-constant length have
to be suppressed when the actual argument is absent.
gfc_conv_subref_array_arg already has the machinery: given the symbol
of the actual argument it suppresses its copy and passes a null pointer
instead, so the array case just has to hand it that symbol rather than
the symbol of the procedure being called. This is what makes the two
pass_optional fixes of the first patch of this series reachable.
conv_dummy_value has no such machinery and guards its CHARACTER copy
directly, passing a null pointer and a zero length when the actual
argument is absent.
PR fortran/49802
gcc/fortran/ChangeLog:
* trans-expr.cc (conv_dummy_value): Suppress the CHARACTER copy
and pass a null pointer and a zero length when the actual argument
is an absent optional one.
(gfc_conv_procedure_call): Give gfc_conv_subref_array_arg the
symbol of the actual argument, so that an absent optional one
suppresses the copy.
gcc/testsuite/ChangeLog:
* gfortran.dg/value_18.f90: New test.
---From 1f42c7657c9e2077c6fa5cfbbbf521ef4a07b96b Mon Sep 17 00:00:00 2001
From: Jerry DeLisle <[email protected]>
Date: Sun, 23 Aug 2026 18:30:26 -0700
Subject: [PATCH 5/5] fortran: [PR49802]-5 Absent optional actual argument
passed to a VALUE dummy
The private copy made for a VALUE dummy dereferenced the actual
argument unconditionally, so passing an absent optional actual argument
to an optional VALUE dummy segfaulted. Both the array copy and the
copy made for a CHARACTER dummy of assumed or non-constant length have
to be suppressed when the actual argument is absent.
gfc_conv_subref_array_arg already has the machinery: given the symbol
of the actual argument it suppresses its copy and passes a null pointer
instead, so the array case just has to hand it that symbol rather than
the symbol of the procedure being called. This is what makes the two
pass_optional fixes of the first patch of this series reachable.
conv_dummy_value has no such machinery and guards its CHARACTER copy
directly, passing a null pointer and a zero length when the actual
argument is absent.
PR fortran/49802
gcc/fortran/ChangeLog:
* trans-expr.cc (conv_dummy_value): Suppress the CHARACTER copy
and pass a null pointer and a zero length when the actual argument
is an absent optional one.
(gfc_conv_procedure_call): Give gfc_conv_subref_array_arg the
symbol of the actual argument, so that an absent optional one
suppresses the copy.
gcc/testsuite/ChangeLog:
* gfortran.dg/value_18.f90: New test.
---
gcc/fortran/trans-expr.cc | 33 ++++-
gcc/testsuite/gfortran.dg/value_18.f90 | 184 +++++++++++++++++++++++++
2 files changed, 215 insertions(+), 2 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/value_18.f90
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index ff09a0f0f1f..19982b1f733 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6979,8 +6979,23 @@ conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym,
&& (!fsym->ts.u.cl || !fsym->ts.u.cl->length
|| fsym->ts.u.cl->length->expr_type != EXPR_CONSTANT))
{
+ /* An optional actual argument that is absent has nothing to copy
+ from; pass a null pointer and a length of zero instead. */
+ tree present = NULL_TREE;
+ if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional)
+ present = gfc_conv_expr_present (e->symtree->n.sym);
+
gfc_conv_string_parameter (parmse);
tree len = fold_convert (gfc_charlen_type_node, parmse->string_length);
+ if (present)
+ {
+ len = fold_build3_loc (input_location, COND_EXPR,
+ gfc_charlen_type_node, present, len,
+ build_zero_cst (gfc_charlen_type_node));
+ len = gfc_evaluate_now (len, &parmse->pre);
+ parmse->string_length = len;
+ }
tree chartype = gfc_get_character_type_len (fsym->ts.kind, len);
tree val_copy = gfc_create_var (chartype, "val_copy");
tmp = fold_build1_loc (input_location, DECL_EXPR, chartype, val_copy);
@@ -6996,10 +7011,19 @@ conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym,
fold_convert (pvoid_type_node,
gfc_build_addr_expr (NULL_TREE, val_copy)),
fold_convert (pvoid_type_node, parmse->expr), bytes);
+ if (present)
+ tmp = build3_v (COND_EXPR, present, tmp,
+ build_empty_stmt (input_location));
gfc_add_expr_to_block (&parmse->pre, tmp);
parmse->expr = fold_convert (
build_pointer_type (gfc_get_char_type (fsym->ts.kind)),
gfc_build_addr_expr (NULL_TREE, val_copy));
+ if (present)
+ parmse->expr = fold_build3_loc (input_location, COND_EXPR,
+ TREE_TYPE (parmse->expr), present,
+ parmse->expr,
+ fold_convert (TREE_TYPE (parmse->expr),
+ null_pointer_node));
}
/* Truncate a too long constant character actual argument. */
@@ -8321,9 +8345,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& e->rank != -1)
/* VALUE array dummy: pass a private copy of the actual
argument. Allocatable components are copied deeply, so
- that the callee cannot reach the actual argument's data. */
+ that the callee cannot reach the actual argument's data.
+ The symbol passed is that of the actual argument, so that
+ the copy is suppressed and a null pointer passed when an
+ optional actual argument is absent. */
gfc_conv_subref_array_arg (&parmse, e, nodesc_arg, INTENT_IN,
- false, fsym, sym->name, NULL,
+ false, fsym, sym->name,
+ e->expr_type == EXPR_VARIABLE
+ ? e->symtree->n.sym : NULL,
false, true);
else if (e->expr_type == EXPR_VARIABLE
diff --git a/gcc/testsuite/gfortran.dg/value_18.f90 b/gcc/testsuite/gfortran.dg/value_18.f90
new file mode 100644
index 00000000000..f16c23f013a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/value_18.f90
@@ -0,0 +1,184 @@
+! { dg-do run }
+! PR 49802
+! An absent OPTIONAL actual argument passed to an OPTIONAL dummy with the
+! VALUE attribute used to segfault: the private copy made for the dummy
+! dereferenced the actual argument unconditionally. Both the array copy
+! and the copy made for a character dummy of assumed or non-constant
+! length must be suppressed when the actual argument is absent.
+
+module m
+ implicit none
+ type :: dt
+ integer, allocatable :: d(:)
+ end type
+contains
+
+ subroutine take_as (x, present_x)
+ integer, value, optional :: x(:)
+ logical, intent(in) :: present_x
+ if (present (x) .neqv. present_x) stop 1
+ if (present (x)) then
+ if (size (x) /= 3) stop 2
+ if (any (x /= [1, 2, 3])) stop 3
+ x = -1
+ if (any (x /= -1)) stop 4
+ end if
+ end subroutine take_as
+
+ subroutine take_es (n, x, present_x)
+ integer, intent(in) :: n
+ integer, value, optional :: x(n)
+ logical, intent(in) :: present_x
+ if (present (x) .neqv. present_x) stop 5
+ if (present (x)) then
+ if (size (x) /= n) stop 6
+ if (x(1) /= 1) stop 7
+ x = 0
+ if (any (x /= 0)) stop 8
+ end if
+ end subroutine take_es
+
+ subroutine take_cs (s, present_s)
+ character(len=*), value, optional :: s
+ logical, intent(in) :: present_s
+ if (present (s) .neqv. present_s) stop 9
+ if (present (s)) then
+ if (s /= 'payload') stop 10
+ s = repeat ('Z', len (s))
+ if (s /= repeat ('Z', len (s))) stop 11
+ end if
+ end subroutine take_cs
+
+ subroutine take_ca (s, present_s)
+ character(len=*), value, optional :: s(:)
+ logical, intent(in) :: present_s
+ if (present (s) .neqv. present_s) stop 12
+ if (present (s)) then
+ if (size (s) /= 2) stop 13
+ if (any (s /= ['ab', 'cd'])) stop 14
+ s = 'ZZ'
+ if (any (s /= 'ZZ')) stop 15
+ end if
+ end subroutine take_ca
+
+ ! A derived type with an allocatable component: the deep copy must be
+ ! suppressed too, not just the copy of the descriptor.
+
+ subroutine take_dt (x, present_x)
+ type(dt), value, optional :: x(:)
+ logical, intent(in) :: present_x
+ if (present (x) .neqv. present_x) stop 19
+ if (present (x)) then
+ if (size (x) /= 2) stop 20
+ if (any (x(1)%d /= [1, 1])) stop 21
+ x(1)%d = [-1, -1]
+ if (any (x(1)%d /= [-1, -1])) stop 22
+ end if
+ end subroutine take_dt
+
+ ! Relay an optional dummy on to the optional VALUE dummy. This is what
+ ! puts a descriptor of an absent argument into the argument list.
+
+ subroutine relay_as (x, present_x)
+ integer, optional :: x(:)
+ logical, intent(in) :: present_x
+ call take_as (x, present_x)
+ end subroutine relay_as
+
+ subroutine relay_es (n, x, present_x)
+ integer, intent(in) :: n
+ integer, optional :: x(n)
+ logical, intent(in) :: present_x
+ call take_es (n, x, present_x)
+ end subroutine relay_es
+
+ ! A non-constant length is needed here: with len=* the length of an
+ ! absent actual argument is zero and the copy reads nothing.
+ subroutine relay_cs (n, s, present_s)
+ integer, intent(in) :: n
+ character(len=n), optional :: s
+ logical, intent(in) :: present_s
+ call take_cs (s, present_s)
+ end subroutine relay_cs
+
+ subroutine relay_ca (s, present_s)
+ character(len=*), optional :: s(:)
+ logical, intent(in) :: present_s
+ call take_ca (s, present_s)
+ end subroutine relay_ca
+
+ subroutine relay_dt (x, present_x)
+ type(dt), optional :: x(:)
+ logical, intent(in) :: present_x
+ call take_dt (x, present_x)
+ end subroutine relay_dt
+
+ ! An optional VALUE dummy relayed on to another optional VALUE dummy.
+
+ subroutine relay_asv (x, present_x)
+ integer, value, optional :: x(:)
+ logical, intent(in) :: present_x
+ call take_as (x, present_x)
+ end subroutine relay_asv
+
+ subroutine relay_csv (n, s, present_s)
+ integer, intent(in) :: n
+ character(len=n), value, optional :: s
+ logical, intent(in) :: present_s
+ call take_cs (s, present_s)
+ end subroutine relay_csv
+
+end module m
+
+program test
+ use m
+ implicit none
+ integer :: v(3), i
+ character(len=7) :: s
+ character(len=2) :: a(2)
+ type(dt) :: w(2)
+
+ v = [1, 2, 3]
+ s = 'payload'
+ a = ['ab', 'cd']
+ do i = 1, 2
+ allocate (w(i)%d(2), source=[i, i])
+ end do
+
+ ! Directly, with and without the actual argument.
+ call take_as (v, .true.)
+ call take_as (present_x = .false.)
+ call take_es (3, v, .true.)
+ call take_es (3, present_x = .false.)
+ call take_cs (s, .true.)
+ call take_cs (present_s = .false.)
+ call take_ca (a, .true.)
+ call take_ca (present_s = .false.)
+ call take_dt (w, .true.)
+ call take_dt (present_x = .false.)
+
+ ! Relayed through an optional dummy.
+ call relay_as (v, .true.)
+ call relay_as (present_x = .false.)
+ call relay_es (3, v, .true.)
+ call relay_es (3, present_x = .false.)
+ call relay_cs (7, s, .true.)
+ call relay_cs (7, present_s = .false.)
+ call relay_ca (a, .true.)
+ call relay_ca (present_s = .false.)
+ call relay_dt (w, .true.)
+ call relay_dt (present_x = .false.)
+
+ ! Relayed through an optional VALUE dummy.
+ call relay_asv (v, .true.)
+ call relay_asv (present_x = .false.)
+ call relay_csv (7, s, .true.)
+ call relay_csv (7, present_s = .false.)
+
+ ! None of the copies may write back to the actual arguments.
+ if (any (v /= [1, 2, 3])) stop 16
+ if (s /= 'payload') stop 17
+ if (any (a /= ['ab', 'cd'])) stop 18
+ if (any (w(1)%d /= [1, 1])) stop 23
+ if (any (w(2)%d /= [2, 2])) stop 24
+end program test
--
2.55.0
