diff --git a/flang/include/flang/Evaluate/common.h b/flang/include/flang/Evaluate/common.h --- a/flang/include/flang/Evaluate/common.h +++ b/flang/include/flang/Evaluate/common.h @@ -19,6 +19,7 @@ #include "flang/Parser/message.h" #include #include +#include namespace Fortran::semantics { class DerivedTypeSpec; @@ -45,6 +46,26 @@ } } +template +static constexpr Ordering Compare( + const std::basic_string &x, const std::basic_string &y) { + std::size_t xLen{x.size()}, yLen{y.size()}; + using String = std::basic_string; + // Fortran CHARACTER comparison is defined with blank padding + // to extend a shorter operand. + if (xLen < yLen) { + return Compare(String{x}.append(yLen - xLen, CH{' '}), y); + } else if (xLen > yLen) { + return Compare(x, String{y}.append(xLen - yLen, CH{' '})); + } else if (x < y) { + return Ordering::Less; + } else if (x > y) { + return Ordering::Greater; + } else { + return Ordering::Equal; + } +} + static constexpr Ordering Reverse(Ordering ordering) { if (ordering == Ordering::Less) { return Ordering::Greater; diff --git a/flang/include/flang/Evaluate/type.h b/flang/include/flang/Evaluate/type.h --- a/flang/include/flang/Evaluate/type.h +++ b/flang/include/flang/Evaluate/type.h @@ -52,6 +52,7 @@ using CInteger = Type; using LogicalResult = Type; using LargestReal = Type; +using Ascii = Type; // A predicate that is true when a kind value is a kind that could possibly // be supported for an intrinsic type category on some target instruction diff --git a/flang/lib/Evaluate/fold-logical.cpp b/flang/lib/Evaluate/fold-logical.cpp --- a/flang/lib/Evaluate/fold-logical.cpp +++ b/flang/lib/Evaluate/fold-logical.cpp @@ -106,6 +106,20 @@ } } } + } else if (name == "lge" || name == "lgt" || name == "lle" || name == "llt") { + // Rewrite LGE/LGT/LLE/LLT into ASCII character relations + auto *cx0{UnwrapExpr>(args[0])}; + auto *cx1{UnwrapExpr>(args[1])}; + if (cx0 && cx1) { + return Fold(context, + ConvertToType( + PackageRelation(name == "lge" ? RelationalOperator::GE + : name == "lgt" ? RelationalOperator::GT + : name == "lle" ? RelationalOperator::LE + : RelationalOperator::LT, + ConvertToType(std::move(*cx0)), + ConvertToType(std::move(*cx1))))); + } } else if (name == "logical") { if (auto *expr{UnwrapExpr>(args[0])}) { return Fold(context, ConvertToType(std::move(*expr))); @@ -126,7 +140,7 @@ return Expr{true}; } // TODO: btest, dot_product, is_iostat_end, - // is_iostat_eor, lge, lgt, lle, llt, logical, matmul, out_of_range, + // is_iostat_eor, logical, matmul, out_of_range, // parity, transfer return Expr{std::move(funcRef)}; } diff --git a/flang/lib/Semantics/check-io.h b/flang/lib/Semantics/check-io.h --- a/flang/lib/Semantics/check-io.h +++ b/flang/lib/Semantics/check-io.h @@ -86,8 +86,7 @@ StatusReplace, StatusScratch, DataList) template std::optional GetConstExpr(const T &x) { - using DefaultCharConstantType = - evaluate::Type; + using DefaultCharConstantType = evaluate::Ascii; if (const SomeExpr * expr{GetExpr(x)}) { const auto foldExpr{ evaluate::Fold(context_.foldingContext(), common::Clone(*expr))}; diff --git a/flang/lib/Semantics/data-to-inits.cpp b/flang/lib/Semantics/data-to-inits.cpp --- a/flang/lib/Semantics/data-to-inits.cpp +++ b/flang/lib/Semantics/data-to-inits.cpp @@ -234,8 +234,8 @@ if (auto converted{evaluate::ConvertToType(type, SomeExpr{expr})}) { return {std::make_pair(std::move(*converted), false)}; } - if (std::optional chValue{evaluate::GetScalarConstantValue< - evaluate::Type>(expr)}) { + if (std::optional chValue{ + evaluate::GetScalarConstantValue(expr)}) { // Allow DATA initialization with Hollerith and kind=1 CHARACTER like // (most) other Fortran compilers do. Pad on the right with spaces // when short, truncate the right if long. diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -1576,8 +1576,8 @@ if (!attrs_ || !attrs_->test(Attr::BIND_C)) { return; } - std::optional label{evaluate::GetScalarConstantValue< - evaluate::Type>(bindName_)}; + std::optional label{ + evaluate::GetScalarConstantValue(bindName_)}; // 18.9.2(2): discard leading and trailing blanks, ignore if all blank if (label) { auto first{label->find_first_not_of(" ")}; diff --git a/flang/lib/Semantics/runtime-type-info.cpp b/flang/lib/Semantics/runtime-type-info.cpp --- a/flang/lib/Semantics/runtime-type-info.cpp +++ b/flang/lib/Semantics/runtime-type-info.cpp @@ -637,7 +637,7 @@ object.set_type(scope.MakeCharacterType( ParamValue{len, common::TypeParamAttr::Len}, KindExpr{1})); } - using Ascii = evaluate::Type; + using evaluate::Ascii; using AsciiExpr = evaluate::Expr; object.set_init(evaluate::AsGenericExpr(AsciiExpr{name})); Symbol &symbol{*scope diff --git a/flang/test/Evaluate/fold-char-cmp.f90 b/flang/test/Evaluate/fold-char-cmp.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Evaluate/fold-char-cmp.f90 @@ -0,0 +1,17 @@ +! RUN: %python %S/test_folding.py %s %flang_fc1 +! Tests folding of character comparisons +module m1 + logical, parameter :: cases(*) = & + [ "" == "", "" == " " & + , "aaa" == "aaa", "aaa" == "aaa ", "aaa" /= "aab" & + , "aaa" <= "aaa", .not. "aaa" < "aaa", "aaa" < "aab", "aaa" >= "aaa" & + , .not. "aaa" > "aaa", .not. "aaa" >= "aab" & + , 4_"aaa" == 4_"aaa", 4_"aaa" == 4_"aaa ", 4_"aaa" /= 4_"aab" & + , 4_"aaa" <= 4_"aaa", .not. 4_"aaa" < 4_"aaa", 4_"aaa" < 4_"aab", 4_"aaa" >= 4_"aaa" & + , .not. 4_"aaa" > 4_"aaa", .not. 4_"aaa" >= 4_"aab" & + , lle("aaa", "aaa"), .not. llt("aaa", "aaa"), llt("aaa", "aab"), lge("aaa", "aaa") & + , .not. lgt("aaa", "aaa"), .not. lge("aaa", "aab") & + , lle("", ""), .not. llt("", ""), lge("", ""), .not. lgt("", "") & + ] + logical, parameter :: test_cases = all(cases) +end module diff --git a/flang/test/Evaluate/folding01.f90 b/flang/test/Evaluate/folding01.f90 --- a/flang/test/Evaluate/folding01.f90 +++ b/flang/test/Evaluate/folding01.f90 @@ -123,9 +123,7 @@ character(len(c3)), parameter :: exp_min = c1 character(len(c3)), parameter :: exp_max = c4 logical, parameter :: test_max_c_1 = res_max_c.EQ.exp_max - logical, parameter :: test_max_c_2 = res_max_c.NE.c4 logical, parameter :: test_max_c_3 = len(res_max_c).EQ.len(c3) - logical, parameter :: test_min_c_1 = res_min_c.NE.c1 logical, parameter :: test_min_c_2 = res_min_c.EQ.exp_min logical, parameter :: test_min_c_3 = len(res_min_c).EQ.len(c3) @@ -137,5 +135,5 @@ logical, parameter :: test_not_zero = not(0).EQ.-1 logical, parameter :: test_not_neg_one = not(-1).EQ.0 logical, parameter :: test_not_array = all(not([5, 6, 7]).EQ.[-6, -7, -8]) - + end module diff --git a/flang/test/Evaluate/folding05.f90 b/flang/test/Evaluate/folding05.f90 index 0000000000000000000000000000000000000000..0000000000000000000000000000000000000000 GIT binary patch literal 0 Hc$@