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, &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 index 00000000000..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, 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