From 6927612d97a8e7360e651bb081745fc7659a4c4b Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
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
@@ -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, &parmse->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 (&argse, NULL);
+ argse.want_pointer = 1;
+ gfc_conv_expr (&argse, 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 (&parmse, 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
{
new file mode 100644
@@ -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, tt% pp, z=tt% za)
+ allocate (aa, pp, ca, cp, za, zp, tt% za)
+ aa = 1; pp = 2.; ca = "c"; cp = "d"; za = 3.; zp = 4.; tt% za = 4.
+ call ref (1, 2., "c", "d", (3.,0.))
+ call ref (aa, pp, ca, cp, za)
+ call val (1, 2., "c", "d", (4.,0.))
+ call val (aa, pp, ca, cp, zp)
+ call opt (1, 2., "c", "d", (4.,0.))
+ call opt (aa, pp, ca, cp, tt% za)
+ deallocate (aa, pp, ca, cp, za, zp, tt% za)
+contains
+ subroutine sub (x, y, c, d, z)
+ integer, value, optional :: x
+ real, value, optional :: y
+ character, value, optional :: c, d
+ complex, value, optional :: z
+ if (present(x)) stop 1
+ if (present(y)) stop 2
+ if (present(c)) stop 3
+ if (present(d)) stop 4
+ if (present(z)) stop 5
+ end
+ ! call by reference
+ subroutine ref (x, y, c, d, z)
+ integer :: x
+ real :: y
+ character :: c, d
+ complex :: z
+ print *, "by reference :", x, y, c, d, z
+ if (x /= 1 .or. y /= 2.0) stop 11
+ if (c /= "c" .or. d /= "d") stop 12
+ if (z /= (3.,0.) ) stop 13
+ end
+ ! call by value
+ subroutine val (x, y, c, d, z)
+ integer, value :: x
+ real, value :: y
+ character, value :: c, d
+ complex, value :: z
+ print *, "by value :", x, y, c, d, z
+ if (x /= 1 .or. y /= 2.0) stop 21
+ if (c /= "c" .or. d /= "d") stop 22
+ if (z /= (4.,0.) ) stop 23
+ end
+ ! call by value, optional arguments
+ subroutine opt (x, y, c, d, z)
+ integer, value, optional :: x
+ real, value, optional :: y
+ character, value, optional :: c, d
+ complex, value, optional :: z
+ if (.not. present(x)) stop 31
+ if (.not. present(y)) stop 32
+ if (.not. present(c)) stop 33
+ if (.not. present(d)) stop 34
+ if (.not. present(z)) stop 35
+ print *, "value+optional:", x, y, c, d, z
+ if (x /= 1 .or. y /= 2.0) stop 36
+ if (c /= "c" .or. d /= "d") stop 37
+ if (z /= (4.,0.) ) stop 38
+ end
+end
--
2.35.3