From 8ee6b564fca20862b9da55a5fe1e8f90f82bd317 Mon Sep 17 00:00:00 2001 From: Yuao Ma Date: Sun, 26 Oct 2025 14:50:28 +0800 Subject: [PATCH] fortran: support .NIL. in conditional arguments TBD gcc/fortran/ChangeLog: * dump-parse-tree.cc (show_expr): * expr.cc (gfc_conditional_expr_with_nil): (simplify_conditional): * gfortran.h (gfc_conditional_expr_with_nil): * interface.cc (gfc_compare_actual_formal): * matchexp.cc (match_conditional): * resolve.cc (resolve_conditional): (gfc_resolve_expr): * trans-array.cc (gfc_walk_conditional_expr): * trans-expr.cc (gfc_conv_conditional_expr): (conv_dummy_value): gcc/testsuite/ChangeLog: * gfortran.dg/conditional_10.f90: New test. * gfortran.dg/conditional_11.f90: New test. * gfortran.dg/conditional_12.f90: New test. --- gcc/fortran/dump-parse-tree.cc | 19 ++++--- gcc/fortran/expr.cc | 17 +++++- gcc/fortran/gfortran.h | 2 +- gcc/fortran/interface.cc | 10 ++++ gcc/fortran/matchexp.cc | 30 +++++++---- gcc/fortran/resolve.cc | 54 +++++++++++++++++--- gcc/fortran/trans-array.cc | 3 ++ gcc/fortran/trans-expr.cc | 19 +++++-- gcc/testsuite/gfortran.dg/conditional_10.f90 | 28 ++++++++++ gcc/testsuite/gfortran.dg/conditional_11.f90 | 22 ++++++++ gcc/testsuite/gfortran.dg/conditional_12.f90 | 33 ++++++++++++ 11 files changed, 208 insertions(+), 29 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/conditional_10.f90 create mode 100644 gcc/testsuite/gfortran.dg/conditional_11.f90 create mode 100644 gcc/testsuite/gfortran.dg/conditional_12.f90 diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc index eda0659d6e2..17d821a0f61 100644 --- a/gcc/fortran/dump-parse-tree.cc +++ b/gcc/fortran/dump-parse-tree.cc @@ -768,13 +768,18 @@ show_expr (gfc_expr *p) break; case EXPR_CONDITIONAL: - fputc ('(', dumpfile); - show_expr (p->value.conditional.condition); - fputs (" ? ", dumpfile); - show_expr (p->value.conditional.true_expr); - fputs (" : ", dumpfile); - show_expr (p->value.conditional.false_expr); - fputc (')', dumpfile); + if (!p->value.conditional.condition) + fputs (".NIL.", dumpfile); + else + { + fputc ('(', dumpfile); + show_expr (p->value.conditional.condition); + fputs (" ? ", dumpfile); + show_expr (p->value.conditional.true_expr); + fputs (" : ", dumpfile); + show_expr (p->value.conditional.false_expr); + fputc (')', dumpfile); + } break; case EXPR_COMPCALL: diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index a11ff79ab6b..d910712ebf4 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -136,6 +136,21 @@ gfc_get_conditional_expr (locus *where, gfc_expr *condition, return e; } +/* Check whether the conditional expression contains .NIL. + (or is .NIL. itself). */ + +bool +gfc_conditional_expr_with_nil (gfc_expr *e) +{ + gcc_assert (e != nullptr); + if (e->expr_type != EXPR_CONDITIONAL) + return false; + if (e->value.conditional.condition == nullptr) + return true; + return gfc_conditional_expr_with_nil (e->value.conditional.true_expr) + || gfc_conditional_expr_with_nil (e->value.conditional.false_expr); +} + /* Get a new expression node that is an structure constructor of given type and kind. */ @@ -1409,7 +1424,7 @@ simplify_conditional (gfc_expr *p, int type) || !gfc_simplify_expr (false_expr, type)) return false; - if (!gfc_is_constant_expr (condition)) + if (!condition /* is .NIL. */ || !gfc_is_constant_expr (condition)) return true; p->value.conditional.condition = NULL; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 19473dfa791..e0be48e08a2 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3969,7 +3969,7 @@ gfc_expr *gfc_copy_expr (gfc_expr *); gfc_ref* gfc_copy_ref (gfc_ref*); bool gfc_specification_expr (gfc_expr *); - +bool gfc_conditional_expr_with_nil (gfc_expr *); bool gfc_numeric_ts (gfc_typespec *); int gfc_kind_max (gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc index ef5a17d0af4..e6a2b44e16c 100644 --- a/gcc/fortran/interface.cc +++ b/gcc/fortran/interface.cc @@ -3547,6 +3547,16 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, goto match; } + if (a->expr->expr_type == EXPR_CONDITIONAL + && gfc_conditional_expr_with_nil (a->expr) && !optional_dummy) + { + gfc_error ("As the dummy argument is not optional, .NIL. at %L shall " + "not appear", + &a->expr->where); + ok = false; + goto match; + } + if (!compare_parameter (f->sym, a->expr, ranks_must_agree, is_elemental, where)) { diff --git a/gcc/fortran/matchexp.cc b/gcc/fortran/matchexp.cc index e3a99253841..d7b25f95666 100644 --- a/gcc/fortran/matchexp.cc +++ b/gcc/fortran/matchexp.cc @@ -170,11 +170,17 @@ match_conditional (gfc_expr **result) } gfc_gobble_whitespace (); - m = gfc_match_expr (&true_expr); - if (m != MATCH_YES) + where = gfc_current_locus; + if ((m = gfc_match (" .nil. ")) == MATCH_YES) + true_expr = gfc_get_conditional_expr (&where, nullptr, nullptr, nullptr); + else { - gfc_free_expr (condition); - return m; + m = gfc_match_expr (&true_expr); + if (m != MATCH_YES) + { + gfc_free_expr (condition); + return m; + } } m = gfc_match_char (':'); @@ -186,12 +192,18 @@ match_conditional (gfc_expr **result) return MATCH_ERROR; } - m = match_conditional (&false_expr); - if (m != MATCH_YES) + where = gfc_current_locus; + if ((m = gfc_match (" .nil. ")) == MATCH_YES) + false_expr = gfc_get_conditional_expr (&where, nullptr, nullptr, nullptr); + else { - gfc_free_expr (condition); - gfc_free_expr (true_expr); - return m; + m = match_conditional (&false_expr); + if (m != MATCH_YES) + { + gfc_free_expr (condition); + gfc_free_expr (true_expr); + return m; + } } *result = gfc_get_conditional_expr (&where, condition, true_expr, false_expr); diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 1c49ccf4711..7bc1d584f18 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -5017,15 +5017,54 @@ static bool resolve_conditional (gfc_expr *expr) { gfc_expr *condition, *true_expr, *false_expr; + bool true_expr_is_nil, false_expr_is_nil; + gfc_typespec non_nil_ts; + int non_nil_rank; condition = expr->value.conditional.condition; true_expr = expr->value.conditional.true_expr; false_expr = expr->value.conditional.false_expr; + if (!condition) + { + if (actual_arg) + return true; + else + { + gfc_error (".NIL. at %L is only valid in conditional arguments", + &expr->where); + return false; + } + } + if (!gfc_resolve_expr (condition) || !gfc_resolve_expr (true_expr) || !gfc_resolve_expr (false_expr)) return false; + true_expr_is_nil = true_expr->expr_type == EXPR_CONDITIONAL + && true_expr->value.conditional.condition == nullptr; + false_expr_is_nil = false_expr->expr_type == EXPR_CONDITIONAL + && false_expr->value.conditional.condition == nullptr; + non_nil_ts = false_expr_is_nil ? true_expr->ts : false_expr->ts; + non_nil_rank = false_expr_is_nil ? true_expr->rank : false_expr->rank; + + if (true_expr_is_nil && false_expr_is_nil) + { + gfc_error ("Both operands of the conditional argument at %L are .NIL.", + &expr->where); + return false; + } + else if (true_expr_is_nil && !false_expr_is_nil) + { + true_expr->ts = non_nil_ts; + true_expr->rank = non_nil_rank; + } + else if (!true_expr_is_nil && false_expr_is_nil) + { + false_expr->ts = non_nil_ts; + false_expr->rank = non_nil_rank; + } + if (condition->ts.type != BT_LOGICAL || condition->rank != 0) { gfc_error ( @@ -5059,9 +5098,9 @@ resolve_conditional (gfc_expr *expr) } /* TODO: support more data types for conditional expressions */ - if (true_expr->ts.type != BT_INTEGER && true_expr->ts.type != BT_LOGICAL - && true_expr->ts.type != BT_REAL && true_expr->ts.type != BT_COMPLEX - && true_expr->ts.type != BT_CHARACTER) + if (non_nil_ts.type != BT_INTEGER && non_nil_ts.type != BT_LOGICAL + && non_nil_ts.type != BT_REAL && non_nil_ts.type != BT_COMPLEX + && non_nil_ts.type != BT_CHARACTER) { gfc_error ( "Sorry, only integer, logical, real, complex and character types are " @@ -5071,7 +5110,7 @@ resolve_conditional (gfc_expr *expr) } /* TODO: support arrays in conditional expressions */ - if (true_expr->rank > 0) + if (non_nil_rank > 0) { gfc_error ("Sorry, array is currently unsupported for conditional " "expressions at %L", @@ -5079,8 +5118,8 @@ resolve_conditional (gfc_expr *expr) return false; } - expr->ts = true_expr->ts; - expr->rank = true_expr->rank; + expr->ts = non_nil_ts; + expr->rank = non_nil_rank; return true; } @@ -8113,7 +8152,8 @@ gfc_resolve_expr (gfc_expr *e) actual_arg_save = actual_arg; first_actual_arg_save = first_actual_arg; - if (e->expr_type != EXPR_VARIABLE) + if (e->expr_type != EXPR_VARIABLE + && e->expr_type != EXPR_CONDITIONAL /* not .NIL. */) { inquiry_argument = false; actual_arg = false; diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index e2b17a725be..b7ba2ee56ce 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -12770,6 +12770,9 @@ gfc_walk_conditional_expr (gfc_ss *ss, gfc_expr *expr) { gfc_ss *head; + if (!expr->value.conditional.condition) + return gfc_ss_terminator; + head = gfc_walk_subexpr (ss, expr->value.conditional.true_expr); head = gfc_walk_subexpr (head, expr->value.conditional.false_expr); return head; diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 67b60c78aa7..dd908963d14 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -4375,6 +4375,17 @@ gfc_conv_conditional_expr (gfc_se *se, gfc_expr *expr) tree condition, true_val, false_val; tree type; + /* Handle .NIL. */ + if (!expr->value.conditional.condition) + { + if (se->want_pointer || expr->ts.type == BT_CHARACTER) + se->expr = null_pointer_node; + else + se->expr = integer_zero_node; + se->string_length = build_int_cst (gfc_charlen_type_node, 0); + return; + } + gfc_init_se (&cond_se, se); gfc_init_se (&true_se, se); gfc_init_se (&false_se, se); @@ -6688,16 +6699,16 @@ conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym, { /* F2018:15.5.2.12 Argument presence and restrictions on arguments not present. */ - if (e->expr_type == EXPR_VARIABLE - && e->rank == 0 - && (gfc_expr_attr (e).allocatable - || gfc_expr_attr (e).pointer)) + if ((e->expr_type == EXPR_VARIABLE && e->rank == 0 + && (gfc_expr_attr (e).allocatable || gfc_expr_attr (e).pointer)) + || e->expr_type == EXPR_CONDITIONAL) { gfc_se argse; tree cond; gfc_init_se (&argse, NULL); argse.want_pointer = 1; gfc_conv_expr (&argse, e); + gfc_add_block_to_block (&parmse->pre, &argse.pre); cond = fold_convert (TREE_TYPE (argse.expr), null_pointer_node); cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, diff --git a/gcc/testsuite/gfortran.dg/conditional_10.f90 b/gcc/testsuite/gfortran.dg/conditional_10.f90 new file mode 100644 index 00000000000..2ff092ba2ad --- /dev/null +++ b/gcc/testsuite/gfortran.dg/conditional_10.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! { dg-options "-std=f2023" } +program conditional_nil + implicit none + integer :: a = 4 + integer :: b = 6 + logical :: c = .true. + + call five((a < 5 ? a : .NIL.)) + if (a /= 5) stop 1 + a = 42 + call five((a == 42 ? .NIL. : a)) + if (a /= 42) stop 2 + a = 42 + call five((a /= 42 ? .NIL. : b > 5 ? b : .NIL.)) + if (b /= 5) stop 3 + call sub((c ? "123" : .NIL.)) +contains + subroutine five(x) + integer, optional :: x + if (present(x)) then + x = 5 + end if + end subroutine five + subroutine sub(x) + character(*), optional :: x + end subroutine sub +end program conditional_nil diff --git a/gcc/testsuite/gfortran.dg/conditional_11.f90 b/gcc/testsuite/gfortran.dg/conditional_11.f90 new file mode 100644 index 00000000000..cda10d8608c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/conditional_11.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-std=f2023" } +program conditional_nil_resolve + implicit none + integer :: i = 42 + + i = (i > 0 ? 1 : .nil.) ! { dg-error "is only valid in conditional arguments" } + call five_with_nil((i > 0 ? .nil. : .nil.)) ! { dg-error "Both operands of the conditional argument at" } + call five((i < 5 ? i : i > 43 ? i : .nil.)) ! { dg-error "As the dummy argument is not optional, .NIL. at" } + call five(1 + (i < 5 ? 1 : .nil.)) ! { dg-error "is only valid in conditional arguments" } +contains + subroutine five(x) + integer :: x + x = 5 + end subroutine five + subroutine five_with_nil(x) + integer, optional :: x + if (present(x)) then + x = 5 + end if + end subroutine five_with_nil +end program conditional_nil_resolve diff --git a/gcc/testsuite/gfortran.dg/conditional_12.f90 b/gcc/testsuite/gfortran.dg/conditional_12.f90 new file mode 100644 index 00000000000..931085a8441 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/conditional_12.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! { dg-options "-std=f2023" } +module m +implicit none +contains + subroutine sub(expected, x) + logical, value :: expected + integer, value, optional :: x + if (expected .neqv. present(x)) error stop + end + + subroutine sub_str(l, x) + integer, value :: l + character, value, optional :: x + if (present(x)) then + if (l /= LEN(x)) error stop + end if + end + + subroutine test + logical :: cc + cc = .true. + call sub(.true., (cc ? 1 : .nil.)) + cc = .false. + call sub(.false., (cc ? 1 : .nil.)) + cc = .true. + call sub_str(1, (cc ? "abc" : .nil.)) + end +end + +use m +call test +end -- 2.43.0