Dear all,
I've dusted off and cleaned up a previous attempt to fix the handling
of allocatable or pointer actual arguments to OPTIONAL+VALUE dummies.
The standard says that a non-allocated / non-associated actual argument
in that case shall be treated as non-present.
However, gfortran's calling conventions demand that the presence status
for OPTIONAL+VALUE is passed as a hidden argument, while we need to
pass something on the stack which has the right type. The solution
is to conditionally create a temporary when needed.
Testcase checked with NAG.
Regtested on x86_64-pc-linux-gnu. OK for mainline?
Thanks,
Harald
From 6927612d97a8e7360e651bb081745fc7659a4c4b Mon Sep 17 00:00:00 2001
From: Harald Anlauf
Date: Wed, 1 Nov 2023 22:55:36 +0100
Subject: [PATCH] Fortran: passing of allocatable/pointer arguments to
OPTIONAL+VALUE [PR92887]
gcc/fortran/ChangeLog:
PR fortran/92887
* trans-expr.cc (conv_cond_temp): Helper function for creation of a
conditional temporary.
(gfc_conv_procedure_call): Handle passing of allocatable or pointer
actual argument to dummy with OPTIONAL + VALUE attribute. Actual
arguments that are not allocated or associated are treated as not
present.
gcc/testsuite/ChangeLog:
PR fortran/92887
* gfortran.dg/value_optional_1.f90: New test.
---
gcc/fortran/trans-expr.cc | 50 ++-
.../gfortran.dg/value_optional_1.f90 | 83 +++
2 files changed, 130 insertions(+), 3 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/value_optional_1.f90
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 1b8be081a17..1c06ecb3c28 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6030,6 +6030,28 @@ post_call:
}
+/* Create "conditional temporary" to handle scalar dummy variables with the
+ OPTIONAL+VALUE attribute that shall not be dereferenced. Use null value
+ as fallback. Only instances of intrinsic basic type are supported. */
+
+void
+conv_cond_temp (gfc_se * parmse, gfc_expr * e, tree cond)
+{
+ tree temp;
+ gcc_assert (e->ts.type != BT_DERIVED && e->ts.type != BT_CLASS);
+ gcc_assert (e->rank == 0);
+ temp = gfc_create_var (TREE_TYPE (parmse->expr), "condtemp");
+ TREE_STATIC (temp) = 1;
+ TREE_CONSTANT (temp) = 1;
+ TREE_READONLY (temp) = 1;
+ DECL_INITIAL (temp) = build_zero_cst (TREE_TYPE (temp));
+ parmse->expr = fold_build3_loc (input_location, COND_EXPR,
+ TREE_TYPE (parmse->expr),
+ cond, parmse->expr, temp);
+ parmse->expr = gfc_evaluate_now (parmse->expr, >pre);
+}
+
+
/* 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.
@@ -6470,9 +6492,31 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& fsym->ts.type != BT_CLASS
&& fsym->ts.type != BT_DERIVED)
{
- if (e->expr_type != EXPR_VARIABLE
- || !e->symtree->n.sym->attr.optional
- || e->ref != NULL)
+ /* F2018:15.5.2.12 Argument presence and
+ restrictions on arguments not present. */
+ if (e->expr_type == EXPR_VARIABLE
+ && (gfc_expr_attr (e).allocatable
+|| gfc_expr_attr (e).pointer))
+ {
+ gfc_se argse;
+ tree cond;
+ gfc_init_se (, NULL);
+ argse.want_pointer = 1;
+ gfc_conv_expr (, e);
+ cond = fold_convert (TREE_TYPE (argse.expr),
+ null_pointer_node);
+ cond = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node,
+ argse.expr, cond);
+ vec_safe_push (optionalargs,
+ fold_convert (boolean_type_node,
+ cond));
+ /* Create "conditional temporary". */
+ conv_cond_temp (, e, cond);
+ }
+ else if (e->expr_type != EXPR_VARIABLE
+ || !e->symtree->n.sym->attr.optional
+ || e->ref != NULL)
vec_safe_push (optionalargs, boolean_true_node);
else
{
diff --git a/gcc/testsuite/gfortran.dg/value_optional_1.f90 b/gcc/testsuite/gfortran.dg/value_optional_1.f90
new file mode 100644
index 000..2f95316de52
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/value_optional_1.f90
@@ -0,0 +1,83 @@
+! { dg-do run }
+! PR fortran/92887
+!
+! Test passing nullified/disassociated pointer or unalloc allocatable
+! to OPTIONAL + VALUE
+
+program p
+ implicit none !(type, external)
+ integer, allocatable :: aa
+ real, pointer :: pp
+ character,allocatable :: ca
+ character,pointer :: cp
+ complex, allocatable :: za
+ complex, pointer :: zp
+ type t
+ integer, allocatable :: aa
+ real, pointer :: pp => NULL()
+ complex, allocatable :: za
+ end type t
+ type(t) :: tt
+ nullify (pp, cp, zp)
+ call sub (aa, pp, ca, cp, za)
+ call sub (tt% aa, t