[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/Parser/message.h"
 #include <cinttypes>
 #include <map>
+#include <string>
 
 namespace Fortran::semantics {
 class DerivedTypeSpec;

   }
 }
 
+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;

flang/include/flang/Evaluate/type.h

 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

flang/lib/Evaluate/fold-logical.cpp

         }
       }
     }
+  } 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)));

     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)};
 }

flang/lib/Semantics/check-io.h

       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))};

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

   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.

flang/lib/Semantics/resolve-names.cpp

   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(" ")};

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

     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

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

   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)
 

   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