1 //===-- lib/Evaluate/fold-integer.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-reduction.h"
11 #include "flang/Evaluate/check-expression.h"
12 
13 namespace Fortran::evaluate {
14 
15 // Class to retrieve the constant lower bound of an expression which is an
16 // array that devolves to a type of Constant<T>
17 class GetConstantArrayLboundHelper {
18 public:
19   GetConstantArrayLboundHelper(ConstantSubscript dim) : dim_{dim} {}
20 
21   template <typename T> ConstantSubscript GetLbound(const T &) {
22     // The method is needed for template expansion, but we should never get
23     // here in practice.
24     CHECK(false);
25     return 0;
26   }
27 
28   template <typename T> ConstantSubscript GetLbound(const Constant<T> &x) {
29     // Return the lower bound
30     return x.lbounds()[dim_];
31   }
32 
33   template <typename T> ConstantSubscript GetLbound(const Parentheses<T> &x) {
34     // Strip off the parentheses
35     return GetLbound(x.left());
36   }
37 
38   template <typename T> ConstantSubscript GetLbound(const Expr<T> &x) {
39     // recurse through Expr<T>'a until we hit a constant
40     return std::visit([&](const auto &inner) { return GetLbound(inner); },
41         //      [&](const auto &) { return 0; },
42         x.u);
43   }
44 
45 private:
46   ConstantSubscript dim_;
47 };
48 
49 template <int KIND>
50 Expr<Type<TypeCategory::Integer, KIND>> LBOUND(FoldingContext &context,
51     FunctionRef<Type<TypeCategory::Integer, KIND>> &&funcRef) {
52   using T = Type<TypeCategory::Integer, KIND>;
53   ActualArguments &args{funcRef.arguments()};
54   if (const auto *array{UnwrapExpr<Expr<SomeType>>(args[0])}) {
55     if (int rank{array->Rank()}; rank > 0) {
56       std::optional<int> dim;
57       if (funcRef.Rank() == 0) {
58         // Optional DIM= argument is present: result is scalar.
59         if (auto dim64{GetInt64Arg(args[1])}) {
60           if (*dim64 < 1 || *dim64 > rank) {
61             context.messages().Say("DIM=%jd dimension is out of range for "
62                                    "rank-%d array"_err_en_US,
63                 *dim64, rank);
64             return MakeInvalidIntrinsic<T>(std::move(funcRef));
65           } else {
66             dim = *dim64 - 1; // 1-based to 0-based
67           }
68         } else {
69           // DIM= is present but not constant
70           return Expr<T>{std::move(funcRef)};
71         }
72       }
73       bool lowerBoundsAreOne{true};
74       if (auto named{ExtractNamedEntity(*array)}) {
75         const Symbol &symbol{named->GetLastSymbol()};
76         if (symbol.Rank() == rank) {
77           lowerBoundsAreOne = false;
78           if (dim) {
79             if (auto lb{GetLBOUND(context, *named, *dim)}) {
80               return Fold(context, ConvertToType<T>(std::move(*lb)));
81             }
82           } else if (auto extents{
83                          AsExtentArrayExpr(GetLBOUNDs(context, *named))}) {
84             return Fold(context,
85                 ConvertToType<T>(Expr<ExtentType>{std::move(*extents)}));
86           }
87         } else {
88           lowerBoundsAreOne = symbol.Rank() == 0; // LBOUND(array%component)
89         }
90       }
91       if (IsActuallyConstant(*array)) {
92         return Expr<T>{GetConstantArrayLboundHelper{*dim}.GetLbound(*array)};
93       }
94       if (lowerBoundsAreOne) {
95         if (dim) {
96           return Expr<T>{1};
97         } else {
98           std::vector<Scalar<T>> ones(rank, Scalar<T>{1});
99           return Expr<T>{
100               Constant<T>{std::move(ones), ConstantSubscripts{rank}}};
101         }
102       }
103     }
104   }
105   return Expr<T>{std::move(funcRef)};
106 }
107 
108 template <int KIND>
109 Expr<Type<TypeCategory::Integer, KIND>> UBOUND(FoldingContext &context,
110     FunctionRef<Type<TypeCategory::Integer, KIND>> &&funcRef) {
111   using T = Type<TypeCategory::Integer, KIND>;
112   ActualArguments &args{funcRef.arguments()};
113   if (auto *array{UnwrapExpr<Expr<SomeType>>(args[0])}) {
114     if (int rank{array->Rank()}; rank > 0) {
115       std::optional<int> dim;
116       if (funcRef.Rank() == 0) {
117         // Optional DIM= argument is present: result is scalar.
118         if (auto dim64{GetInt64Arg(args[1])}) {
119           if (*dim64 < 1 || *dim64 > rank) {
120             context.messages().Say("DIM=%jd dimension is out of range for "
121                                    "rank-%d array"_err_en_US,
122                 *dim64, rank);
123             return MakeInvalidIntrinsic<T>(std::move(funcRef));
124           } else {
125             dim = *dim64 - 1; // 1-based to 0-based
126           }
127         } else {
128           // DIM= is present but not constant
129           return Expr<T>{std::move(funcRef)};
130         }
131       }
132       bool takeBoundsFromShape{true};
133       if (auto named{ExtractNamedEntity(*array)}) {
134         const Symbol &symbol{named->GetLastSymbol()};
135         if (symbol.Rank() == rank) {
136           takeBoundsFromShape = false;
137           if (dim) {
138             if (semantics::IsAssumedSizeArray(symbol) && *dim == rank - 1) {
139               context.messages().Say("DIM=%jd dimension is out of range for "
140                                      "rank-%d assumed-size array"_err_en_US,
141                   rank, rank);
142               return MakeInvalidIntrinsic<T>(std::move(funcRef));
143             } else if (auto ub{GetUpperBound(context, *named, *dim)}) {
144               return Fold(context, ConvertToType<T>(std::move(*ub)));
145             }
146           } else {
147             Shape ubounds{GetUpperBounds(context, *named)};
148             if (semantics::IsAssumedSizeArray(symbol)) {
149               CHECK(!ubounds.back());
150               ubounds.back() = ExtentExpr{-1};
151             }
152             if (auto extents{AsExtentArrayExpr(ubounds)}) {
153               return Fold(context,
154                   ConvertToType<T>(Expr<ExtentType>{std::move(*extents)}));
155             }
156           }
157         } else {
158           takeBoundsFromShape = symbol.Rank() == 0; // UBOUND(array%component)
159         }
160       }
161       if (takeBoundsFromShape) {
162         if (auto shape{GetContextFreeShape(context, *array)}) {
163           if (dim) {
164             if (auto &dimSize{shape->at(*dim)}) {
165               return Fold(context,
166                   ConvertToType<T>(Expr<ExtentType>{std::move(*dimSize)}));
167             }
168           } else if (auto shapeExpr{AsExtentArrayExpr(*shape)}) {
169             return Fold(context, ConvertToType<T>(std::move(*shapeExpr)));
170           }
171         }
172       }
173     }
174   }
175   return Expr<T>{std::move(funcRef)};
176 }
177 
178 // COUNT()
179 template <typename T>
180 static Expr<T> FoldCount(FoldingContext &context, FunctionRef<T> &&ref) {
181   static_assert(T::category == TypeCategory::Integer);
182   ActualArguments &arg{ref.arguments()};
183   if (const Constant<LogicalResult> *mask{arg.empty()
184               ? nullptr
185               : Folder<LogicalResult>{context}.Folding(arg[0])}) {
186     std::optional<int> dim;
187     if (CheckReductionDIM(dim, context, arg, 1, mask->Rank())) {
188       auto accumulator{[&](Scalar<T> &element, const ConstantSubscripts &at) {
189         if (mask->At(at).IsTrue()) {
190           element = element.AddSigned(Scalar<T>{1}).value;
191         }
192       }};
193       return Expr<T>{DoReduction<T>(*mask, dim, Scalar<T>{}, accumulator)};
194     }
195   }
196   return Expr<T>{std::move(ref)};
197 }
198 
199 // FINDLOC(), MAXLOC(), & MINLOC()
200 enum class WhichLocation { Findloc, Maxloc, Minloc };
201 template <WhichLocation WHICH> class LocationHelper {
202 public:
203   LocationHelper(
204       DynamicType &&type, ActualArguments &arg, FoldingContext &context)
205       : type_{type}, arg_{arg}, context_{context} {}
206   using Result = std::optional<Constant<SubscriptInteger>>;
207   using Types = std::conditional_t<WHICH == WhichLocation::Findloc,
208       AllIntrinsicTypes, RelationalTypes>;
209 
210   template <typename T> Result Test() const {
211     if (T::category != type_.category() || T::kind != type_.kind()) {
212       return std::nullopt;
213     }
214     CHECK(arg_.size() == (WHICH == WhichLocation::Findloc ? 6 : 5));
215     Folder<T> folder{context_};
216     Constant<T> *array{folder.Folding(arg_[0])};
217     if (!array) {
218       return std::nullopt;
219     }
220     std::optional<Constant<T>> value;
221     if constexpr (WHICH == WhichLocation::Findloc) {
222       if (const Constant<T> *p{folder.Folding(arg_[1])}) {
223         value.emplace(*p);
224       } else {
225         return std::nullopt;
226       }
227     }
228     std::optional<int> dim;
229     Constant<LogicalResult> *mask{
230         GetReductionMASK(arg_[maskArg], array->shape(), context_)};
231     if ((!mask && arg_[maskArg]) ||
232         !CheckReductionDIM(dim, context_, arg_, dimArg, array->Rank())) {
233       return std::nullopt;
234     }
235     bool back{false};
236     if (arg_[backArg]) {
237       const auto *backConst{
238           Folder<LogicalResult>{context_}.Folding(arg_[backArg])};
239       if (backConst) {
240         back = backConst->GetScalarValue().value().IsTrue();
241       } else {
242         return std::nullopt;
243       }
244     }
245     const RelationalOperator relation{WHICH == WhichLocation::Findloc
246             ? RelationalOperator::EQ
247             : WHICH == WhichLocation::Maxloc
248             ? (back ? RelationalOperator::GE : RelationalOperator::GT)
249             : back ? RelationalOperator::LE
250                    : RelationalOperator::LT};
251     // Use lower bounds of 1 exclusively.
252     array->SetLowerBoundsToOne();
253     ConstantSubscripts at{array->lbounds()}, maskAt, resultIndices, resultShape;
254     if (mask) {
255       mask->SetLowerBoundsToOne();
256       maskAt = mask->lbounds();
257     }
258     if (dim) { // DIM=
259       if (*dim < 1 || *dim > array->Rank()) {
260         context_.messages().Say("DIM=%d is out of range"_err_en_US, *dim);
261         return std::nullopt;
262       }
263       int zbDim{*dim - 1};
264       resultShape = array->shape();
265       resultShape.erase(
266           resultShape.begin() + zbDim); // scalar if array is vector
267       ConstantSubscript dimLength{array->shape()[zbDim]};
268       ConstantSubscript n{GetSize(resultShape)};
269       for (ConstantSubscript j{0}; j < n; ++j) {
270         ConstantSubscript hit{0};
271         if constexpr (WHICH == WhichLocation::Maxloc ||
272             WHICH == WhichLocation::Minloc) {
273           value.reset();
274         }
275         for (ConstantSubscript k{0}; k < dimLength;
276              ++k, ++at[zbDim], mask && ++maskAt[zbDim]) {
277           if ((!mask || mask->At(maskAt).IsTrue()) &&
278               IsHit(array->At(at), value, relation)) {
279             hit = at[zbDim];
280             if constexpr (WHICH == WhichLocation::Findloc) {
281               if (!back) {
282                 break;
283               }
284             }
285           }
286         }
287         resultIndices.emplace_back(hit);
288         at[zbDim] = std::max<ConstantSubscript>(dimLength, 1);
289         array->IncrementSubscripts(at);
290         at[zbDim] = 1;
291         if (mask) {
292           maskAt[zbDim] = mask->lbounds()[zbDim] +
293               std::max<ConstantSubscript>(dimLength, 1) - 1;
294           mask->IncrementSubscripts(maskAt);
295           maskAt[zbDim] = mask->lbounds()[zbDim];
296         }
297       }
298     } else { // no DIM=
299       resultShape = ConstantSubscripts{array->Rank()}; // always a vector
300       ConstantSubscript n{GetSize(array->shape())};
301       resultIndices = ConstantSubscripts(array->Rank(), 0);
302       for (ConstantSubscript j{0}; j < n; ++j, array->IncrementSubscripts(at),
303            mask && mask->IncrementSubscripts(maskAt)) {
304         if ((!mask || mask->At(maskAt).IsTrue()) &&
305             IsHit(array->At(at), value, relation)) {
306           resultIndices = at;
307           if constexpr (WHICH == WhichLocation::Findloc) {
308             if (!back) {
309               break;
310             }
311           }
312         }
313       }
314     }
315     std::vector<Scalar<SubscriptInteger>> resultElements;
316     for (ConstantSubscript j : resultIndices) {
317       resultElements.emplace_back(j);
318     }
319     return Constant<SubscriptInteger>{
320         std::move(resultElements), std::move(resultShape)};
321   }
322 
323 private:
324   template <typename T>
325   bool IsHit(typename Constant<T>::Element element,
326       std::optional<Constant<T>> &value,
327       [[maybe_unused]] RelationalOperator relation) const {
328     std::optional<Expr<LogicalResult>> cmp;
329     bool result{true};
330     if (value) {
331       if constexpr (T::category == TypeCategory::Logical) {
332         // array(at) .EQV. value?
333         static_assert(WHICH == WhichLocation::Findloc);
334         cmp.emplace(
335             ConvertToType<LogicalResult>(Expr<T>{LogicalOperation<T::kind>{
336                 LogicalOperator::Eqv, Expr<T>{Constant<T>{std::move(element)}},
337                 Expr<T>{Constant<T>{*value}}}}));
338       } else { // compare array(at) to value
339         cmp.emplace(
340             PackageRelation(relation, Expr<T>{Constant<T>{std::move(element)}},
341                 Expr<T>{Constant<T>{*value}}));
342       }
343       Expr<LogicalResult> folded{Fold(context_, std::move(*cmp))};
344       result = GetScalarConstantValue<LogicalResult>(folded).value().IsTrue();
345     } else {
346       // first unmasked element for MAXLOC/MINLOC - always take it
347     }
348     if constexpr (WHICH == WhichLocation::Maxloc ||
349         WHICH == WhichLocation::Minloc) {
350       if (result) {
351         value.emplace(std::move(element));
352       }
353     }
354     return result;
355   }
356 
357   static constexpr int dimArg{WHICH == WhichLocation::Findloc ? 2 : 1};
358   static constexpr int maskArg{dimArg + 1};
359   static constexpr int backArg{maskArg + 2};
360 
361   DynamicType type_;
362   ActualArguments &arg_;
363   FoldingContext &context_;
364 };
365 
366 template <WhichLocation which>
367 static std::optional<Constant<SubscriptInteger>> FoldLocationCall(
368     ActualArguments &arg, FoldingContext &context) {
369   if (arg[0]) {
370     if (auto type{arg[0]->GetType()}) {
371       return common::SearchTypes(
372           LocationHelper<which>{std::move(*type), arg, context});
373     }
374   }
375   return std::nullopt;
376 }
377 
378 template <WhichLocation which, typename T>
379 static Expr<T> FoldLocation(FoldingContext &context, FunctionRef<T> &&ref) {
380   static_assert(T::category == TypeCategory::Integer);
381   if (std::optional<Constant<SubscriptInteger>> found{
382           FoldLocationCall<which>(ref.arguments(), context)}) {
383     return Expr<T>{Fold(
384         context, ConvertToType<T>(Expr<SubscriptInteger>{std::move(*found)}))};
385   } else {
386     return Expr<T>{std::move(ref)};
387   }
388 }
389 
390 // for IALL, IANY, & IPARITY
391 template <typename T>
392 static Expr<T> FoldBitReduction(FoldingContext &context, FunctionRef<T> &&ref,
393     Scalar<T> (Scalar<T>::*operation)(const Scalar<T> &) const,
394     Scalar<T> identity) {
395   static_assert(T::category == TypeCategory::Integer);
396   std::optional<int> dim;
397   if (std::optional<Constant<T>> array{
398           ProcessReductionArgs<T>(context, ref.arguments(), dim, identity,
399               /*ARRAY=*/0, /*DIM=*/1, /*MASK=*/2)}) {
400     auto accumulator{[&](Scalar<T> &element, const ConstantSubscripts &at) {
401       element = (element.*operation)(array->At(at));
402     }};
403     return Expr<T>{DoReduction<T>(*array, dim, identity, accumulator)};
404   }
405   return Expr<T>{std::move(ref)};
406 }
407 
408 template <int KIND>
409 Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
410     FoldingContext &context,
411     FunctionRef<Type<TypeCategory::Integer, KIND>> &&funcRef) {
412   using T = Type<TypeCategory::Integer, KIND>;
413   using Int4 = Type<TypeCategory::Integer, 4>;
414   ActualArguments &args{funcRef.arguments()};
415   auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)};
416   CHECK(intrinsic);
417   std::string name{intrinsic->name};
418   if (name == "abs") { // incl. babs, iiabs, jiaabs, & kiabs
419     return FoldElementalIntrinsic<T, T>(context, std::move(funcRef),
420         ScalarFunc<T, T>([&context](const Scalar<T> &i) -> Scalar<T> {
421           typename Scalar<T>::ValueWithOverflow j{i.ABS()};
422           if (j.overflow) {
423             context.messages().Say(
424                 "abs(integer(kind=%d)) folding overflowed"_warn_en_US, KIND);
425           }
426           return j.value;
427         }));
428   } else if (name == "bit_size") {
429     return Expr<T>{Scalar<T>::bits};
430   } else if (name == "ceiling" || name == "floor" || name == "nint") {
431     if (const auto *cx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
432       // NINT rounds ties away from zero, not to even
433       common::RoundingMode mode{name == "ceiling" ? common::RoundingMode::Up
434               : name == "floor"                   ? common::RoundingMode::Down
435                                 : common::RoundingMode::TiesAwayFromZero};
436       return std::visit(
437           [&](const auto &kx) {
438             using TR = ResultType<decltype(kx)>;
439             return FoldElementalIntrinsic<T, TR>(context, std::move(funcRef),
440                 ScalarFunc<T, TR>([&](const Scalar<TR> &x) {
441                   auto y{x.template ToInteger<Scalar<T>>(mode)};
442                   if (y.flags.test(RealFlag::Overflow)) {
443                     context.messages().Say(
444                         "%s intrinsic folding overflow"_warn_en_US, name);
445                   }
446                   return y.value;
447                 }));
448           },
449           cx->u);
450     }
451   } else if (name == "count") {
452     return FoldCount<T>(context, std::move(funcRef));
453   } else if (name == "digits") {
454     if (const auto *cx{UnwrapExpr<Expr<SomeInteger>>(args[0])}) {
455       return Expr<T>{std::visit(
456           [](const auto &kx) {
457             return Scalar<ResultType<decltype(kx)>>::DIGITS;
458           },
459           cx->u)};
460     } else if (const auto *cx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
461       return Expr<T>{std::visit(
462           [](const auto &kx) {
463             return Scalar<ResultType<decltype(kx)>>::DIGITS;
464           },
465           cx->u)};
466     } else if (const auto *cx{UnwrapExpr<Expr<SomeComplex>>(args[0])}) {
467       return Expr<T>{std::visit(
468           [](const auto &kx) {
469             return Scalar<typename ResultType<decltype(kx)>::Part>::DIGITS;
470           },
471           cx->u)};
472     }
473   } else if (name == "dim") {
474     return FoldElementalIntrinsic<T, T, T>(
475         context, std::move(funcRef), &Scalar<T>::DIM);
476   } else if (name == "dshiftl" || name == "dshiftr") {
477     const auto fptr{
478         name == "dshiftl" ? &Scalar<T>::DSHIFTL : &Scalar<T>::DSHIFTR};
479     // Third argument can be of any kind. However, it must be smaller or equal
480     // than BIT_SIZE. It can be converted to Int4 to simplify.
481     return FoldElementalIntrinsic<T, T, T, Int4>(context, std::move(funcRef),
482         ScalarFunc<T, T, T, Int4>(
483             [&fptr](const Scalar<T> &i, const Scalar<T> &j,
484                 const Scalar<Int4> &shift) -> Scalar<T> {
485               return std::invoke(fptr, i, j, static_cast<int>(shift.ToInt64()));
486             }));
487   } else if (name == "exponent") {
488     if (auto *sx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
489       return std::visit(
490           [&funcRef, &context](const auto &x) -> Expr<T> {
491             using TR = typename std::decay_t<decltype(x)>::Result;
492             return FoldElementalIntrinsic<T, TR>(context, std::move(funcRef),
493                 &Scalar<TR>::template EXPONENT<Scalar<T>>);
494           },
495           sx->u);
496     } else {
497       DIE("exponent argument must be real");
498     }
499   } else if (name == "findloc") {
500     return FoldLocation<WhichLocation::Findloc, T>(context, std::move(funcRef));
501   } else if (name == "huge") {
502     return Expr<T>{Scalar<T>::HUGE()};
503   } else if (name == "iachar" || name == "ichar") {
504     auto *someChar{UnwrapExpr<Expr<SomeCharacter>>(args[0])};
505     CHECK(someChar);
506     if (auto len{ToInt64(someChar->LEN())}) {
507       if (len.value() != 1) {
508         // Do not die, this was not checked before
509         context.messages().Say(
510             "Character in intrinsic function %s must have length one"_warn_en_US,
511             name);
512       } else {
513         return std::visit(
514             [&funcRef, &context](const auto &str) -> Expr<T> {
515               using Char = typename std::decay_t<decltype(str)>::Result;
516               return FoldElementalIntrinsic<T, Char>(context,
517                   std::move(funcRef),
518                   ScalarFunc<T, Char>([](const Scalar<Char> &c) {
519                     return Scalar<T>{CharacterUtils<Char::kind>::ICHAR(c)};
520                   }));
521             },
522             someChar->u);
523       }
524     }
525   } else if (name == "iand" || name == "ior" || name == "ieor") {
526     auto fptr{&Scalar<T>::IAND};
527     if (name == "iand") { // done in fptr declaration
528     } else if (name == "ior") {
529       fptr = &Scalar<T>::IOR;
530     } else if (name == "ieor") {
531       fptr = &Scalar<T>::IEOR;
532     } else {
533       common::die("missing case to fold intrinsic function %s", name.c_str());
534     }
535     return FoldElementalIntrinsic<T, T, T>(
536         context, std::move(funcRef), ScalarFunc<T, T, T>(fptr));
537   } else if (name == "iall") {
538     return FoldBitReduction(
539         context, std::move(funcRef), &Scalar<T>::IAND, Scalar<T>{}.NOT());
540   } else if (name == "iany") {
541     return FoldBitReduction(
542         context, std::move(funcRef), &Scalar<T>::IOR, Scalar<T>{});
543   } else if (name == "ibclr" || name == "ibset") {
544     // Second argument can be of any kind. However, it must be smaller
545     // than BIT_SIZE. It can be converted to Int4 to simplify.
546     auto fptr{&Scalar<T>::IBCLR};
547     if (name == "ibclr") { // done in fptr definition
548     } else if (name == "ibset") {
549       fptr = &Scalar<T>::IBSET;
550     } else {
551       common::die("missing case to fold intrinsic function %s", name.c_str());
552     }
553     return FoldElementalIntrinsic<T, T, Int4>(context, std::move(funcRef),
554         ScalarFunc<T, T, Int4>([&](const Scalar<T> &i,
555                                    const Scalar<Int4> &pos) -> Scalar<T> {
556           auto posVal{static_cast<int>(pos.ToInt64())};
557           if (posVal < 0) {
558             context.messages().Say(
559                 "bit position for %s (%d) is negative"_err_en_US, name, posVal);
560           } else if (posVal >= i.bits) {
561             context.messages().Say(
562                 "bit position for %s (%d) is not less than %d"_err_en_US, name,
563                 posVal, i.bits);
564           }
565           return std::invoke(fptr, i, posVal);
566         }));
567   } else if (name == "index" || name == "scan" || name == "verify") {
568     if (auto *charExpr{UnwrapExpr<Expr<SomeCharacter>>(args[0])}) {
569       return std::visit(
570           [&](const auto &kch) -> Expr<T> {
571             using TC = typename std::decay_t<decltype(kch)>::Result;
572             if (UnwrapExpr<Expr<SomeLogical>>(args[2])) { // BACK=
573               return FoldElementalIntrinsic<T, TC, TC, LogicalResult>(context,
574                   std::move(funcRef),
575                   ScalarFunc<T, TC, TC, LogicalResult>{
576                       [&name](const Scalar<TC> &str, const Scalar<TC> &other,
577                           const Scalar<LogicalResult> &back) -> Scalar<T> {
578                         return name == "index"
579                             ? CharacterUtils<TC::kind>::INDEX(
580                                   str, other, back.IsTrue())
581                             : name == "scan" ? CharacterUtils<TC::kind>::SCAN(
582                                                    str, other, back.IsTrue())
583                                              : CharacterUtils<TC::kind>::VERIFY(
584                                                    str, other, back.IsTrue());
585                       }});
586             } else {
587               return FoldElementalIntrinsic<T, TC, TC>(context,
588                   std::move(funcRef),
589                   ScalarFunc<T, TC, TC>{
590                       [&name](const Scalar<TC> &str,
591                           const Scalar<TC> &other) -> Scalar<T> {
592                         return name == "index"
593                             ? CharacterUtils<TC::kind>::INDEX(str, other)
594                             : name == "scan"
595                             ? CharacterUtils<TC::kind>::SCAN(str, other)
596                             : CharacterUtils<TC::kind>::VERIFY(str, other);
597                       }});
598             }
599           },
600           charExpr->u);
601     } else {
602       DIE("first argument must be CHARACTER");
603     }
604   } else if (name == "int") {
605     if (auto *expr{UnwrapExpr<Expr<SomeType>>(args[0])}) {
606       return std::visit(
607           [&](auto &&x) -> Expr<T> {
608             using From = std::decay_t<decltype(x)>;
609             if constexpr (std::is_same_v<From, BOZLiteralConstant> ||
610                 IsNumericCategoryExpr<From>()) {
611               return Fold(context, ConvertToType<T>(std::move(x)));
612             }
613             DIE("int() argument type not valid");
614           },
615           std::move(expr->u));
616     }
617   } else if (name == "int_ptr_kind") {
618     return Expr<T>{8};
619   } else if (name == "kind") {
620     if constexpr (common::HasMember<T, IntegerTypes>) {
621       return Expr<T>{args[0].value().GetType()->kind()};
622     } else {
623       DIE("kind() result not integral");
624     }
625   } else if (name == "iparity") {
626     return FoldBitReduction(
627         context, std::move(funcRef), &Scalar<T>::IEOR, Scalar<T>{});
628   } else if (name == "ishft") {
629     return FoldElementalIntrinsic<T, T, Int4>(context, std::move(funcRef),
630         ScalarFunc<T, T, Int4>([&](const Scalar<T> &i,
631                                    const Scalar<Int4> &pos) -> Scalar<T> {
632           auto posVal{static_cast<int>(pos.ToInt64())};
633           if (posVal < -i.bits) {
634             context.messages().Say(
635                 "SHIFT=%d count for ishft is less than %d"_err_en_US, posVal,
636                 -i.bits);
637           } else if (posVal > i.bits) {
638             context.messages().Say(
639                 "SHIFT=%d count for ishft is greater than %d"_err_en_US, posVal,
640                 i.bits);
641           }
642           return i.ISHFT(posVal);
643         }));
644   } else if (name == "lbound") {
645     return LBOUND(context, std::move(funcRef));
646   } else if (name == "leadz" || name == "trailz" || name == "poppar" ||
647       name == "popcnt") {
648     if (auto *sn{UnwrapExpr<Expr<SomeInteger>>(args[0])}) {
649       return std::visit(
650           [&funcRef, &context, &name](const auto &n) -> Expr<T> {
651             using TI = typename std::decay_t<decltype(n)>::Result;
652             if (name == "poppar") {
653               return FoldElementalIntrinsic<T, TI>(context, std::move(funcRef),
654                   ScalarFunc<T, TI>([](const Scalar<TI> &i) -> Scalar<T> {
655                     return Scalar<T>{i.POPPAR() ? 1 : 0};
656                   }));
657             }
658             auto fptr{&Scalar<TI>::LEADZ};
659             if (name == "leadz") { // done in fptr definition
660             } else if (name == "trailz") {
661               fptr = &Scalar<TI>::TRAILZ;
662             } else if (name == "popcnt") {
663               fptr = &Scalar<TI>::POPCNT;
664             } else {
665               common::die(
666                   "missing case to fold intrinsic function %s", name.c_str());
667             }
668             return FoldElementalIntrinsic<T, TI>(context, std::move(funcRef),
669                 ScalarFunc<T, TI>([&fptr](const Scalar<TI> &i) -> Scalar<T> {
670                   return Scalar<T>{std::invoke(fptr, i)};
671                 }));
672           },
673           sn->u);
674     } else {
675       DIE("leadz argument must be integer");
676     }
677   } else if (name == "len") {
678     if (auto *charExpr{UnwrapExpr<Expr<SomeCharacter>>(args[0])}) {
679       return std::visit(
680           [&](auto &kx) {
681             if (auto len{kx.LEN()}) {
682               if (IsScopeInvariantExpr(*len)) {
683                 return Fold(context, ConvertToType<T>(*std::move(len)));
684               } else {
685                 return Expr<T>{std::move(funcRef)};
686               }
687             } else {
688               return Expr<T>{std::move(funcRef)};
689             }
690           },
691           charExpr->u);
692     } else {
693       DIE("len() argument must be of character type");
694     }
695   } else if (name == "len_trim") {
696     if (auto *charExpr{UnwrapExpr<Expr<SomeCharacter>>(args[0])}) {
697       return std::visit(
698           [&](const auto &kch) -> Expr<T> {
699             using TC = typename std::decay_t<decltype(kch)>::Result;
700             return FoldElementalIntrinsic<T, TC>(context, std::move(funcRef),
701                 ScalarFunc<T, TC>{[](const Scalar<TC> &str) -> Scalar<T> {
702                   return CharacterUtils<TC::kind>::LEN_TRIM(str);
703                 }});
704           },
705           charExpr->u);
706     } else {
707       DIE("len_trim() argument must be of character type");
708     }
709   } else if (name == "maskl" || name == "maskr") {
710     // Argument can be of any kind but value has to be smaller than BIT_SIZE.
711     // It can be safely converted to Int4 to simplify.
712     const auto fptr{name == "maskl" ? &Scalar<T>::MASKL : &Scalar<T>::MASKR};
713     return FoldElementalIntrinsic<T, Int4>(context, std::move(funcRef),
714         ScalarFunc<T, Int4>([&fptr](const Scalar<Int4> &places) -> Scalar<T> {
715           return fptr(static_cast<int>(places.ToInt64()));
716         }));
717   } else if (name == "max") {
718     return FoldMINorMAX(context, std::move(funcRef), Ordering::Greater);
719   } else if (name == "max0" || name == "max1") {
720     return RewriteSpecificMINorMAX(context, std::move(funcRef));
721   } else if (name == "maxexponent") {
722     if (auto *sx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
723       return std::visit(
724           [](const auto &x) {
725             using TR = typename std::decay_t<decltype(x)>::Result;
726             return Expr<T>{Scalar<TR>::MAXEXPONENT};
727           },
728           sx->u);
729     }
730   } else if (name == "maxloc") {
731     return FoldLocation<WhichLocation::Maxloc, T>(context, std::move(funcRef));
732   } else if (name == "maxval") {
733     return FoldMaxvalMinval<T>(context, std::move(funcRef),
734         RelationalOperator::GT, T::Scalar::Least());
735   } else if (name == "merge") {
736     return FoldMerge<T>(context, std::move(funcRef));
737   } else if (name == "merge_bits") {
738     return FoldElementalIntrinsic<T, T, T, T>(
739         context, std::move(funcRef), &Scalar<T>::MERGE_BITS);
740   } else if (name == "min") {
741     return FoldMINorMAX(context, std::move(funcRef), Ordering::Less);
742   } else if (name == "min0" || name == "min1") {
743     return RewriteSpecificMINorMAX(context, std::move(funcRef));
744   } else if (name == "minexponent") {
745     if (auto *sx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
746       return std::visit(
747           [](const auto &x) {
748             using TR = typename std::decay_t<decltype(x)>::Result;
749             return Expr<T>{Scalar<TR>::MINEXPONENT};
750           },
751           sx->u);
752     }
753   } else if (name == "minloc") {
754     return FoldLocation<WhichLocation::Minloc, T>(context, std::move(funcRef));
755   } else if (name == "minval") {
756     return FoldMaxvalMinval<T>(
757         context, std::move(funcRef), RelationalOperator::LT, T::Scalar::HUGE());
758   } else if (name == "mod") {
759     return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
760         ScalarFuncWithContext<T, T, T>(
761             [](FoldingContext &context, const Scalar<T> &x,
762                 const Scalar<T> &y) -> Scalar<T> {
763               auto quotRem{x.DivideSigned(y)};
764               if (quotRem.divisionByZero) {
765                 context.messages().Say("mod() by zero"_warn_en_US);
766               } else if (quotRem.overflow) {
767                 context.messages().Say("mod() folding overflowed"_warn_en_US);
768               }
769               return quotRem.remainder;
770             }));
771   } else if (name == "modulo") {
772     return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
773         ScalarFuncWithContext<T, T, T>(
774             [](FoldingContext &context, const Scalar<T> &x,
775                 const Scalar<T> &y) -> Scalar<T> {
776               auto result{x.MODULO(y)};
777               if (result.overflow) {
778                 context.messages().Say(
779                     "modulo() folding overflowed"_warn_en_US);
780               }
781               return result.value;
782             }));
783   } else if (name == "not") {
784     return FoldElementalIntrinsic<T, T>(
785         context, std::move(funcRef), &Scalar<T>::NOT);
786   } else if (name == "precision") {
787     if (const auto *cx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
788       return Expr<T>{std::visit(
789           [](const auto &kx) {
790             return Scalar<ResultType<decltype(kx)>>::PRECISION;
791           },
792           cx->u)};
793     } else if (const auto *cx{UnwrapExpr<Expr<SomeComplex>>(args[0])}) {
794       return Expr<T>{std::visit(
795           [](const auto &kx) {
796             return Scalar<typename ResultType<decltype(kx)>::Part>::PRECISION;
797           },
798           cx->u)};
799     }
800   } else if (name == "product") {
801     return FoldProduct<T>(context, std::move(funcRef), Scalar<T>{1});
802   } else if (name == "radix") {
803     return Expr<T>{2};
804   } else if (name == "range") {
805     if (const auto *cx{UnwrapExpr<Expr<SomeInteger>>(args[0])}) {
806       return Expr<T>{std::visit(
807           [](const auto &kx) {
808             return Scalar<ResultType<decltype(kx)>>::RANGE;
809           },
810           cx->u)};
811     } else if (const auto *cx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
812       return Expr<T>{std::visit(
813           [](const auto &kx) {
814             return Scalar<ResultType<decltype(kx)>>::RANGE;
815           },
816           cx->u)};
817     } else if (const auto *cx{UnwrapExpr<Expr<SomeComplex>>(args[0])}) {
818       return Expr<T>{std::visit(
819           [](const auto &kx) {
820             return Scalar<typename ResultType<decltype(kx)>::Part>::RANGE;
821           },
822           cx->u)};
823     }
824   } else if (name == "rank") {
825     if (const auto *array{UnwrapExpr<Expr<SomeType>>(args[0])}) {
826       if (auto named{ExtractNamedEntity(*array)}) {
827         const Symbol &symbol{named->GetLastSymbol()};
828         if (IsAssumedRank(symbol)) {
829           // DescriptorInquiry can only be placed in expression of kind
830           // DescriptorInquiry::Result::kind.
831           return ConvertToType<T>(Expr<
832               Type<TypeCategory::Integer, DescriptorInquiry::Result::kind>>{
833               DescriptorInquiry{*named, DescriptorInquiry::Field::Rank}});
834         }
835       }
836       return Expr<T>{args[0].value().Rank()};
837     }
838     return Expr<T>{args[0].value().Rank()};
839   } else if (name == "selected_char_kind") {
840     if (const auto *chCon{UnwrapExpr<Constant<TypeOf<std::string>>>(args[0])}) {
841       if (std::optional<std::string> value{chCon->GetScalarValue()}) {
842         int defaultKind{
843             context.defaults().GetDefaultKind(TypeCategory::Character)};
844         return Expr<T>{SelectedCharKind(*value, defaultKind)};
845       }
846     }
847   } else if (name == "selected_int_kind") {
848     if (auto p{GetInt64Arg(args[0])}) {
849       return Expr<T>{SelectedIntKind(*p)};
850     }
851   } else if (name == "selected_real_kind" ||
852       name == "__builtin_ieee_selected_real_kind") {
853     if (auto p{GetInt64ArgOr(args[0], 0)}) {
854       if (auto r{GetInt64ArgOr(args[1], 0)}) {
855         if (auto radix{GetInt64ArgOr(args[2], 2)}) {
856           return Expr<T>{SelectedRealKind(*p, *r, *radix)};
857         }
858       }
859     }
860   } else if (name == "shape") {
861     if (auto shape{GetContextFreeShape(context, args[0])}) {
862       if (auto shapeExpr{AsExtentArrayExpr(*shape)}) {
863         return Fold(context, ConvertToType<T>(std::move(*shapeExpr)));
864       }
865     }
866   } else if (name == "shifta" || name == "shiftr" || name == "shiftl") {
867     // Second argument can be of any kind. However, it must be smaller or
868     // equal than BIT_SIZE. It can be converted to Int4 to simplify.
869     auto fptr{&Scalar<T>::SHIFTA};
870     if (name == "shifta") { // done in fptr definition
871     } else if (name == "shiftr") {
872       fptr = &Scalar<T>::SHIFTR;
873     } else if (name == "shiftl") {
874       fptr = &Scalar<T>::SHIFTL;
875     } else {
876       common::die("missing case to fold intrinsic function %s", name.c_str());
877     }
878     return FoldElementalIntrinsic<T, T, Int4>(context, std::move(funcRef),
879         ScalarFunc<T, T, Int4>([&](const Scalar<T> &i,
880                                    const Scalar<Int4> &pos) -> Scalar<T> {
881           auto posVal{static_cast<int>(pos.ToInt64())};
882           if (posVal < 0) {
883             context.messages().Say(
884                 "SHIFT=%d count for %s is negative"_err_en_US, posVal, name);
885           } else if (posVal > i.bits) {
886             context.messages().Say(
887                 "SHIFT=%d count for %s is greater than %d"_err_en_US, posVal,
888                 name, i.bits);
889           }
890           return std::invoke(fptr, i, posVal);
891         }));
892   } else if (name == "sign") {
893     return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
894         ScalarFunc<T, T, T>(
895             [&context](const Scalar<T> &j, const Scalar<T> &k) -> Scalar<T> {
896               typename Scalar<T>::ValueWithOverflow result{j.SIGN(k)};
897               if (result.overflow) {
898                 context.messages().Say(
899                     "sign(integer(kind=%d)) folding overflowed"_warn_en_US,
900                     KIND);
901               }
902               return result.value;
903             }));
904   } else if (name == "size") {
905     if (auto shape{GetContextFreeShape(context, args[0])}) {
906       if (auto &dimArg{args[1]}) { // DIM= is present, get one extent
907         if (auto dim{GetInt64Arg(args[1])}) {
908           int rank{GetRank(*shape)};
909           if (*dim >= 1 && *dim <= rank) {
910             const Symbol *symbol{UnwrapWholeSymbolDataRef(args[0])};
911             if (symbol && IsAssumedSizeArray(*symbol) && *dim == rank) {
912               context.messages().Say(
913                   "size(array,dim=%jd) of last dimension is not available for rank-%d assumed-size array dummy argument"_err_en_US,
914                   *dim, rank);
915               return MakeInvalidIntrinsic<T>(std::move(funcRef));
916             } else if (auto &extent{shape->at(*dim - 1)}) {
917               return Fold(context, ConvertToType<T>(std::move(*extent)));
918             }
919           } else {
920             context.messages().Say(
921                 "size(array,dim=%jd) dimension is out of range for rank-%d array"_warn_en_US,
922                 *dim, rank);
923           }
924         }
925       } else if (auto extents{common::AllElementsPresent(std::move(*shape))}) {
926         // DIM= is absent; compute PRODUCT(SHAPE())
927         ExtentExpr product{1};
928         for (auto &&extent : std::move(*extents)) {
929           product = std::move(product) * std::move(extent);
930         }
931         return Expr<T>{ConvertToType<T>(Fold(context, std::move(product)))};
932       }
933     }
934   } else if (name == "sizeof") { // in bytes; extension
935     if (auto info{
936             characteristics::TypeAndShape::Characterize(args[0], context)}) {
937       if (auto bytes{info->MeasureSizeInBytes(context)}) {
938         return Expr<T>{Fold(context, ConvertToType<T>(std::move(*bytes)))};
939       }
940     }
941   } else if (name == "storage_size") { // in bits
942     if (auto info{
943             characteristics::TypeAndShape::Characterize(args[0], context)}) {
944       if (auto bytes{info->MeasureElementSizeInBytes(context, true)}) {
945         return Expr<T>{
946             Fold(context, Expr<T>{8} * ConvertToType<T>(std::move(*bytes)))};
947       }
948     }
949   } else if (name == "sum") {
950     return FoldSum<T>(context, std::move(funcRef));
951   } else if (name == "ubound") {
952     return UBOUND(context, std::move(funcRef));
953   }
954   // TODO: dot_product, ibits, ishftc, matmul, sign, transfer
955   return Expr<T>{std::move(funcRef)};
956 }
957 
958 // Substitutes a bare type parameter reference with its value if it has one now
959 // in an instantiation.  Bare LEN type parameters are substituted only when
960 // the known value is constant.
961 Expr<TypeParamInquiry::Result> FoldOperation(
962     FoldingContext &context, TypeParamInquiry &&inquiry) {
963   std::optional<NamedEntity> base{inquiry.base()};
964   parser::CharBlock parameterName{inquiry.parameter().name()};
965   if (base) {
966     // Handling "designator%typeParam".  Get the value of the type parameter
967     // from the instantiation of the base
968     if (const semantics::DeclTypeSpec *
969         declType{base->GetLastSymbol().GetType()}) {
970       if (const semantics::ParamValue *
971           paramValue{
972               declType->derivedTypeSpec().FindParameter(parameterName)}) {
973         const semantics::MaybeIntExpr &paramExpr{paramValue->GetExplicit()};
974         if (paramExpr && IsConstantExpr(*paramExpr)) {
975           Expr<SomeInteger> intExpr{*paramExpr};
976           return Fold(context,
977               ConvertToType<TypeParamInquiry::Result>(std::move(intExpr)));
978         }
979       }
980     }
981   } else {
982     // A "bare" type parameter: replace with its value, if that's now known
983     // in a current derived type instantiation, for KIND type parameters.
984     if (const auto *pdt{context.pdtInstance()}) {
985       bool isLen{false};
986       if (const semantics::Scope * scope{context.pdtInstance()->scope()}) {
987         auto iter{scope->find(parameterName)};
988         if (iter != scope->end()) {
989           const Symbol &symbol{*iter->second};
990           const auto *details{symbol.detailsIf<semantics::TypeParamDetails>()};
991           if (details) {
992             isLen = details->attr() == common::TypeParamAttr::Len;
993             const semantics::MaybeIntExpr &initExpr{details->init()};
994             if (initExpr && IsConstantExpr(*initExpr) &&
995                 (!isLen || ToInt64(*initExpr))) {
996               Expr<SomeInteger> expr{*initExpr};
997               return Fold(context,
998                   ConvertToType<TypeParamInquiry::Result>(std::move(expr)));
999             }
1000           }
1001         }
1002       }
1003       if (const auto *value{pdt->FindParameter(parameterName)}) {
1004         if (value->isExplicit()) {
1005           auto folded{Fold(context,
1006               AsExpr(ConvertToType<TypeParamInquiry::Result>(
1007                   Expr<SomeInteger>{value->GetExplicit().value()})))};
1008           if (!isLen || ToInt64(folded)) {
1009             return folded;
1010           }
1011         }
1012       }
1013     }
1014   }
1015   return AsExpr(std::move(inquiry));
1016 }
1017 
1018 std::optional<std::int64_t> ToInt64(const Expr<SomeInteger> &expr) {
1019   return std::visit(
1020       [](const auto &kindExpr) { return ToInt64(kindExpr); }, expr.u);
1021 }
1022 
1023 std::optional<std::int64_t> ToInt64(const Expr<SomeType> &expr) {
1024   if (const auto *intExpr{UnwrapExpr<Expr<SomeInteger>>(expr)}) {
1025     return ToInt64(*intExpr);
1026   } else {
1027     return std::nullopt;
1028   }
1029 }
1030 
1031 #ifdef _MSC_VER // disable bogus warning about missing definitions
1032 #pragma warning(disable : 4661)
1033 #endif
1034 FOR_EACH_INTEGER_KIND(template class ExpressionBase, )
1035 template class ExpressionBase<SomeInteger>;
1036 } // namespace Fortran::evaluate
1037