[flang] Fold LGE/LGT/LLE/LLT intrinsic functions

[klausler]

Summary

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.)

[PeteSteinfeld]

Things generally look good, and I'm approving.

But Phabricator is treating flang/test/Evaluate/folding05.f90 as a binary file, and I can't figure out how to get the version that's in this patch onto my test machine. As a result, when I run check-flang, I get errors when testing folding05.f90.

flang/include/flang/Evaluate/common.h

 #include "flang/Common/enum-set.h"
 #include "flang/Common/idioms.h"
 #include "flang/Common/indirection.h"
 #include "flang/Common/restorer.h"
 #include "flang/Parser/char-block.h"
 #include "flang/Parser/message.h"
 #include <cinttypes>
 #include <map>
+#include <string>
 
 namespace Fortran::semantics {
 class DerivedTypeSpec;
 }
 
 namespace Fortran::evaluate {
 class IntrinsicProcTable;
 
if (x < y) {
     return Ordering::Less;
   } else if (x > y) {
     return Ordering::Greater;
   } else {
     return Ordering::Equal;
   }
 }
 
+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;
   } else if (ordering == Ordering::Greater) {
     return Ordering::Less;
   } else {
     return Ordering::Equal;
   }

flang/include/flang/Evaluate/type.h

 // Specific intrinsic types are represented by specializations of
 // this class template Type<CATEGORY, KIND>.
 template <TypeCategory CATEGORY, int KIND = 0> class Type;
 
 using SubscriptInteger = Type<TypeCategory::Integer, 8>;
 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
 // set architecture.
 // TODO: specialize for the actual target architecture
 static constexpr bool IsValidKindOfIntrinsicType(
     TypeCategory category, std::int64_t kind) {
   switch (category) {

flang/lib/Evaluate/fold-logical.cpp

Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
   } else if (name == "is_contiguous") {
     if (args.at(0)) {
       if (auto *expr{args[0]->UnwrapExpr()}) {
         if (IsSimplyContiguous(*expr, context)) {
           return Expr<T>{true};
         }
       }
     }
+  } 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)));
     }
   } else if (name == "merge") {
     return FoldMerge<T>(context, std::move(funcRef));
   } else if (name == "__builtin_ieee_support_datatype" ||
       name == "__builtin_ieee_support_denormal" ||
       name == "__builtin_ieee_support_divide" ||
       name == "__builtin_ieee_support_divide" ||
       name == "__builtin_ieee_support_inf" ||
       name == "__builtin_ieee_support_io" ||
       name == "__builtin_ieee_support_nan" ||
       name == "__builtin_ieee_support_sqrt" ||
       name == "__builtin_ieee_support_standard" ||
       name == "__builtin_ieee_support_subnormal" ||
       name == "__builtin_ieee_support_underflow_control") {
     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)};
 }
 
 template <typename T>
 Expr<LogicalResult> FoldOperation(
     FoldingContext &context, Relational<T> &&relation) {
   if (auto array{ApplyElementwise(context, relation,

flang/lib/Semantics/check-io.h

 private:
   // Presence flag values.
   ENUM_CLASS(Flag, IoControlList, InternalUnit, NumberUnit, StarUnit, CharFmt,
       LabelFmt, StarFmt, AssignFmt, FmtOrNml, KnownAccess, AccessDirect,
       AccessStream, AdvanceYes, AsynchronousYes, KnownStatus, StatusNew,
       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))};
       if constexpr (std::is_same_v<R, std::string>) {
         return evaluate::GetScalarConstantValue<DefaultCharConstantType>(
             foldExpr);
       } else {
         static_assert(std::is_same_v<R, std::int64_t>, "unexpected type");

flang/lib/Semantics/data-to-inits.cpp

 }
 
 std::optional<std::pair<SomeExpr, bool>>
 DataInitializationCompiler::ConvertElement(
     const SomeExpr &expr, const evaluate::DynamicType &type) {
   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.
     // TODO: big-endian targets
     auto bytes{static_cast<std::size_t>(evaluate::ToInt64(
         type.MeasureSizeInBytes(exprAnalyzer_.GetFoldingContext(), false))
                                             .value())};
     evaluate::BOZLiteralConstant bits{0};

flang/lib/Semantics/resolve-names.cpp

std::visit(common::visitors{
       symbol.details());
   return true;
 }
 
 void AttrsVisitor::SetBindNameOn(Symbol &symbol) {
   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(" ")};
     if (first == std::string::npos) {
       // Empty NAME= means no binding at all (18.10.2p2)
       Say(currStmtSource().value(), "Blank binding label ignored"_en_US);
       return;
     }

flang/lib/Semantics/runtime-type-info.cpp

SomeExpr RuntimeTableBuilder::SaveNameAsPointerTarget(
   auto len{static_cast<common::ConstantSubscript>(name.size())};
   if (const auto *spec{scope.FindType(DeclTypeSpec{CharacterTypeSpec{
           ParamValue{len, common::TypeParamAttr::Len}, KindExpr{1}}})}) {
     object.set_type(*spec);
   } else {
     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
                       .try_emplace(SaveObjectName(".n."s + name),
                           Attrs{Attr::TARGET, Attr::SAVE}, std::move(object))
                       .first->second};
   symbol.set(Symbol::Flag::CompilerCreated);
   return evaluate::AsGenericExpr(

flang/test/Evaluate/fold-char-cmp.f90

+! 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

flang/test/Evaluate/folding01.f90

! Check integer intrinsic operation folding
   character(*), parameter :: c1 = "elephant", c2="elevator"
   character(*), parameter :: c3 = "excalibur", c4="z", c5="epsilon"
   character(*), parameter :: res_max_c = max(c1, c2, c3, c4, c5)
   character(*), parameter :: res_min_c = min(c1, c2, c3, c4, c5)
   ! length of result is length of longest arguments!
   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)
 
   integer, parameter :: x1a(*) = [1, 12, 3, 14]
   integer, parameter :: x2a(*) = [11, 2, 13, 4]
   logical, parameter :: test_max_a1 = all(max(x1a, x2a).EQ.[11, 12, 13, 14])
   logical, parameter :: test_min_a1 = all(min(x1a, x2a).EQ.[1, 2, 3, 4])
 
   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