flang/lib/Evaluate/fold-logical.cpp

   1 //===-- lib/Evaluate/fold-logical.cpp -------------------------------------===//
   2 //
   3 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
   4 // See https://llvm.org/LICENSE.txt for license information.
   5 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
   6 //
   7 //===----------------------------------------------------------------------===//
   8
   9 #include "fold-implementation.h"
  10 #include "fold-matmul.h"
  11 #include "fold-reduction.h"
  12 #include "flang/Evaluate/check-expression.h"
  13 #include "flang/Runtime/magic-numbers.h"
  14
  15 namespace Fortran::evaluate {
  16
  17 template <typename T>
  18 static std::optional<Expr<SomeType>> ZeroExtend(const Constant<T> &c) {
  19   std::vector<Scalar<LargestInt>> exts;
  20   for (const auto &v : c.values()) {
  21     exts.push_back(Scalar<LargestInt>::ConvertUnsigned(v).value);
  22   }
  23   return AsGenericExpr(
  24       Constant<LargestInt>(std::move(exts), ConstantSubscripts(c.shape())));
  25 }
  26
  27 // for ALL, ANY & PARITY
  28 template <typename T>
  29 static Expr<T> FoldAllAnyParity(FoldingContext &context, FunctionRef<T> &&ref,
  30     Scalar<T> (Scalar<T>::*operation)(const Scalar<T> &) const,
  31     Scalar<T> identity) {
  32   static_assert(T::category == TypeCategory::Logical);
  33   std::optional<int> dim;
  34   if (std::optional<ArrayAndMask<T>> arrayAndMask{
  35           ProcessReductionArgs<T>(context, ref.arguments(), dim,
  36               /*ARRAY(MASK)=*/0, /*DIM=*/1)}) {
  37     OperationAccumulator accumulator{arrayAndMask->array, operation};
  38     return Expr<T>{DoReduction<T>(
  39         arrayAndMask->array, arrayAndMask->mask, dim, identity, accumulator)};
  40   }
  41   return Expr<T>{std::move(ref)};
  42 }
  43
  44 // OUT_OF_RANGE(x,mold[,round]) references are entirely rewritten here into
  45 // expressions, which are then folded into constants when 'x' and 'round'
  46 // are constant.  It is guaranteed that 'x' is evaluated at most once.
  47
  48 template <int X_RKIND, int MOLD_IKIND>
  49 Expr<SomeReal> RealToIntBoundHelper(bool round, bool negate) {
  50   using RType = Type<TypeCategory::Real, X_RKIND>;
  51   using RealType = Scalar<RType>;
  52   using IntType = Scalar<Type<TypeCategory::Integer, MOLD_IKIND>>;
  53   RealType result{}; // 0.
  54   common::RoundingMode roundingMode{round
  55           ? common::RoundingMode::TiesAwayFromZero
  56           : common::RoundingMode::ToZero};
  57   // Add decreasing powers of two to the result to find the largest magnitude
  58   // value that can be converted to the integer type without overflow.
  59   RealType at{RealType::FromInteger(IntType{negate ? -1 : 1}).value};
  60   bool decrement{true};
  61   while (!at.template ToInteger<IntType>(roundingMode)
  62               .flags.test(RealFlag::Overflow)) {
  63     auto tmp{at.SCALE(IntType{1})};
  64     if (tmp.flags.test(RealFlag::Overflow)) {
  65       decrement = false;
  66       break;
  67     }
  68     at = tmp.value;
  69   }
  70   while (true) {
  71     if (decrement) {
  72       at = at.SCALE(IntType{-1}).value;
  73     } else {
  74       decrement = true;
  75     }
  76     auto tmp{at.Add(result)};
  77     if (tmp.flags.test(RealFlag::Inexact)) {
  78       break;
  79     } else if (!tmp.value.template ToInteger<IntType>(roundingMode)
  80                     .flags.test(RealFlag::Overflow)) {
  81       result = tmp.value;
  82     }
  83   }
  84   return AsCategoryExpr(Constant<RType>{std::move(result)});
  85 }
  86
  87 static Expr<SomeReal> RealToIntBound(
  88     int xRKind, int moldIKind, bool round, bool negate) {
  89   switch (xRKind) {
  90 #define ICASES(RK) \
  91   switch (moldIKind) { \
  92   case 1: \
  93     return RealToIntBoundHelper<RK, 1>(round, negate); \
  94     break; \
  95   case 2: \
  96     return RealToIntBoundHelper<RK, 2>(round, negate); \
  97     break; \
  98   case 4: \
  99     return RealToIntBoundHelper<RK, 4>(round, negate); \
 100     break; \
 101   case 8: \
 102     return RealToIntBoundHelper<RK, 8>(round, negate); \
 103     break; \
 104   case 16: \
 105     return RealToIntBoundHelper<RK, 16>(round, negate); \
 106     break; \
 107   } \
 108   break
 109   case 2:
 110     ICASES(2);
 111     break;
 112   case 3:
 113     ICASES(3);
 114     break;
 115   case 4:
 116     ICASES(4);
 117     break;
 118   case 8:
 119     ICASES(8);
 120     break;
 121   case 10:
 122     ICASES(10);
 123     break;
 124   case 16:
 125     ICASES(16);
 126     break;
 127   }
 128   DIE("RealToIntBound: no case");
 129 #undef ICASES
 130 }
 131
 132 class RealToIntLimitHelper {
 133 public:
 134   using Result = std::optional<Expr<SomeReal>>;
 135   using Types = RealTypes;
 136   RealToIntLimitHelper(
 137       FoldingContext &context, Expr<SomeReal> &&hi, Expr<SomeReal> &lo)
 138       : context_{context}, hi_{std::move(hi)}, lo_{lo} {}
 139   template <typename T> Result Test() {
 140     if (UnwrapExpr<Expr<T>>(hi_)) {
 141       bool promote{T::kind < 16};
 142       Result constResult;
 143       if (auto hiV{GetScalarConstantValue<T>(hi_)}) {
 144         auto loV{GetScalarConstantValue<T>(lo_)};
 145         CHECK(loV.has_value());
 146         auto diff{hiV->Subtract(*loV, Rounding{common::RoundingMode::ToZero})};
 147         promote = promote &&
 148             (diff.flags.test(RealFlag::Overflow) ||
 149                 diff.flags.test(RealFlag::Inexact));
 150         constResult = AsCategoryExpr(Constant<T>{std::move(diff.value)});
 151       }
 152       if (promote) {
 153         constexpr int nextKind{T::kind < 4 ? 4 : T::kind == 4 ? 8 : 16};
 154         using T2 = Type<TypeCategory::Real, nextKind>;
 155         hi_ = Expr<SomeReal>{Fold(context_, ConvertToType<T2>(std::move(hi_)))};
 156         lo_ = Expr<SomeReal>{Fold(context_, ConvertToType<T2>(std::move(lo_)))};
 157         if (constResult) {
 158           // Use promoted constants on next iteration of SearchTypes
 159           return std::nullopt;
 160         }
 161       }
 162       if (constResult) {
 163         return constResult;
 164       } else {
 165         return AsCategoryExpr(std::move(hi_) - Expr<SomeReal>{lo_});
 166       }
 167     } else {
 168       return std::nullopt;
 169     }
 170   }
 171
 172 private:
 173   FoldingContext &context_;
 174   Expr<SomeReal> hi_;
 175   Expr<SomeReal> &lo_;
 176 };
 177
 178 static std::optional<Expr<SomeReal>> RealToIntLimit(
 179     FoldingContext &context, Expr<SomeReal> &&hi, Expr<SomeReal> &lo) {
 180   return common::SearchTypes(RealToIntLimitHelper{context, std::move(hi), lo});
 181 }
 182
 183 // RealToRealBounds() returns a pair (HUGE(x),REAL(HUGE(mold),KIND(x)))
 184 // when REAL(HUGE(x),KIND(mold)) overflows, and std::nullopt otherwise.
 185 template <int X_RKIND, int MOLD_RKIND>
 186 std::optional<std::pair<Expr<SomeReal>, Expr<SomeReal>>>
 187 RealToRealBoundsHelper() {
 188   using RType = Type<TypeCategory::Real, X_RKIND>;
 189   using RealType = Scalar<RType>;
 190   using MoldRealType = Scalar<Type<TypeCategory::Real, MOLD_RKIND>>;
 191   if (!MoldRealType::Convert(RealType::HUGE()).flags.test(RealFlag::Overflow)) {
 192     return std::nullopt;
 193   } else {
 194     return std::make_pair(AsCategoryExpr(Constant<RType>{
 195                               RealType::Convert(MoldRealType::HUGE()).value}),
 196         AsCategoryExpr(Constant<RType>{RealType::HUGE()}));
 197   }
 198 }
 199
 200 static std::optional<std::pair<Expr<SomeReal>, Expr<SomeReal>>>
 201 RealToRealBounds(int xRKind, int moldRKind) {
 202   switch (xRKind) {
 203 #define RCASES(RK) \
 204   switch (moldRKind) { \
 205   case 2: \
 206     return RealToRealBoundsHelper<RK, 2>(); \
 207     break; \
 208   case 3: \
 209     return RealToRealBoundsHelper<RK, 3>(); \
 210     break; \
 211   case 4: \
 212     return RealToRealBoundsHelper<RK, 4>(); \
 213     break; \
 214   case 8: \
 215     return RealToRealBoundsHelper<RK, 8>(); \
 216     break; \
 217   case 10: \
 218     return RealToRealBoundsHelper<RK, 10>(); \
 219     break; \
 220   case 16: \
 221     return RealToRealBoundsHelper<RK, 16>(); \
 222     break; \
 223   } \
 224   break
 225   case 2:
 226     RCASES(2);
 227     break;
 228   case 3:
 229     RCASES(3);
 230     break;
 231   case 4:
 232     RCASES(4);
 233     break;
 234   case 8:
 235     RCASES(8);
 236     break;
 237   case 10:
 238     RCASES(10);
 239     break;
 240   case 16:
 241     RCASES(16);
 242     break;
 243   }
 244   DIE("RealToRealBounds: no case");
 245 #undef RCASES
 246 }
 247
 248 template <int X_IKIND, int MOLD_RKIND>
 249 std::optional<Expr<SomeInteger>> IntToRealBoundHelper(bool negate) {
 250   using IType = Type<TypeCategory::Integer, X_IKIND>;
 251   using IntType = Scalar<IType>;
 252   using RealType = Scalar<Type<TypeCategory::Real, MOLD_RKIND>>;
 253   IntType result{}; // 0
 254   while (true) {
 255     std::optional<IntType> next;
 256     for (int bit{0}; bit < IntType::bits; ++bit) {
 257       IntType power{IntType{}.IBSET(bit)};
 258       if (power.IsNegative()) {
 259         if (!negate) {
 260           break;
 261         }
 262       } else if (negate) {
 263         power = power.Negate().value;
 264       }
 265       auto tmp{power.AddSigned(result)};
 266       if (tmp.overflow ||
 267           RealType::FromInteger(tmp.value).flags.test(RealFlag::Overflow)) {
 268         break;
 269       }
 270       next = tmp.value;
 271     }
 272     if (next) {
 273       CHECK(result.CompareSigned(*next) != Ordering::Equal);
 274       result = *next;
 275     } else {
 276       break;
 277     }
 278   }
 279   if (result.CompareSigned(IntType::HUGE()) == Ordering::Equal) {
 280     return std::nullopt;
 281   } else {
 282     return AsCategoryExpr(Constant<IType>{std::move(result)});
 283   }
 284 }
 285
 286 static std::optional<Expr<SomeInteger>> IntToRealBound(
 287     int xIKind, int moldRKind, bool negate) {
 288   switch (xIKind) {
 289 #define RCASES(IK) \
 290   switch (moldRKind) { \
 291   case 2: \
 292     return IntToRealBoundHelper<IK, 2>(negate); \
 293     break; \
 294   case 3: \
 295     return IntToRealBoundHelper<IK, 3>(negate); \
 296     break; \
 297   case 4: \
 298     return IntToRealBoundHelper<IK, 4>(negate); \
 299     break; \
 300   case 8: \
 301     return IntToRealBoundHelper<IK, 8>(negate); \
 302     break; \
 303   case 10: \
 304     return IntToRealBoundHelper<IK, 10>(negate); \
 305     break; \
 306   case 16: \
 307     return IntToRealBoundHelper<IK, 16>(negate); \
 308     break; \
 309   } \
 310   break
 311   case 1:
 312     RCASES(1);
 313     break;
 314   case 2:
 315     RCASES(2);
 316     break;
 317   case 4:
 318     RCASES(4);
 319     break;
 320   case 8:
 321     RCASES(8);
 322     break;
 323   case 16:
 324     RCASES(16);
 325     break;
 326   }
 327   DIE("IntToRealBound: no case");
 328 #undef RCASES
 329 }
 330
 331 template <int X_IKIND, int MOLD_IKIND>
 332 std::optional<Expr<SomeInteger>> IntToIntBoundHelper() {
 333   if constexpr (X_IKIND <= MOLD_IKIND) {
 334     return std::nullopt;
 335   } else {
 336     using XIType = Type<TypeCategory::Integer, X_IKIND>;
 337     using IntegerType = Scalar<XIType>;
 338     using MoldIType = Type<TypeCategory::Integer, MOLD_IKIND>;
 339     using MoldIntegerType = Scalar<MoldIType>;
 340     return AsCategoryExpr(Constant<XIType>{
 341         IntegerType::ConvertSigned(MoldIntegerType::HUGE()).value});
 342   }
 343 }
 344
 345 static std::optional<Expr<SomeInteger>> IntToIntBound(
 346     int xIKind, int moldIKind) {
 347   switch (xIKind) {
 348 #define ICASES(IK) \
 349   switch (moldIKind) { \
 350   case 1: \
 351     return IntToIntBoundHelper<IK, 1>(); \
 352     break; \
 353   case 2: \
 354     return IntToIntBoundHelper<IK, 2>(); \
 355     break; \
 356   case 4: \
 357     return IntToIntBoundHelper<IK, 4>(); \
 358     break; \
 359   case 8: \
 360     return IntToIntBoundHelper<IK, 8>(); \
 361     break; \
 362   case 16: \
 363     return IntToIntBoundHelper<IK, 16>(); \
 364     break; \
 365   } \
 366   break
 367   case 1:
 368     ICASES(1);
 369     break;
 370   case 2:
 371     ICASES(2);
 372     break;
 373   case 4:
 374     ICASES(4);
 375     break;
 376   case 8:
 377     ICASES(8);
 378     break;
 379   case 16:
 380     ICASES(16);
 381     break;
 382   }
 383   DIE("IntToIntBound: no case");
 384 #undef ICASES
 385 }
 386
 387 // ApplyIntrinsic() constructs the typed expression representation
 388 // for a specific intrinsic function reference.
 389 // TODO: maybe move into tools.h?
 390 class IntrinsicCallHelper {
 391 public:
 392   explicit IntrinsicCallHelper(SpecificCall &&call) : call_{call} {
 393     CHECK(proc_.IsFunction());
 394     typeAndShape_ = proc_.functionResult->GetTypeAndShape();
 395     CHECK(typeAndShape_ != nullptr);
 396   }
 397   using Result = std::optional<Expr<SomeType>>;
 398   using Types = LengthlessIntrinsicTypes;
 399   template <typename T> Result Test() {
 400     if (T::category == typeAndShape_->type().category() &&
 401         T::kind == typeAndShape_->type().kind()) {
 402       return AsGenericExpr(FunctionRef<T>{
 403           ProcedureDesignator{std::move(call_.specificIntrinsic)},
 404           std::move(call_.arguments)});
 405     } else {
 406       return std::nullopt;
 407     }
 408   }
 409
 410 private:
 411   SpecificCall call_;
 412   const characteristics::Procedure &proc_{
 413       call_.specificIntrinsic.characteristics.value()};
 414   const characteristics::TypeAndShape *typeAndShape_{nullptr};
 415 };
 416
 417 static Expr<SomeType> ApplyIntrinsic(
 418     FoldingContext &context, const std::string &func, ActualArguments &&args) {
 419   auto found{
 420       context.intrinsics().Probe(CallCharacteristics{func}, args, context)};
 421   CHECK(found.has_value());
 422   auto result{common::SearchTypes(IntrinsicCallHelper{std::move(*found)})};
 423   CHECK(result.has_value());
 424   return *result;
 425 }
 426
 427 static Expr<LogicalResult> CompareUnsigned(FoldingContext &context,
 428     const char *intrin, Expr<SomeType> &&x, Expr<SomeType> &&y) {
 429   Expr<SomeType> result{ApplyIntrinsic(context, intrin,
 430       ActualArguments{
 431           ActualArgument{std::move(x)}, ActualArgument{std::move(y)}})};
 432   return DEREF(UnwrapExpr<Expr<LogicalResult>>(result));
 433 }
 434
 435 // Determines the right kind of INTEGER to hold the bits of a REAL type.
 436 static Expr<SomeType> IntTransferMold(
 437     const TargetCharacteristics &target, DynamicType realType, bool asVector) {
 438   CHECK(realType.category() == TypeCategory::Real);
 439   int rKind{realType.kind()};
 440   int iKind{std::max<int>(target.GetAlignment(TypeCategory::Real, rKind),
 441       target.GetByteSize(TypeCategory::Real, rKind))};
 442   CHECK(target.CanSupportType(TypeCategory::Integer, iKind));
 443   DynamicType iType{TypeCategory::Integer, iKind};
 444   ConstantSubscripts shape;
 445   if (asVector) {
 446     shape = ConstantSubscripts{1};
 447   }
 448   Constant<SubscriptInteger> value{
 449       std::vector<Scalar<SubscriptInteger>>{0}, std::move(shape)};
 450   auto expr{ConvertToType(iType, AsGenericExpr(std::move(value)))};
 451   CHECK(expr.has_value());
 452   return std::move(*expr);
 453 }
 454
 455 static Expr<SomeType> GetRealBits(FoldingContext &context, Expr<SomeReal> &&x) {
 456   auto xType{x.GetType()};
 457   CHECK(xType.has_value());
 458   bool asVector{x.Rank() > 0};
 459   return ApplyIntrinsic(context, "transfer",
 460       ActualArguments{ActualArgument{AsGenericExpr(std::move(x))},
 461           ActualArgument{IntTransferMold(
 462               context.targetCharacteristics(), *xType, asVector)}});
 463 }
 464
 465 template <int KIND>
 466 static Expr<Type<TypeCategory::Logical, KIND>> RewriteOutOfRange(
 467     FoldingContext &context,
 468     FunctionRef<Type<TypeCategory::Logical, KIND>> &&funcRef) {
 469   using ResultType = Type<TypeCategory::Logical, KIND>;
 470   ActualArguments &args{funcRef.arguments()};
 471   // Fold x= and round= unconditionally
 472   if (auto *x{UnwrapExpr<Expr<SomeType>>(args[0])}) {
 473     *args[0] = Fold(context, std::move(*x));
 474   }
 475   if (args.size() >= 3) {
 476     if (auto *round{UnwrapExpr<Expr<SomeType>>(args[2])}) {
 477       *args[2] = Fold(context, std::move(*round));
 478     }
 479   }
 480   if (auto *x{UnwrapExpr<Expr<SomeType>>(args[0])}) {
 481     x = UnwrapExpr<Expr<SomeType>>(args[0]);
 482     CHECK(x != nullptr);
 483     if (const auto *mold{UnwrapExpr<Expr<SomeType>>(args[1])}) {
 484       DynamicType xType{x->GetType().value()};
 485       std::optional<Expr<LogicalResult>> result;
 486       bool alwaysFalse{false};
 487       if (auto *iXExpr{UnwrapExpr<Expr<SomeInteger>>(*x)}) {
 488         int iXKind{iXExpr->GetType().value().kind()};
 489         if (auto *iMoldExpr{UnwrapExpr<Expr<SomeInteger>>(*mold)}) {
 490           // INTEGER -> INTEGER
 491           int iMoldKind{iMoldExpr->GetType().value().kind()};
 492           if (auto hi{IntToIntBound(iXKind, iMoldKind)}) {
 493             // 'hi' is INT(HUGE(mold), KIND(x))
 494             // OUT_OF_RANGE(x,mold) = (x + (hi + 1)) .UGT. (2*hi + 1)
 495             auto one{DEREF(UnwrapExpr<Expr<SomeInteger>>(ConvertToType(
 496                 xType, AsGenericExpr(Constant<SubscriptInteger>{1}))))};
 497             auto lhs{std::move(*iXExpr) +
 498                 (Expr<SomeInteger>{*hi} + Expr<SomeInteger>{one})};
 499             auto two{DEREF(UnwrapExpr<Expr<SomeInteger>>(ConvertToType(
 500                 xType, AsGenericExpr(Constant<SubscriptInteger>{2}))))};
 501             auto rhs{std::move(two) * std::move(*hi) + std::move(one)};
 502             result = CompareUnsigned(context, "bgt",
 503                 Expr<SomeType>{std::move(lhs)}, Expr<SomeType>{std::move(rhs)});
 504           } else {
 505             alwaysFalse = true;
 506           }
 507         } else if (auto *rMoldExpr{UnwrapExpr<Expr<SomeReal>>(*mold)}) {
 508           // INTEGER -> REAL
 509           int rMoldKind{rMoldExpr->GetType().value().kind()};
 510           if (auto hi{IntToRealBound(iXKind, rMoldKind, /*negate=*/false)}) {
 511             // OUT_OF_RANGE(x,mold) = (x - lo) .UGT. (hi - lo)
 512             auto lo{IntToRealBound(iXKind, rMoldKind, /*negate=*/true)};
 513             CHECK(lo.has_value());
 514             auto lhs{std::move(*iXExpr) - Expr<SomeInteger>{*lo}};
 515             auto rhs{std::move(*hi) - std::move(*lo)};
 516             result = CompareUnsigned(context, "bgt",
 517                 Expr<SomeType>{std::move(lhs)}, Expr<SomeType>{std::move(rhs)});
 518           } else {
 519             alwaysFalse = true;
 520           }
 521         }
 522       } else if (auto *rXExpr{UnwrapExpr<Expr<SomeReal>>(*x)}) {
 523         int rXKind{rXExpr->GetType().value().kind()};
 524         if (auto *iMoldExpr{UnwrapExpr<Expr<SomeInteger>>(*mold)}) {
 525           // REAL -> INTEGER
 526           int iMoldKind{iMoldExpr->GetType().value().kind()};
 527           auto hi{RealToIntBound(rXKind, iMoldKind, false, false)};
 528           auto lo{RealToIntBound(rXKind, iMoldKind, false, true)};
 529           if (args.size() >= 3) {
 530             // Bounds depend on round= value
 531             if (auto *round{UnwrapExpr<Expr<SomeType>>(args[2])}) {
 532               if (const Symbol * whole{UnwrapWholeSymbolDataRef(*round)};
 533                   whole && semantics::IsOptional(whole->GetUltimate()) &&
 534                   context.languageFeatures().ShouldWarn(
 535                       common::UsageWarning::OptionalMustBePresent)) {
 536                 if (auto source{args[2]->sourceLocation()}) {
 537                   context.messages().Say(
 538                       common::UsageWarning::OptionalMustBePresent, *source,
 539                       "ROUND= argument to OUT_OF_RANGE() is an optional dummy argument that must be present at execution"_warn_en_US);
 540                 }
 541               }
 542               auto rlo{RealToIntBound(rXKind, iMoldKind, true, true)};
 543               auto rhi{RealToIntBound(rXKind, iMoldKind, true, false)};
 544               auto mlo{Fold(context,
 545                   ApplyIntrinsic(context, "merge",
 546                       ActualArguments{
 547                           ActualArgument{Expr<SomeType>{std::move(rlo)}},
 548                           ActualArgument{Expr<SomeType>{std::move(lo)}},
 549                           ActualArgument{Expr<SomeType>{*round}}}))};
 550               auto mhi{Fold(context,
 551                   ApplyIntrinsic(context, "merge",
 552                       ActualArguments{
 553                           ActualArgument{Expr<SomeType>{std::move(rhi)}},
 554                           ActualArgument{Expr<SomeType>{std::move(hi)}},
 555                           ActualArgument{std::move(*round)}}))};
 556               lo = std::move(DEREF(UnwrapExpr<Expr<SomeReal>>(mlo)));
 557               hi = std::move(DEREF(UnwrapExpr<Expr<SomeReal>>(mhi)));
 558             }
 559           }
 560           // OUT_OF_RANGE(x,mold[,round]) =
 561           //   TRANSFER(x - lo, int) .UGT. TRANSFER(hi - lo, int)
 562           hi = Fold(context, std::move(hi));
 563           lo = Fold(context, std::move(lo));
 564           if (auto rhs{RealToIntLimit(context, std::move(hi), lo)}) {
 565             Expr<SomeReal> lhs{std::move(*rXExpr) - std::move(lo)};
 566             result = CompareUnsigned(context, "bgt",
 567                 GetRealBits(context, std::move(lhs)),
 568                 GetRealBits(context, std::move(*rhs)));
 569           }
 570         } else if (auto *rMoldExpr{UnwrapExpr<Expr<SomeReal>>(*mold)}) {
 571           // REAL -> REAL
 572           // Only finite arguments with ABS(x) > HUGE(mold) are .TRUE.
 573           // OUT_OF_RANGE(x,mold) =
 574           //   TRANSFER(ABS(x) - HUGE(mold), int) - 1 .ULT.
 575           //   TRANSFER(HUGE(mold), int)
 576           // Note that OUT_OF_RANGE(+/-Inf or NaN,mold) =
 577           //   TRANSFER(+Inf or Nan, int) - 1 .ULT. TRANSFER(HUGE(mold), int)
 578           int rMoldKind{rMoldExpr->GetType().value().kind()};
 579           if (auto bounds{RealToRealBounds(rXKind, rMoldKind)}) {
 580             auto &[moldHuge, xHuge]{*bounds};
 581             Expr<SomeType> abs{ApplyIntrinsic(context, "abs",
 582                 ActualArguments{
 583                     ActualArgument{Expr<SomeType>{std::move(*rXExpr)}}})};
 584             auto &absR{DEREF(UnwrapExpr<Expr<SomeReal>>(abs))};
 585             Expr<SomeType> diffBits{
 586                 GetRealBits(context, std::move(absR) - std::move(moldHuge))};
 587             auto &diffBitsI{DEREF(UnwrapExpr<Expr<SomeInteger>>(diffBits))};
 588             Expr<SomeType> decr{std::move(diffBitsI) -
 589                 Expr<SomeInteger>{Expr<SubscriptInteger>{1}}};
 590             result = CompareUnsigned(context, "blt", std::move(decr),
 591                 GetRealBits(context, std::move(xHuge)));
 592           } else {
 593             alwaysFalse = true;
 594           }
 595         }
 596       }
 597       if (alwaysFalse) {
 598         // xType can never overflow moldType, so
 599         //   OUT_OF_RANGE(x) = (x /= 0) .AND. .FALSE.
 600         // which has the same shape as x.
 601         Expr<LogicalResult> scalarFalse{
 602             Constant<LogicalResult>{Scalar<LogicalResult>{false}}};
 603         if (x->Rank() > 0) {
 604           if (auto nez{Relate(context.messages(), RelationalOperator::NE,
 605                   std::move(*x),
 606                   AsGenericExpr(Constant<SubscriptInteger>{0}))}) {
 607             result = Expr<LogicalResult>{LogicalOperation<LogicalResult::kind>{
 608                 LogicalOperator::And, std::move(*nez), std::move(scalarFalse)}};
 609           }
 610         } else {
 611           result = std::move(scalarFalse);
 612         }
 613       }
 614       if (result) {
 615         auto restorer{context.messages().DiscardMessages()};
 616         return Fold(
 617             context, AsExpr(ConvertToType<ResultType>(std::move(*result))));
 618       }
 619     }
 620   }
 621   return AsExpr(std::move(funcRef));
 622 }
 623
 624 static std::optional<common::RoundingMode> GetRoundingMode(
 625     const std::optional<ActualArgument> &arg) {
 626   if (arg) {
 627     if (const auto *cst{UnwrapExpr<Constant<SomeDerived>>(*arg)}) {
 628       if (auto constr{cst->GetScalarValue()}) {
 629         if (StructureConstructorValues & values{constr->values()};
 630             values.size() == 1) {
 631           const Expr<SomeType> &value{values.begin()->second.value()};
 632           if (auto code{ToInt64(value)}) {
 633             return static_cast<common::RoundingMode>(*code);
 634           }
 635         }
 636       }
 637     }
 638   }
 639   return std::nullopt;
 640 }
 641
 642 template <int KIND>
 643 Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
 644     FoldingContext &context,
 645     FunctionRef<Type<TypeCategory::Logical, KIND>> &&funcRef) {
 646   using T = Type<TypeCategory::Logical, KIND>;
 647   ActualArguments &args{funcRef.arguments()};
 648   auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)};
 649   CHECK(intrinsic);
 650   std::string name{intrinsic->name};
 651   using SameInt = Type<TypeCategory::Integer, KIND>;
 652   if (name == "all") {
 653     return FoldAllAnyParity(
 654         context, std::move(funcRef), &Scalar<T>::AND, Scalar<T>{true});
 655   } else if (name == "any") {
 656     return FoldAllAnyParity(
 657         context, std::move(funcRef), &Scalar<T>::OR, Scalar<T>{false});
 658   } else if (name == "associated") {
 659     bool gotConstant{true};
 660     const Expr<SomeType> *firstArgExpr{args[0]->UnwrapExpr()};
 661     if (!firstArgExpr || !IsNullPointer(*firstArgExpr)) {
 662       gotConstant = false;
 663     } else if (args[1]) { // There's a second argument
 664       const Expr<SomeType> *secondArgExpr{args[1]->UnwrapExpr()};
 665       if (!secondArgExpr || !IsNullPointer(*secondArgExpr)) {
 666         gotConstant = false;
 667       }
 668     }
 669     return gotConstant ? Expr<T>{false} : Expr<T>{std::move(funcRef)};
 670   } else if (name == "bge" || name == "bgt" || name == "ble" || name == "blt") {
 671     static_assert(std::is_same_v<Scalar<LargestInt>, BOZLiteralConstant>);
 672
 673     // The arguments to these intrinsics can be of different types. In that
 674     // case, the shorter of the two would need to be zero-extended to match
 675     // the size of the other. If at least one of the operands is not a constant,
 676     // the zero-extending will be done during lowering. Otherwise, the folding
 677     // must be done here.
 678     std::optional<Expr<SomeType>> constArgs[2];
 679     for (int i{0}; i <= 1; i++) {
 680       if (BOZLiteralConstant * x{UnwrapExpr<BOZLiteralConstant>(args[i])}) {
 681         constArgs[i] = AsGenericExpr(Constant<LargestInt>{std::move(*x)});
 682       } else if (auto *x{UnwrapExpr<Expr<SomeInteger>>(args[i])}) {
 683         common::visit(
 684             [&](const auto &ix) {
 685               using IntT = typename std::decay_t<decltype(ix)>::Result;
 686               if (auto *c{UnwrapConstantValue<IntT>(ix)}) {
 687                 constArgs[i] = ZeroExtend(*c);
 688               }
 689             },
 690             x->u);
 691       }
 692     }
 693
 694     if (constArgs[0] && constArgs[1]) {
 695       auto fptr{&Scalar<LargestInt>::BGE};
 696       if (name == "bge") { // done in fptr declaration
 697       } else if (name == "bgt") {
 698         fptr = &Scalar<LargestInt>::BGT;
 699       } else if (name == "ble") {
 700         fptr = &Scalar<LargestInt>::BLE;
 701       } else if (name == "blt") {
 702         fptr = &Scalar<LargestInt>::BLT;
 703       } else {
 704         common::die("missing case to fold intrinsic function %s", name.c_str());
 705       }
 706
 707       for (int i{0}; i <= 1; i++) {
 708         *args[i] = std::move(constArgs[i].value());
 709       }
 710
 711       return FoldElementalIntrinsic<T, LargestInt, LargestInt>(context,
 712           std::move(funcRef),
 713           ScalarFunc<T, LargestInt, LargestInt>(
 714               [&fptr](
 715                   const Scalar<LargestInt> &i, const Scalar<LargestInt> &j) {
 716                 return Scalar<T>{std::invoke(fptr, i, j)};
 717               }));
 718     } else {
 719       return Expr<T>{std::move(funcRef)};
 720     }
 721   } else if (name == "btest") {
 722     if (const auto *ix{UnwrapExpr<Expr<SomeInteger>>(args[0])}) {
 723       return common::visit(
 724           [&](const auto &x) {
 725             using IT = ResultType<decltype(x)>;
 726             return FoldElementalIntrinsic<T, IT, SameInt>(context,
 727                 std::move(funcRef),
 728                 ScalarFunc<T, IT, SameInt>(
 729                     [&](const Scalar<IT> &x, const Scalar<SameInt> &pos) {
 730                       auto posVal{pos.ToInt64()};
 731                       if (posVal < 0 || posVal >= x.bits) {
 732                         context.messages().Say(
 733                             "POS=%jd out of range for BTEST"_err_en_US,
 734                             static_cast<std::intmax_t>(posVal));
 735                       }
 736                       return Scalar<T>{x.BTEST(posVal)};
 737                     }));
 738           },
 739           ix->u);
 740     }
 741   } else if (name == "dot_product") {
 742     return FoldDotProduct<T>(context, std::move(funcRef));
 743   } else if (name == "extends_type_of") {
 744     // Type extension testing with EXTENDS_TYPE_OF() ignores any type
 745     // parameters. Returns a constant truth value when the result is known now.
 746     if (args[0] && args[1]) {
 747       auto t0{args[0]->GetType()};
 748       auto t1{args[1]->GetType()};
 749       if (t0 && t1) {
 750         if (auto result{t0->ExtendsTypeOf(*t1)}) {
 751           return Expr<T>{*result};
 752         }
 753       }
 754     }
 755   } else if (name == "isnan" || name == "__builtin_ieee_is_nan") {
 756     // Only replace the type of the function if we can do the fold
 757     if (args[0] && args[0]->UnwrapExpr() &&
 758         IsActuallyConstant(*args[0]->UnwrapExpr())) {
 759       auto restorer{context.messages().DiscardMessages()};
 760       using DefaultReal = Type<TypeCategory::Real, 4>;
 761       return FoldElementalIntrinsic<T, DefaultReal>(context, std::move(funcRef),
 762           ScalarFunc<T, DefaultReal>([](const Scalar<DefaultReal> &x) {
 763             return Scalar<T>{x.IsNotANumber()};
 764           }));
 765     }
 766   } else if (name == "__builtin_ieee_is_negative") {
 767     auto restorer{context.messages().DiscardMessages()};
 768     using DefaultReal = Type<TypeCategory::Real, 4>;
 769     if (args[0] && args[0]->UnwrapExpr() &&
 770         IsActuallyConstant(*args[0]->UnwrapExpr())) {
 771       return FoldElementalIntrinsic<T, DefaultReal>(context, std::move(funcRef),
 772           ScalarFunc<T, DefaultReal>([](const Scalar<DefaultReal> &x) {
 773             return Scalar<T>{x.IsNegative()};
 774           }));
 775     }
 776   } else if (name == "__builtin_ieee_is_normal") {
 777     auto restorer{context.messages().DiscardMessages()};
 778     using DefaultReal = Type<TypeCategory::Real, 4>;
 779     if (args[0] && args[0]->UnwrapExpr() &&
 780         IsActuallyConstant(*args[0]->UnwrapExpr())) {
 781       return FoldElementalIntrinsic<T, DefaultReal>(context, std::move(funcRef),
 782           ScalarFunc<T, DefaultReal>([](const Scalar<DefaultReal> &x) {
 783             return Scalar<T>{x.IsNormal()};
 784           }));
 785     }
 786   } else if (name == "is_contiguous") {
 787     if (args.at(0)) {
 788       if (auto *expr{args[0]->UnwrapExpr()}) {
 789         if (auto contiguous{IsContiguous(*expr, context)}) {
 790           return Expr<T>{*contiguous};
 791         }
 792       } else if (auto *assumedType{args[0]->GetAssumedTypeDummy()}) {
 793         if (auto contiguous{IsContiguous(*assumedType, context)}) {
 794           return Expr<T>{*contiguous};
 795         }
 796       }
 797     }
 798   } else if (name == "is_iostat_end") {
 799     if (args[0] && args[0]->UnwrapExpr() &&
 800         IsActuallyConstant(*args[0]->UnwrapExpr())) {
 801       using Int64 = Type<TypeCategory::Integer, 8>;
 802       return FoldElementalIntrinsic<T, Int64>(context, std::move(funcRef),
 803           ScalarFunc<T, Int64>([](const Scalar<Int64> &x) {
 804             return Scalar<T>{x.ToInt64() == FORTRAN_RUNTIME_IOSTAT_END};
 805           }));
 806     }
 807   } else if (name == "is_iostat_eor") {
 808     if (args[0] && args[0]->UnwrapExpr() &&
 809         IsActuallyConstant(*args[0]->UnwrapExpr())) {
 810       using Int64 = Type<TypeCategory::Integer, 8>;
 811       return FoldElementalIntrinsic<T, Int64>(context, std::move(funcRef),
 812           ScalarFunc<T, Int64>([](const Scalar<Int64> &x) {
 813             return Scalar<T>{x.ToInt64() == FORTRAN_RUNTIME_IOSTAT_EOR};
 814           }));
 815     }
 816   } else if (name == "lge" || name == "lgt" || name == "lle" || name == "llt") {
 817     // Rewrite LGE/LGT/LLE/LLT into ASCII character relations
 818     auto *cx0{UnwrapExpr<Expr<SomeCharacter>>(args[0])};
 819     auto *cx1{UnwrapExpr<Expr<SomeCharacter>>(args[1])};
 820     if (cx0 && cx1) {
 821       return Fold(context,
 822           ConvertToType<T>(
 823               PackageRelation(name == "lge" ? RelationalOperator::GE
 824                       : name == "lgt"       ? RelationalOperator::GT
 825                       : name == "lle"       ? RelationalOperator::LE
 826                                             : RelationalOperator::LT,
 827                   ConvertToType<Ascii>(std::move(*cx0)),
 828                   ConvertToType<Ascii>(std::move(*cx1)))));
 829     }
 830   } else if (name == "logical") {
 831     if (auto *expr{UnwrapExpr<Expr<SomeLogical>>(args[0])}) {
 832       return Fold(context, ConvertToType<T>(std::move(*expr)));
 833     }
 834   } else if (name == "matmul") {
 835     return FoldMatmul(context, std::move(funcRef));
 836   } else if (name == "out_of_range") {
 837     return RewriteOutOfRange<KIND>(context, std::move(funcRef));
 838   } else if (name == "parity") {
 839     return FoldAllAnyParity(
 840         context, std::move(funcRef), &Scalar<T>::NEQV, Scalar<T>{false});
 841   } else if (name == "same_type_as") {
 842     // Type equality testing with SAME_TYPE_AS() ignores any type parameters.
 843     // Returns a constant truth value when the result is known now.
 844     if (args[0] && args[1]) {
 845       auto t0{args[0]->GetType()};
 846       auto t1{args[1]->GetType()};
 847       if (t0 && t1) {
 848         if (auto result{t0->SameTypeAs(*t1)}) {
 849           return Expr<T>{*result};
 850         }
 851       }
 852     }
 853   } else if (name == "__builtin_ieee_support_datatype") {
 854     return Expr<T>{true};
 855   } else if (name == "__builtin_ieee_support_denormal") {
 856     return Expr<T>{context.targetCharacteristics().ieeeFeatures().test(
 857         IeeeFeature::Denormal)};
 858   } else if (name == "__builtin_ieee_support_divide") {
 859     return Expr<T>{context.targetCharacteristics().ieeeFeatures().test(
 860         IeeeFeature::Divide)};
 861   } else if (name == "__builtin_ieee_support_flag") {
 862     return Expr<T>{context.targetCharacteristics().ieeeFeatures().test(
 863         IeeeFeature::Flags)};
 864   } else if (name == "__builtin_ieee_support_halting") {
 865     return Expr<T>{context.targetCharacteristics().ieeeFeatures().test(
 866         IeeeFeature::Halting)};
 867   } else if (name == "__builtin_ieee_support_inf") {
 868     return Expr<T>{
 869         context.targetCharacteristics().ieeeFeatures().test(IeeeFeature::Inf)};
 870   } else if (name == "__builtin_ieee_support_io") {
 871     return Expr<T>{
 872         context.targetCharacteristics().ieeeFeatures().test(IeeeFeature::Io)};
 873   } else if (name == "__builtin_ieee_support_nan") {
 874     return Expr<T>{
 875         context.targetCharacteristics().ieeeFeatures().test(IeeeFeature::NaN)};
 876   } else if (name == "__builtin_ieee_support_rounding") {
 877     if (context.targetCharacteristics().ieeeFeatures().test(
 878             IeeeFeature::Rounding)) {
 879       if (auto mode{GetRoundingMode(args[0])}) {
 880         return Expr<T>{mode != common::RoundingMode::TiesAwayFromZero};
 881       }
 882     }
 883   } else if (name == "__builtin_ieee_support_sqrt") {
 884     return Expr<T>{
 885         context.targetCharacteristics().ieeeFeatures().test(IeeeFeature::Sqrt)};
 886   } else if (name == "__builtin_ieee_support_standard") {
 887     return Expr<T>{context.targetCharacteristics().ieeeFeatures().test(
 888         IeeeFeature::Standard)};
 889   } else if (name == "__builtin_ieee_support_subnormal") {
 890     return Expr<T>{context.targetCharacteristics().ieeeFeatures().test(
 891         IeeeFeature::Subnormal)};
 892   } else if (name == "__builtin_ieee_support_underflow_control") {
 893     return Expr<T>{context.targetCharacteristics().ieeeFeatures().test(
 894         IeeeFeature::UnderflowControl)};
 895   }
 896   return Expr<T>{std::move(funcRef)};
 897 }
 898
 899 template <typename T>
 900 Expr<LogicalResult> FoldOperation(
 901     FoldingContext &context, Relational<T> &&relation) {
 902   if (auto array{ApplyElementwise(context, relation,
 903           std::function<Expr<LogicalResult>(Expr<T> &&, Expr<T> &&)>{
 904               [=](Expr<T> &&x, Expr<T> &&y) {
 905                 return Expr<LogicalResult>{Relational<SomeType>{
 906                     Relational<T>{relation.opr, std::move(x), std::move(y)}}};
 907               }})}) {
 908     return *array;
 909   }
 910   if (auto folded{OperandsAreConstants(relation)}) {
 911     bool result{};
 912     if constexpr (T::category == TypeCategory::Integer) {
 913       result =
 914           Satisfies(relation.opr, folded->first.CompareSigned(folded->second));
 915     } else if constexpr (T::category == TypeCategory::Real) {
 916       result = Satisfies(relation.opr, folded->first.Compare(folded->second));
 917     } else if constexpr (T::category == TypeCategory::Complex) {
 918       result = (relation.opr == RelationalOperator::EQ) ==
 919           folded->first.Equals(folded->second);
 920     } else if constexpr (T::category == TypeCategory::Character) {
 921       result = Satisfies(relation.opr, Compare(folded->first, folded->second));
 922     } else {
 923       static_assert(T::category != TypeCategory::Logical);
 924     }
 925     return Expr<LogicalResult>{Constant<LogicalResult>{result}};
 926   }
 927   return Expr<LogicalResult>{Relational<SomeType>{std::move(relation)}};
 928 }
 929
 930 Expr<LogicalResult> FoldOperation(
 931     FoldingContext &context, Relational<SomeType> &&relation) {
 932   return common::visit(
 933       [&](auto &&x) {
 934         return Expr<LogicalResult>{FoldOperation(context, std::move(x))};
 935       },
 936       std::move(relation.u));
 937 }
 938
 939 template <int KIND>
 940 Expr<Type<TypeCategory::Logical, KIND>> FoldOperation(
 941     FoldingContext &context, Not<KIND> &&x) {
 942   if (auto array{ApplyElementwise(context, x)}) {
 943     return *array;
 944   }
 945   using Ty = Type<TypeCategory::Logical, KIND>;
 946   auto &operand{x.left()};
 947   if (auto value{GetScalarConstantValue<Ty>(operand)}) {
 948     return Expr<Ty>{Constant<Ty>{!value->IsTrue()}};
 949   }
 950   return Expr<Ty>{x};
 951 }
 952
 953 template <int KIND>
 954 Expr<Type<TypeCategory::Logical, KIND>> FoldOperation(
 955     FoldingContext &context, LogicalOperation<KIND> &&operation) {
 956   using LOGICAL = Type<TypeCategory::Logical, KIND>;
 957   if (auto array{ApplyElementwise(context, operation,
 958           std::function<Expr<LOGICAL>(Expr<LOGICAL> &&, Expr<LOGICAL> &&)>{
 959               [=](Expr<LOGICAL> &&x, Expr<LOGICAL> &&y) {
 960                 return Expr<LOGICAL>{LogicalOperation<KIND>{
 961                     operation.logicalOperator, std::move(x), std::move(y)}};
 962               }})}) {
 963     return *array;
 964   }
 965   if (auto folded{OperandsAreConstants(operation)}) {
 966     bool xt{folded->first.IsTrue()}, yt{folded->second.IsTrue()}, result{};
 967     switch (operation.logicalOperator) {
 968     case LogicalOperator::And:
 969       result = xt && yt;
 970       break;
 971     case LogicalOperator::Or:
 972       result = xt || yt;
 973       break;
 974     case LogicalOperator::Eqv:
 975       result = xt == yt;
 976       break;
 977     case LogicalOperator::Neqv:
 978       result = xt != yt;
 979       break;
 980     case LogicalOperator::Not:
 981       DIE("not a binary operator");
 982     }
 983     return Expr<LOGICAL>{Constant<LOGICAL>{result}};
 984   }
 985   return Expr<LOGICAL>{std::move(operation)};
 986 }
 987
 988 #ifdef _MSC_VER // disable bogus warning about missing definitions
 989 #pragma warning(disable : 4661)
 990 #endif
 991 FOR_EACH_LOGICAL_KIND(template class ExpressionBase, )
 992 template class ExpressionBase<SomeLogical>;
 993 } // namespace Fortran::evaluate