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.

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 1b8be081a17d5417738915aaca712e779b264cfa..50c4604a025ec52e1f98a46eb253f4467892e967 100644 (file)
--- 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.  */
+
+static 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
                          {

diff --git a/gcc/testsuite/gfortran.dg/value_optional_1.f90 b/gcc/testsuite/gfortran.dg/value_optional_1.f90
new file mode 100644 (file)
index 0000000..2f95316
--- /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, 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