https://gcc.gnu.org/g:2c1949bf152f8fcadb0ef7a44113c41d18724691
commit r16-4474-g2c1949bf152f8fcadb0ef7a44113c41d18724691 Author: Yuao Ma <[email protected]> Date: Thu Oct 16 22:32:52 2025 +0800 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_string_parameter): Handle COND_EXPR tree code. gcc/testsuite/ChangeLog: * gfortran.dg/conditional_1.f90: Test character type. * gfortran.dg/conditional_2.f90: Test print constants. * gfortran.dg/conditional_4.f90: Test diagnostic message. * gfortran.dg/conditional_6.f90: Test character cond-arg. Diff: --- gcc/fortran/resolve.cc | 11 +++++++---- gcc/fortran/trans-const.cc | 8 ++++++++ gcc/fortran/trans-expr.cc | 28 ++++++++++++++++++++++++++++ gcc/testsuite/gfortran.dg/conditional_1.f90 | 14 ++++++++++++++ gcc/testsuite/gfortran.dg/conditional_2.f90 | 2 ++ gcc/testsuite/gfortran.dg/conditional_4.f90 | 6 +++++- gcc/testsuite/gfortran.dg/conditional_6.f90 | 23 +++++++++++++++++++++++ 7 files changed, 87 insertions(+), 5 deletions(-) diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index f419f5c7559f..1c49ccf47111 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -5060,14 +5060,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 arrays in 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 ea1501a4d540..f70f36284a38 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_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 271d2633dfba..21f256b280f4 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. */ @@ -11546,6 +11551,29 @@ gfc_conv_string_parameter (gfc_se * se) return; } + if (TREE_CODE (se->expr) == COND_EXPR) + { + tree cond = TREE_OPERAND (se->expr, 0); + tree lhs = TREE_OPERAND (se->expr, 1); + tree rhs = TREE_OPERAND (se->expr, 2); + + gfc_se lse, rse; + gfc_init_se (&lse, NULL); + gfc_init_se (&rse, NULL); + + lse.expr = lhs; + lse.string_length = se->string_length; + gfc_conv_string_parameter (&lse); + + rse.expr = rhs; + rse.string_length = se->string_length; + gfc_conv_string_parameter (&rse); + + se->expr + = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (lse.expr), + cond, lse.expr, rse.expr); + } + if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE) && TYPE_STRING_FLAG (TREE_TYPE (se->expr))) diff --git a/gcc/testsuite/gfortran.dg/conditional_1.f90 b/gcc/testsuite/gfortran.dg/conditional_1.f90 index ca7d21db1a7d..9fd442a73cc6 100644 --- a/gcc/testsuite/gfortran.dg/conditional_1.f90 +++ b/gcc/testsuite/gfortran.dg/conditional_1.f90 @@ -6,6 +6,8 @@ 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" + character(len=:), allocatable :: c3 i = (i > 0 ? 1 : -1) if (i /= 1) stop 1 @@ -29,4 +31,16 @@ 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 + + i = 0 + c1 = (i /= 0 ? "abcde" : "bcdef") + if (c1 /= "bcdef") stop 8 + + i = 0 + c3 = (i /= 0 ? "abcde" : c2(1:3)) + if (c3 /= "wor") stop 9 end program conditional_simple diff --git a/gcc/testsuite/gfortran.dg/conditional_2.f90 b/gcc/testsuite/gfortran.dg/conditional_2.f90 index e78cd0841543..c45b06521436 100644 --- a/gcc/testsuite/gfortran.dg/conditional_2.f90 +++ b/gcc/testsuite/gfortran.dg/conditional_2.f90 @@ -4,6 +4,8 @@ program conditional_constant implicit none integer :: i = 42 + print *, (.true. ? 1 : -1) + print *, (.false. ? "hello" : "world") i = (.true. ? 1 : -1) if (i /= 1) stop 1 diff --git a/gcc/testsuite/gfortran.dg/conditional_4.f90 b/gcc/testsuite/gfortran.dg/conditional_4.f90 index 38033b9ec1de..5ecf9e0633aa 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 c9ac7132c45f..931f11c64597 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
