[flang] Fold LGE/LGT/LLE/LLT intrinsic functions
Fold the legacy intrinsic functions LGE, LGT, LLE, & LLT
by rewriting them into character relational expressions and
then folding those. Also fix folding of comparisons of
character values of distinct lengths: the shorter value must
be padded with blanks. (This fix exposed some bad test cases,
which are also fixed.)
Differential Revision: https://reviews.llvm.org/D111843
GitOrigin-RevId: 6965a776ee192cb4c1a2618c270254fbf70879df
diff --git a/include/flang/Evaluate/common.h b/include/flang/Evaluate/common.h
index dd7cb96..e0e5cac 100644
--- a/include/flang/Evaluate/common.h
+++ b/include/flang/Evaluate/common.h
@@ -19,6 +19,7 @@
#include "flang/Parser/message.h"
#include <cinttypes>
#include <map>
+#include <string>
namespace Fortran::semantics {
class DerivedTypeSpec;
@@ -45,6 +46,26 @@
}
}
+template <typename CH>
+static constexpr Ordering Compare(
+ const std::basic_string<CH> &x, const std::basic_string<CH> &y) {
+ std::size_t xLen{x.size()}, yLen{y.size()};
+ using String = std::basic_string<CH>;
+ // 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/include/flang/Evaluate/type.h b/include/flang/Evaluate/type.h
index 23fc6ca..dcc0527 100644
--- a/include/flang/Evaluate/type.h
+++ b/include/flang/Evaluate/type.h
@@ -52,6 +52,7 @@
using CInteger = Type<TypeCategory::Integer, 4>;
using LogicalResult = Type<TypeCategory::Logical, 4>;
using LargestReal = Type<TypeCategory::Real, 16>;
+using Ascii = Type<TypeCategory::Character, 1>;
// 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/lib/Evaluate/fold-logical.cpp b/lib/Evaluate/fold-logical.cpp
index 1e11fec..586909d 100644
--- a/lib/Evaluate/fold-logical.cpp
+++ b/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<Expr<SomeCharacter>>(args[0])};
+ auto *cx1{UnwrapExpr<Expr<SomeCharacter>>(args[1])};
+ if (cx0 && cx1) {
+ return Fold(context,
+ ConvertToType<T>(
+ PackageRelation(name == "lge" ? RelationalOperator::GE
+ : name == "lgt" ? RelationalOperator::GT
+ : name == "lle" ? RelationalOperator::LE
+ : RelationalOperator::LT,
+ ConvertToType<Ascii>(std::move(*cx0)),
+ ConvertToType<Ascii>(std::move(*cx1)))));
+ }
} else if (name == "logical") {
if (auto *expr{UnwrapExpr<Expr<SomeLogical>>(args[0])}) {
return Fold(context, ConvertToType<T>(std::move(*expr)));
@@ -126,7 +140,7 @@
return Expr<T>{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<T>{std::move(funcRef)};
}
diff --git a/lib/Semantics/check-io.h b/lib/Semantics/check-io.h
index 01bbcd9..44c01e8 100644
--- a/lib/Semantics/check-io.h
+++ b/lib/Semantics/check-io.h
@@ -86,8 +86,7 @@
StatusReplace, StatusScratch, DataList)
template <typename R, typename T> std::optional<R> GetConstExpr(const T &x) {
- using DefaultCharConstantType =
- evaluate::Type<common::TypeCategory::Character, 1>;
+ using DefaultCharConstantType = evaluate::Ascii;
if (const SomeExpr * expr{GetExpr(x)}) {
const auto foldExpr{
evaluate::Fold(context_.foldingContext(), common::Clone(*expr))};
diff --git a/lib/Semantics/data-to-inits.cpp b/lib/Semantics/data-to-inits.cpp
index 8fba39f..958184c 100644
--- a/lib/Semantics/data-to-inits.cpp
+++ b/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<std::string> chValue{evaluate::GetScalarConstantValue<
- evaluate::Type<TypeCategory::Character, 1>>(expr)}) {
+ if (std::optional<std::string> chValue{
+ evaluate::GetScalarConstantValue<evaluate::Ascii>(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/lib/Semantics/resolve-names.cpp b/lib/Semantics/resolve-names.cpp
index 21f0b4f..8ad0f5a 100644
--- a/lib/Semantics/resolve-names.cpp
+++ b/lib/Semantics/resolve-names.cpp
@@ -1576,8 +1576,8 @@
if (!attrs_ || !attrs_->test(Attr::BIND_C)) {
return;
}
- std::optional<std::string> label{evaluate::GetScalarConstantValue<
- evaluate::Type<TypeCategory::Character, 1>>(bindName_)};
+ std::optional<std::string> label{
+ evaluate::GetScalarConstantValue<evaluate::Ascii>(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/lib/Semantics/runtime-type-info.cpp b/lib/Semantics/runtime-type-info.cpp
index ddda7d1..bc6a889 100644
--- a/lib/Semantics/runtime-type-info.cpp
+++ b/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<TypeCategory::Character, 1>;
+ using evaluate::Ascii;
using AsciiExpr = evaluate::Expr<Ascii>;
object.set_init(evaluate::AsGenericExpr(AsciiExpr{name}));
Symbol &symbol{*scope
diff --git a/test/Evaluate/fold-char-cmp.f90 b/test/Evaluate/fold-char-cmp.f90
new file mode 100644
index 0000000..6fe5c70
--- /dev/null
+++ b/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/test/Evaluate/folding01.f90 b/test/Evaluate/folding01.f90
index cb7a9eb..cc3b17e 100644
--- a/test/Evaluate/folding01.f90
+++ b/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/test/Evaluate/folding05.f90 b/test/Evaluate/folding05.f90
index 22c0290..4ace088 100644
--- a/test/Evaluate/folding05.f90
+++ b/test/Evaluate/folding05.f90
Binary files differ
