xref: /llvm-project/flang/lib/Evaluate/fold-logical.cpp (revision 6003be7ef14bd95647e1ea6ec9685c1310f8ce58) 
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     // Setting kind=0 checks subnormal flushing control across all type kinds.
894     if (args[0]) {
895       return Expr<T>{
896           context.targetCharacteristics().hasSubnormalFlushingControl(
897               args[0]->GetType().value().kind())};
898     } else {
899       return Expr<T>{
900           context.targetCharacteristics().hasSubnormalFlushingControl(
901               /*any=*/false)};
902     }
903   }
904   return Expr<T>{std::move(funcRef)};
905 }
906 
907 template <typename T>
908 Expr<LogicalResult> FoldOperation(
909     FoldingContext &context, Relational<T> &&relation) {
910   if (auto array{ApplyElementwise(context, relation,
911           std::function<Expr<LogicalResult>(Expr<T> &&, Expr<T> &&)>{
912               [=](Expr<T> &&x, Expr<T> &&y) {
913                 return Expr<LogicalResult>{Relational<SomeType>{
914                     Relational<T>{relation.opr, std::move(x), std::move(y)}}};
915               }})}) {
916     return *array;
917   }
918   if (auto folded{OperandsAreConstants(relation)}) {
919     bool result{};
920     if constexpr (T::category == TypeCategory::Integer) {
921       result =
922           Satisfies(relation.opr, folded->first.CompareSigned(folded->second));
923     } else if constexpr (T::category == TypeCategory::Real) {
924       result = Satisfies(relation.opr, folded->first.Compare(folded->second));
925     } else if constexpr (T::category == TypeCategory::Complex) {
926       result = (relation.opr == RelationalOperator::EQ) ==
927           folded->first.Equals(folded->second);
928     } else if constexpr (T::category == TypeCategory::Character) {
929       result = Satisfies(relation.opr, Compare(folded->first, folded->second));
930     } else {
931       static_assert(T::category != TypeCategory::Logical);
932     }
933     return Expr<LogicalResult>{Constant<LogicalResult>{result}};
934   }
935   return Expr<LogicalResult>{Relational<SomeType>{std::move(relation)}};
936 }
937 
938 Expr<LogicalResult> FoldOperation(
939     FoldingContext &context, Relational<SomeType> &&relation) {
940   return common::visit(
941       [&](auto &&x) {
942         return Expr<LogicalResult>{FoldOperation(context, std::move(x))};
943       },
944       std::move(relation.u));
945 }
946 
947 template <int KIND>
948 Expr<Type<TypeCategory::Logical, KIND>> FoldOperation(
949     FoldingContext &context, Not<KIND> &&x) {
950   if (auto array{ApplyElementwise(context, x)}) {
951     return *array;
952   }
953   using Ty = Type<TypeCategory::Logical, KIND>;
954   auto &operand{x.left()};
955   if (auto value{GetScalarConstantValue<Ty>(operand)}) {
956     return Expr<Ty>{Constant<Ty>{!value->IsTrue()}};
957   }
958   return Expr<Ty>{x};
959 }
960 
961 template <int KIND>
962 Expr<Type<TypeCategory::Logical, KIND>> FoldOperation(
963     FoldingContext &context, LogicalOperation<KIND> &&operation) {
964   using LOGICAL = Type<TypeCategory::Logical, KIND>;
965   if (auto array{ApplyElementwise(context, operation,
966           std::function<Expr<LOGICAL>(Expr<LOGICAL> &&, Expr<LOGICAL> &&)>{
967               [=](Expr<LOGICAL> &&x, Expr<LOGICAL> &&y) {
968                 return Expr<LOGICAL>{LogicalOperation<KIND>{
969                     operation.logicalOperator, std::move(x), std::move(y)}};
970               }})}) {
971     return *array;
972   }
973   if (auto folded{OperandsAreConstants(operation)}) {
974     bool xt{folded->first.IsTrue()}, yt{folded->second.IsTrue()}, result{};
975     switch (operation.logicalOperator) {
976     case LogicalOperator::And:
977       result = xt && yt;
978       break;
979     case LogicalOperator::Or:
980       result = xt || yt;
981       break;
982     case LogicalOperator::Eqv:
983       result = xt == yt;
984       break;
985     case LogicalOperator::Neqv:
986       result = xt != yt;
987       break;
988     case LogicalOperator::Not:
989       DIE("not a binary operator");
990     }
991     return Expr<LOGICAL>{Constant<LOGICAL>{result}};
992   }
993   return Expr<LOGICAL>{std::move(operation)};
994 }
995 
996 #ifdef _MSC_VER // disable bogus warning about missing definitions
997 #pragma warning(disable : 4661)
998 #endif
999 FOR_EACH_LOGICAL_KIND(template class ExpressionBase, )
1000 template class ExpressionBase<SomeLogical>;
1001 } // namespace Fortran::evaluate
1002