From 7e22c80b221cbd56f7ae8ad26e15fe0db6d53385 Mon Sep 17 00:00:00 2001 From: Yuao Ma Date: Wed, 17 Sep 2025 22:28:17 +0800 Subject: [PATCH] fortran: allow character in conditional expression This patch allows the use of character types in conditional expressions. gcc/fortran/ChangeLog: * resolve.cc (resolve_conditional): Allow character in cond-expr. * trans-const.cc (gfc_conv_constant): Handle want_pointer. * trans-expr.cc (gfc_conv_conditional_expr): Fill se->string_length. (gfc_conv_expr_reference): Handle cond-expr before character type. gcc/testsuite/ChangeLog: * gfortran.dg/conditional_1.f90: Test character type. * gfortran.dg/conditional_4.f90: Test diagnostic message. * gfortran.dg/conditional_6.f90: Test character cond-arg. --- gcc/fortran/resolve.cc | 11 ++++++---- gcc/fortran/trans-const.cc | 8 +++++++ gcc/fortran/trans-expr.cc | 19 ++++++++++------- gcc/testsuite/gfortran.dg/conditional_1.f90 | 5 +++++ gcc/testsuite/gfortran.dg/conditional_4.f90 | 6 +++++- gcc/testsuite/gfortran.dg/conditional_6.f90 | 23 +++++++++++++++++++++ 6 files changed, 60 insertions(+), 12 deletions(-) diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index b83961fe6f1..a6f36dcd6f1 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -5036,14 +5036,17 @@ 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_REAL && true_expr->ts.type != BT_COMPLEX + && true_expr->ts.type != BT_CHARACTER) { - gfc_error ("Sorry, only integer, logical, real and complex types " - "are currently supported for conditional expressions at %L", - &expr->where); + gfc_error ( + "Sorry, only integer, logical, real, complex and character types are " + "currently supported for conditional expressions at %L", + &expr->where); return false; } + /* TODO: support array for conditional expressions */ if (true_expr->rank > 0) { gfc_error ("Sorry, array is currently unsupported for conditional " diff --git a/gcc/fortran/trans-const.cc b/gcc/fortran/trans-const.cc index ea1501a4d54..54c9ac54f39 100644 --- a/gcc/fortran/trans-const.cc +++ b/gcc/fortran/trans-const.cc @@ -438,4 +438,12 @@ gfc_conv_constant (gfc_se * se, gfc_expr * expr) structure, too. */ if (expr->ts.type == BT_CHARACTER) se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr))); + + if (se->want_pointer) + { + if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr)) + gfc_conv_string_parameter (se); + else + se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); + } } diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 271d2633dfb..c8f84e43958 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -4418,6 +4418,11 @@ gfc_conv_conditional_expr (gfc_se *se, gfc_expr *expr) se->expr = fold_build3_loc (input_location, COND_EXPR, type, condition, true_val, false_val); + if (expr->ts.type == BT_CHARACTER) + se->string_length + = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node, + condition, true_se.string_length, + false_se.string_length); } /* If a string's length is one, we convert it to a single character. */ @@ -10649,6 +10654,13 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr) return; } + if (expr->expr_type == EXPR_CONDITIONAL) + { + se->want_pointer = 1; + gfc_conv_expr (se, expr); + return; + } + if (expr->ts.type == BT_CHARACTER) { gfc_conv_expr (se, expr); @@ -10670,13 +10682,6 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr) return; } - if (expr->expr_type == EXPR_CONDITIONAL) - { - se->want_pointer = 1; - gfc_conv_expr (se, expr); - return; - } - if (expr->expr_type == EXPR_FUNCTION && ((expr->value.function.esym && expr->value.function.esym->result diff --git a/gcc/testsuite/gfortran.dg/conditional_1.f90 b/gcc/testsuite/gfortran.dg/conditional_1.f90 index ca7d21db1a7..e5397be5604 100644 --- a/gcc/testsuite/gfortran.dg/conditional_1.f90 +++ b/gcc/testsuite/gfortran.dg/conditional_1.f90 @@ -6,6 +6,7 @@ program conditional_simple logical :: l = .true. real(4) :: r1 = 1.e-4, r2 = 1.e-5 complex :: z = (3.0, 4.0) + character(kind=1, len=5) :: c1 = "hello", c2 = "world" i = (i > 0 ? 1 : -1) if (i /= 1) stop 1 @@ -29,4 +30,8 @@ program conditional_simple i = 0 z = (i /= 0 ? z : (-3.0, -4.0)) if (z /= (-3.0, -4.0)) stop 6 + + i = 0 + c1 = (i /= 0 ? c1 : c2) + if (c1 /= "world") stop 7 end program conditional_simple diff --git a/gcc/testsuite/gfortran.dg/conditional_4.f90 b/gcc/testsuite/gfortran.dg/conditional_4.f90 index 38033b9ec1d..5ecf9e0633a 100644 --- a/gcc/testsuite/gfortran.dg/conditional_4.f90 +++ b/gcc/testsuite/gfortran.dg/conditional_4.f90 @@ -10,12 +10,16 @@ program conditional_resolve integer, dimension(1, 1) :: a_2d logical :: l1(2) integer :: i1(2) + type :: Point + real :: x = 0.0 + end type Point + type(Point) :: p1, p2 i = (l1 ? 1 : -1) ! { dg-error "Condition in conditional expression must be a scalar logical" } i = (i ? 1 : -1) ! { dg-error "Condition in conditional expression must be a scalar logical" } i = (i /= 0 ? 1 : "oh no") ! { dg-error "must have the same declared type" } i = (i /= 0 ? k1 : k4) ! { dg-error "must have the same kind parameter" } i = (i /= 0 ? a_1d : a_2d) ! { dg-error "must have the same rank" } - k1 = (i /= 0 ? k1 : k1) ! { dg-error "Sorry, only integer, logical, real and complex types are currently supported for conditional expressions" } + p1 = (i /= 0 ? p1 : p2) ! { dg-error "Sorry, only integer, logical, real, complex and character types are currently supported for conditional expressions" } i1 = (i /= 0 ? i1 : i1 + 1) ! { dg-error "Sorry, array is currently unsupported for conditional expressions" } end program conditional_resolve diff --git a/gcc/testsuite/gfortran.dg/conditional_6.f90 b/gcc/testsuite/gfortran.dg/conditional_6.f90 index c9ac7132c45..931f11c6459 100644 --- a/gcc/testsuite/gfortran.dg/conditional_6.f90 +++ b/gcc/testsuite/gfortran.dg/conditional_6.f90 @@ -4,8 +4,19 @@ program conditional_arg implicit none integer :: a = 4 integer :: b = 5 + character(kind=1, len=4) :: c4 = "abcd" + character(kind=1, len=5) :: c5 = "bcdef" + call five((a < 5 ? a : b)) if (a /= 5) stop 1 + + if (my_trim_len((b == 5 ? c4 : c5)) /= 4) stop 2 + if (my_trim_len((b == 5 ? "abcd" : "abcde")) /= 4) stop 3 + if (my_trim_len((b /= 5 ? c4 : c5)) /= 5) stop 4 + if (my_trim_len((b /= 5 ? "abcd" : "abcde")) /= 5) stop 5 + + call five_c((b == 5 ? c4 : c5)) + if (c4 /= "bcde") stop 6 contains subroutine five(x) integer, optional :: x @@ -13,4 +24,16 @@ contains x = 5 end if end subroutine five + + integer function my_trim_len(s) + character(len=*), intent(in) :: s + my_trim_len = len_trim(s) + end function my_trim_len + + subroutine five_c(x) + character(len=*), optional :: x + if (present(x)) then + x = c5 + end if + end subroutine five_c end program conditional_arg -- 2.43.0