xref: /llvm-project/flang/lib/Evaluate/fold-integer.cpp (revision fc97d2e68b03bc2979395e84b645e5b3ba35aecd) 
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-matmul.h"
11 #include "fold-reduction.h"
12 #include "flang/Evaluate/check-expression.h"
13 
14 namespace Fortran::evaluate {
15 
16 // Given a collection of ConstantSubscripts values, package them as a Constant.
17 // Return scalar value if asScalar == true and shape-dim array otherwise.
18 template <typename T>
19 Expr<T> PackageConstantBounds(
20     const ConstantSubscripts &&bounds, bool asScalar = false) {
21   if (asScalar) {
22     return Expr<T>{Constant<T>{bounds.at(0)}};
23   } else {
24     // As rank-dim array
25     const int rank{GetRank(bounds)};
26     std::vector<Scalar<T>> packed(rank);
27     std::transform(bounds.begin(), bounds.end(), packed.begin(),
28         [](ConstantSubscript x) { return Scalar<T>(x); });
29     return Expr<T>{Constant<T>{std::move(packed), ConstantSubscripts{rank}}};
30   }
31 }
32 
33 // If a DIM= argument to LBOUND(), UBOUND(), or SIZE() exists and has a valid
34 // constant value, return in "dimVal" that value, less 1 (to make it suitable
35 // for use as a C++ vector<> index).  Also check for erroneous constant values
36 // and returns false on error.
37 static bool CheckDimArg(const std::optional<ActualArgument> &dimArg,
38     const Expr<SomeType> &array, parser::ContextualMessages &messages,
39     bool isLBound, std::optional<int> &dimVal) {
40   dimVal.reset();
41   if (int rank{array.Rank()}; rank > 0 || IsAssumedRank(array)) {
42     auto named{ExtractNamedEntity(array)};
43     if (auto dim64{ToInt64(dimArg)}) {
44       if (*dim64 < 1) {
45         messages.Say("DIM=%jd dimension must be positive"_err_en_US, *dim64);
46         return false;
47       } else if (!IsAssumedRank(array) && *dim64 > rank) {
48         messages.Say(
49             "DIM=%jd dimension is out of range for rank-%d array"_err_en_US,
50             *dim64, rank);
51         return false;
52       } else if (!isLBound && named &&
53           semantics::IsAssumedSizeArray(named->GetLastSymbol()) &&
54           *dim64 == rank) {
55         messages.Say(
56             "DIM=%jd dimension is out of range for rank-%d assumed-size array"_err_en_US,
57             *dim64, rank);
58         return false;
59       } else if (IsAssumedRank(array)) {
60         if (*dim64 > common::maxRank) {
61           messages.Say(
62               "DIM=%jd dimension is too large for any array (maximum rank %d)"_err_en_US,
63               *dim64, common::maxRank);
64           return false;
65         }
66       } else {
67         dimVal = static_cast<int>(*dim64 - 1); // 1-based to 0-based
68       }
69     }
70   }
71   return true;
72 }
73 
74 // Class to retrieve the constant bound of an expression which is an
75 // array that devolves to a type of Constant<T>
76 class GetConstantArrayBoundHelper {
77 public:
78   template <typename T>
79   static Expr<T> GetLbound(
80       const Expr<SomeType> &array, std::optional<int> dim) {
81     return PackageConstantBounds<T>(
82         GetConstantArrayBoundHelper(dim, /*getLbound=*/true).Get(array),
83         dim.has_value());
84   }
85 
86   template <typename T>
87   static Expr<T> GetUbound(
88       const Expr<SomeType> &array, std::optional<int> dim) {
89     return PackageConstantBounds<T>(
90         GetConstantArrayBoundHelper(dim, /*getLbound=*/false).Get(array),
91         dim.has_value());
92   }
93 
94 private:
95   GetConstantArrayBoundHelper(
96       std::optional<ConstantSubscript> dim, bool getLbound)
97       : dim_{dim}, getLbound_{getLbound} {}
98 
99   template <typename T> ConstantSubscripts Get(const T &) {
100     // The method is needed for template expansion, but we should never get
101     // here in practice.
102     CHECK(false);
103     return {0};
104   }
105 
106   template <typename T> ConstantSubscripts Get(const Constant<T> &x) {
107     if (getLbound_) {
108       // Return the lower bound
109       if (dim_) {
110         return {x.lbounds().at(*dim_)};
111       } else {
112         return x.lbounds();
113       }
114     } else {
115       // Return the upper bound
116       if (arrayFromParenthesesExpr) {
117         // Underlying array comes from (x) expression - return shapes
118         if (dim_) {
119           return {x.shape().at(*dim_)};
120         } else {
121           return x.shape();
122         }
123       } else {
124         return x.ComputeUbounds(dim_);
125       }
126     }
127   }
128 
129   template <typename T> ConstantSubscripts Get(const Parentheses<T> &x) {
130     // Case of temp variable inside parentheses - return [1, ... 1] for lower
131     // bounds and shape for upper bounds
132     if (getLbound_) {
133       return ConstantSubscripts(x.Rank(), ConstantSubscript{1});
134     } else {
135       // Indicate that underlying array comes from parentheses expression.
136       // Continue to unwrap expression until we hit a constant
137       arrayFromParenthesesExpr = true;
138       return Get(x.left());
139     }
140   }
141 
142   template <typename T> ConstantSubscripts Get(const Expr<T> &x) {
143     // recurse through Expr<T>'a until we hit a constant
144     return common::visit([&](const auto &inner) { return Get(inner); },
145         //      [&](const auto &) { return 0; },
146         x.u);
147   }
148 
149   const std::optional<ConstantSubscript> dim_;
150   const bool getLbound_;
151   bool arrayFromParenthesesExpr{false};
152 };
153 
154 template <int KIND>
155 Expr<Type<TypeCategory::Integer, KIND>> LBOUND(FoldingContext &context,
156     FunctionRef<Type<TypeCategory::Integer, KIND>> &&funcRef) {
157   using T = Type<TypeCategory::Integer, KIND>;
158   ActualArguments &args{funcRef.arguments()};
159   if (const auto *array{UnwrapExpr<Expr<SomeType>>(args[0])}) {
160     std::optional<int> dim;
161     if (funcRef.Rank() == 0) {
162       // Optional DIM= argument is present: result is scalar.
163       if (!CheckDimArg(args[1], *array, context.messages(), true, dim)) {
164         return MakeInvalidIntrinsic<T>(std::move(funcRef));
165       } else if (!dim) {
166         // DIM= is present but not constant, or error
167         return Expr<T>{std::move(funcRef)};
168       }
169     }
170     if (IsAssumedRank(*array)) {
171       // Would like to return 1 if DIM=.. is present, but that would be
172       // hiding a runtime error if the DIM= were too large (including
173       // the case of an assumed-rank argument that's scalar).
174     } else if (int rank{array->Rank()}; rank > 0) {
175       bool lowerBoundsAreOne{true};
176       if (auto named{ExtractNamedEntity(*array)}) {
177         const Symbol &symbol{named->GetLastSymbol()};
178         if (symbol.Rank() == rank) {
179           lowerBoundsAreOne = false;
180           if (dim) {
181             if (auto lb{GetLBOUND(context, *named, *dim)}) {
182               return Fold(context, ConvertToType<T>(std::move(*lb)));
183             }
184           } else if (auto extents{
185                          AsExtentArrayExpr(GetLBOUNDs(context, *named))}) {
186             return Fold(context,
187                 ConvertToType<T>(Expr<ExtentType>{std::move(*extents)}));
188           }
189         } else {
190           lowerBoundsAreOne = symbol.Rank() == 0; // LBOUND(array%component)
191         }
192       }
193       if (IsActuallyConstant(*array)) {
194         return GetConstantArrayBoundHelper::GetLbound<T>(*array, dim);
195       }
196       if (lowerBoundsAreOne) {
197         ConstantSubscripts ones(rank, ConstantSubscript{1});
198         return PackageConstantBounds<T>(std::move(ones), dim.has_value());
199       }
200     }
201   }
202   return Expr<T>{std::move(funcRef)};
203 }
204 
205 template <int KIND>
206 Expr<Type<TypeCategory::Integer, KIND>> UBOUND(FoldingContext &context,
207     FunctionRef<Type<TypeCategory::Integer, KIND>> &&funcRef) {
208   using T = Type<TypeCategory::Integer, KIND>;
209   ActualArguments &args{funcRef.arguments()};
210   if (auto *array{UnwrapExpr<Expr<SomeType>>(args[0])}) {
211     std::optional<int> dim;
212     if (funcRef.Rank() == 0) {
213       // Optional DIM= argument is present: result is scalar.
214       if (!CheckDimArg(args[1], *array, context.messages(), false, dim)) {
215         return MakeInvalidIntrinsic<T>(std::move(funcRef));
216       } else if (!dim) {
217         // DIM= is present but not constant, or error
218         return Expr<T>{std::move(funcRef)};
219       }
220     }
221     if (IsAssumedRank(*array)) {
222     } else if (int rank{array->Rank()}; rank > 0) {
223       bool takeBoundsFromShape{true};
224       if (auto named{ExtractNamedEntity(*array)}) {
225         const Symbol &symbol{named->GetLastSymbol()};
226         if (symbol.Rank() == rank) {
227           takeBoundsFromShape = false;
228           if (dim) {
229             if (auto ub{GetUBOUND(context, *named, *dim)}) {
230               return Fold(context, ConvertToType<T>(std::move(*ub)));
231             }
232           } else {
233             Shape ubounds{GetUBOUNDs(context, *named)};
234             if (semantics::IsAssumedSizeArray(symbol)) {
235               CHECK(!ubounds.back());
236               ubounds.back() = ExtentExpr{-1};
237             }
238             if (auto extents{AsExtentArrayExpr(ubounds)}) {
239               return Fold(context,
240                   ConvertToType<T>(Expr<ExtentType>{std::move(*extents)}));
241             }
242           }
243         } else {
244           takeBoundsFromShape = symbol.Rank() == 0; // UBOUND(array%component)
245         }
246       }
247       if (IsActuallyConstant(*array)) {
248         return GetConstantArrayBoundHelper::GetUbound<T>(*array, dim);
249       }
250       if (takeBoundsFromShape) {
251         if (auto shape{GetContextFreeShape(context, *array)}) {
252           if (dim) {
253             if (auto &dimSize{shape->at(*dim)}) {
254               return Fold(context,
255                   ConvertToType<T>(Expr<ExtentType>{std::move(*dimSize)}));
256             }
257           } else if (auto shapeExpr{AsExtentArrayExpr(*shape)}) {
258             return Fold(context, ConvertToType<T>(std::move(*shapeExpr)));
259           }
260         }
261       }
262     }
263   }
264   return Expr<T>{std::move(funcRef)};
265 }
266 
267 // COUNT()
268 template <typename T, int MASK_KIND> class CountAccumulator {
269   using MaskT = Type<TypeCategory::Logical, MASK_KIND>;
270 
271 public:
272   CountAccumulator(const Constant<MaskT> &mask) : mask_{mask} {}
273   void operator()(
274       Scalar<T> &element, const ConstantSubscripts &at, bool /*first*/) {
275     if (mask_.At(at).IsTrue()) {
276       auto incremented{element.AddSigned(Scalar<T>{1})};
277       overflow_ |= incremented.overflow;
278       element = incremented.value;
279     }
280   }
281   bool overflow() const { return overflow_; }
282   void Done(Scalar<T> &) const {}
283 
284 private:
285   const Constant<MaskT> &mask_;
286   bool overflow_{false};
287 };
288 
289 template <typename T, int maskKind>
290 static Expr<T> FoldCount(FoldingContext &context, FunctionRef<T> &&ref) {
291   using KindLogical = Type<TypeCategory::Logical, maskKind>;
292   static_assert(T::category == TypeCategory::Integer);
293   std::optional<int> dim;
294   if (std::optional<ArrayAndMask<KindLogical>> arrayAndMask{
295           ProcessReductionArgs<KindLogical>(
296               context, ref.arguments(), dim, /*ARRAY=*/0, /*DIM=*/1)}) {
297     CountAccumulator<T, maskKind> accumulator{arrayAndMask->array};
298     Constant<T> result{DoReduction<T>(arrayAndMask->array, arrayAndMask->mask,
299         dim, Scalar<T>{}, accumulator)};
300     if (accumulator.overflow() &&
301         context.languageFeatures().ShouldWarn(
302             common::UsageWarning::FoldingException)) {
303       context.messages().Say(common::UsageWarning::FoldingException,
304           "Result of intrinsic function COUNT overflows its result type"_warn_en_US);
305     }
306     return Expr<T>{std::move(result)};
307   }
308   return Expr<T>{std::move(ref)};
309 }
310 
311 // FINDLOC(), MAXLOC(), & MINLOC()
312 enum class WhichLocation { Findloc, Maxloc, Minloc };
313 template <WhichLocation WHICH> class LocationHelper {
314 public:
315   LocationHelper(
316       DynamicType &&type, ActualArguments &arg, FoldingContext &context)
317       : type_{type}, arg_{arg}, context_{context} {}
318   using Result = std::optional<Constant<SubscriptInteger>>;
319   using Types = std::conditional_t<WHICH == WhichLocation::Findloc,
320       AllIntrinsicTypes, RelationalTypes>;
321 
322   template <typename T> Result Test() const {
323     if (T::category != type_.category() || T::kind != type_.kind()) {
324       return std::nullopt;
325     }
326     CHECK(arg_.size() == (WHICH == WhichLocation::Findloc ? 6 : 5));
327     Folder<T> folder{context_};
328     Constant<T> *array{folder.Folding(arg_[0])};
329     if (!array) {
330       return std::nullopt;
331     }
332     std::optional<Constant<T>> value;
333     if constexpr (WHICH == WhichLocation::Findloc) {
334       if (const Constant<T> *p{folder.Folding(arg_[1])}) {
335         value.emplace(*p);
336       } else {
337         return std::nullopt;
338       }
339     }
340     std::optional<int> dim;
341     Constant<LogicalResult> *mask{
342         GetReductionMASK(arg_[maskArg], array->shape(), context_)};
343     if ((!mask && arg_[maskArg]) ||
344         !CheckReductionDIM(dim, context_, arg_, dimArg, array->Rank())) {
345       return std::nullopt;
346     }
347     bool back{false};
348     if (arg_[backArg]) {
349       const auto *backConst{
350           Folder<LogicalResult>{context_, /*forOptionalArgument=*/true}.Folding(
351               arg_[backArg])};
352       if (backConst) {
353         back = backConst->GetScalarValue().value().IsTrue();
354       } else {
355         return std::nullopt;
356       }
357     }
358     const RelationalOperator relation{WHICH == WhichLocation::Findloc
359             ? RelationalOperator::EQ
360             : WHICH == WhichLocation::Maxloc
361             ? (back ? RelationalOperator::GE : RelationalOperator::GT)
362             : back ? RelationalOperator::LE
363                    : RelationalOperator::LT};
364     // Use lower bounds of 1 exclusively.
365     array->SetLowerBoundsToOne();
366     ConstantSubscripts at{array->lbounds()}, maskAt, resultIndices, resultShape;
367     if (mask) {
368       if (auto scalarMask{mask->GetScalarValue()}) {
369         // Convert into array in case of scalar MASK= (for
370         // MAXLOC/MINLOC/FINDLOC mask should be conformable)
371         ConstantSubscript n{GetSize(array->shape())};
372         std::vector<Scalar<LogicalResult>> mask_elements(
373             n, Scalar<LogicalResult>{scalarMask.value()});
374         *mask = Constant<LogicalResult>{
375             std::move(mask_elements), ConstantSubscripts{array->shape()}};
376       }
377       mask->SetLowerBoundsToOne();
378       maskAt = mask->lbounds();
379     }
380     if (dim) { // DIM=
381       if (*dim < 1 || *dim > array->Rank()) {
382         context_.messages().Say("DIM=%d is out of range"_err_en_US, *dim);
383         return std::nullopt;
384       }
385       int zbDim{*dim - 1};
386       resultShape = array->shape();
387       resultShape.erase(
388           resultShape.begin() + zbDim); // scalar if array is vector
389       ConstantSubscript dimLength{array->shape()[zbDim]};
390       ConstantSubscript n{GetSize(resultShape)};
391       for (ConstantSubscript j{0}; j < n; ++j) {
392         ConstantSubscript hit{0};
393         if constexpr (WHICH == WhichLocation::Maxloc ||
394             WHICH == WhichLocation::Minloc) {
395           value.reset();
396         }
397         for (ConstantSubscript k{0}; k < dimLength;
398              ++k, ++at[zbDim], mask && ++maskAt[zbDim]) {
399           if ((!mask || mask->At(maskAt).IsTrue()) &&
400               IsHit(array->At(at), value, relation, back)) {
401             hit = at[zbDim];
402             if constexpr (WHICH == WhichLocation::Findloc) {
403               if (!back) {
404                 break;
405               }
406             }
407           }
408         }
409         resultIndices.emplace_back(hit);
410         at[zbDim] = std::max<ConstantSubscript>(dimLength, 1);
411         array->IncrementSubscripts(at);
412         at[zbDim] = 1;
413         if (mask) {
414           maskAt[zbDim] = mask->lbounds()[zbDim] +
415               std::max<ConstantSubscript>(dimLength, 1) - 1;
416           mask->IncrementSubscripts(maskAt);
417           maskAt[zbDim] = mask->lbounds()[zbDim];
418         }
419       }
420     } else { // no DIM=
421       resultShape = ConstantSubscripts{array->Rank()}; // always a vector
422       ConstantSubscript n{GetSize(array->shape())};
423       resultIndices = ConstantSubscripts(array->Rank(), 0);
424       for (ConstantSubscript j{0}; j < n; ++j, array->IncrementSubscripts(at),
425            mask && mask->IncrementSubscripts(maskAt)) {
426         if ((!mask || mask->At(maskAt).IsTrue()) &&
427             IsHit(array->At(at), value, relation, back)) {
428           resultIndices = at;
429           if constexpr (WHICH == WhichLocation::Findloc) {
430             if (!back) {
431               break;
432             }
433           }
434         }
435       }
436     }
437     std::vector<Scalar<SubscriptInteger>> resultElements;
438     for (ConstantSubscript j : resultIndices) {
439       resultElements.emplace_back(j);
440     }
441     return Constant<SubscriptInteger>{
442         std::move(resultElements), std::move(resultShape)};
443   }
444 
445 private:
446   template <typename T>
447   bool IsHit(typename Constant<T>::Element element,
448       std::optional<Constant<T>> &value,
449       [[maybe_unused]] RelationalOperator relation,
450       [[maybe_unused]] bool back) const {
451     std::optional<Expr<LogicalResult>> cmp;
452     bool result{true};
453     if (value) {
454       if constexpr (T::category == TypeCategory::Logical) {
455         // array(at) .EQV. value?
456         static_assert(WHICH == WhichLocation::Findloc);
457         cmp.emplace(ConvertToType<LogicalResult>(
458             Expr<T>{LogicalOperation<T::kind>{LogicalOperator::Eqv,
459                 Expr<T>{Constant<T>{element}}, Expr<T>{Constant<T>{*value}}}}));
460       } else { // compare array(at) to value
461         if constexpr (T::category == TypeCategory::Real &&
462             (WHICH == WhichLocation::Maxloc ||
463                 WHICH == WhichLocation::Minloc)) {
464           if (value && value->GetScalarValue().value().IsNotANumber() &&
465               (back || !element.IsNotANumber())) {
466             // Replace NaN
467             cmp.emplace(Constant<LogicalResult>{Scalar<LogicalResult>{true}});
468           }
469         }
470         if (!cmp) {
471           cmp.emplace(PackageRelation(relation, Expr<T>{Constant<T>{element}},
472               Expr<T>{Constant<T>{*value}}));
473         }
474       }
475       Expr<LogicalResult> folded{Fold(context_, std::move(*cmp))};
476       result = GetScalarConstantValue<LogicalResult>(folded).value().IsTrue();
477     } else {
478       // first unmasked element for MAXLOC/MINLOC - always take it
479     }
480     if constexpr (WHICH == WhichLocation::Maxloc ||
481         WHICH == WhichLocation::Minloc) {
482       if (result) {
483         value.emplace(std::move(element));
484       }
485     }
486     return result;
487   }
488 
489   static constexpr int dimArg{WHICH == WhichLocation::Findloc ? 2 : 1};
490   static constexpr int maskArg{dimArg + 1};
491   static constexpr int backArg{maskArg + 2};
492 
493   DynamicType type_;
494   ActualArguments &arg_;
495   FoldingContext &context_;
496 };
497 
498 template <WhichLocation which>
499 static std::optional<Constant<SubscriptInteger>> FoldLocationCall(
500     ActualArguments &arg, FoldingContext &context) {
501   if (arg[0]) {
502     if (auto type{arg[0]->GetType()}) {
503       if constexpr (which == WhichLocation::Findloc) {
504         // Both ARRAY and VALUE are susceptible to conversion to a common
505         // comparison type.
506         if (arg[1]) {
507           if (auto valType{arg[1]->GetType()}) {
508             if (auto compareType{ComparisonType(*type, *valType)}) {
509               type = compareType;
510             }
511           }
512         }
513       }
514       return common::SearchTypes(
515           LocationHelper<which>{std::move(*type), arg, context});
516     }
517   }
518   return std::nullopt;
519 }
520 
521 template <WhichLocation which, typename T>
522 static Expr<T> FoldLocation(FoldingContext &context, FunctionRef<T> &&ref) {
523   static_assert(T::category == TypeCategory::Integer);
524   if (std::optional<Constant<SubscriptInteger>> found{
525           FoldLocationCall<which>(ref.arguments(), context)}) {
526     return Expr<T>{Fold(
527         context, ConvertToType<T>(Expr<SubscriptInteger>{std::move(*found)}))};
528   } else {
529     return Expr<T>{std::move(ref)};
530   }
531 }
532 
533 // for IALL, IANY, & IPARITY
534 template <typename T>
535 static Expr<T> FoldBitReduction(FoldingContext &context, FunctionRef<T> &&ref,
536     Scalar<T> (Scalar<T>::*operation)(const Scalar<T> &) const,
537     Scalar<T> identity) {
538   static_assert(T::category == TypeCategory::Integer ||
539       T::category == TypeCategory::Unsigned);
540   std::optional<int> dim;
541   if (std::optional<ArrayAndMask<T>> arrayAndMask{
542           ProcessReductionArgs<T>(context, ref.arguments(), dim,
543               /*ARRAY=*/0, /*DIM=*/1, /*MASK=*/2)}) {
544     OperationAccumulator<T> accumulator{arrayAndMask->array, operation};
545     return Expr<T>{DoReduction<T>(
546         arrayAndMask->array, arrayAndMask->mask, dim, identity, accumulator)};
547   }
548   return Expr<T>{std::move(ref)};
549 }
550 
551 // Common cases for INTEGER and UNSIGNED
552 template <typename T>
553 std::optional<Expr<T>> FoldIntrinsicFunctionCommon(
554     FoldingContext &context, FunctionRef<T> &funcRef) {
555   ActualArguments &args{funcRef.arguments()};
556   auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)};
557   CHECK(intrinsic);
558   std::string name{intrinsic->name};
559   using Int4 = Type<TypeCategory::Integer, 4>;
560   if (name == "bit_size") {
561     return Expr<T>{Scalar<T>::bits};
562   } else if (name == "digits") {
563     if (const auto *cx{UnwrapExpr<Expr<SomeInteger>>(args[0])}) {
564       return Expr<T>{common::visit(
565           [](const auto &kx) {
566             return Scalar<ResultType<decltype(kx)>>::DIGITS;
567           },
568           cx->u)};
569     } else if (const auto *cx{UnwrapExpr<Expr<SomeUnsigned>>(args[0])}) {
570       return Expr<T>{common::visit(
571           [](const auto &kx) {
572             return Scalar<ResultType<decltype(kx)>>::DIGITS + 1;
573           },
574           cx->u)};
575     } else if (const auto *cx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
576       return Expr<T>{common::visit(
577           [](const auto &kx) {
578             return Scalar<ResultType<decltype(kx)>>::DIGITS;
579           },
580           cx->u)};
581     } else if (const auto *cx{UnwrapExpr<Expr<SomeComplex>>(args[0])}) {
582       return Expr<T>{common::visit(
583           [](const auto &kx) {
584             return Scalar<typename ResultType<decltype(kx)>::Part>::DIGITS;
585           },
586           cx->u)};
587     }
588   } else if (name == "dot_product") {
589     return FoldDotProduct<T>(context, std::move(funcRef));
590   } else if (name == "dshiftl" || name == "dshiftr") {
591     const auto fptr{
592         name == "dshiftl" ? &Scalar<T>::DSHIFTL : &Scalar<T>::DSHIFTR};
593     // Third argument can be of any kind. However, it must be smaller or equal
594     // than BIT_SIZE. It can be converted to Int4 to simplify.
595     if (const auto *argCon{Folder<T>(context).Folding(args[0])};
596         argCon && argCon->empty()) {
597     } else if (const auto *shiftCon{Folder<Int4>(context).Folding(args[2])}) {
598       for (const auto &scalar : shiftCon->values()) {
599         std::int64_t shiftVal{scalar.ToInt64()};
600         if (shiftVal < 0) {
601           context.messages().Say("SHIFT=%jd count for %s is negative"_err_en_US,
602               std::intmax_t{shiftVal}, name);
603           break;
604         } else if (shiftVal > T::Scalar::bits) {
605           context.messages().Say(
606               "SHIFT=%jd count for %s is greater than %d"_err_en_US,
607               std::intmax_t{shiftVal}, name, T::Scalar::bits);
608           break;
609         }
610       }
611     }
612     return FoldElementalIntrinsic<T, T, T, Int4>(context, std::move(funcRef),
613         ScalarFunc<T, T, T, Int4>(
614             [&fptr](const Scalar<T> &i, const Scalar<T> &j,
615                 const Scalar<Int4> &shift) -> Scalar<T> {
616               return std::invoke(fptr, i, j, static_cast<int>(shift.ToInt64()));
617             }));
618   } else if (name == "iand" || name == "ior" || name == "ieor") {
619     auto fptr{&Scalar<T>::IAND};
620     if (name == "iand") { // done in fptr declaration
621     } else if (name == "ior") {
622       fptr = &Scalar<T>::IOR;
623     } else if (name == "ieor") {
624       fptr = &Scalar<T>::IEOR;
625     } else {
626       common::die("missing case to fold intrinsic function %s", name.c_str());
627     }
628     return FoldElementalIntrinsic<T, T, T>(
629         context, std::move(funcRef), ScalarFunc<T, T, T>(fptr));
630   } else if (name == "iall") {
631     return FoldBitReduction(
632         context, std::move(funcRef), &Scalar<T>::IAND, Scalar<T>{}.NOT());
633   } else if (name == "iany") {
634     return FoldBitReduction(
635         context, std::move(funcRef), &Scalar<T>::IOR, Scalar<T>{});
636   } else if (name == "ibclr" || name == "ibset") {
637     // Second argument can be of any kind. However, it must be smaller
638     // than BIT_SIZE. It can be converted to Int4 to simplify.
639     auto fptr{&Scalar<T>::IBCLR};
640     if (name == "ibclr") { // done in fptr definition
641     } else if (name == "ibset") {
642       fptr = &Scalar<T>::IBSET;
643     } else {
644       common::die("missing case to fold intrinsic function %s", name.c_str());
645     }
646     if (const auto *argCon{Folder<T>(context).Folding(args[0])};
647         argCon && argCon->empty()) {
648     } else if (const auto *posCon{Folder<Int4>(context).Folding(args[1])}) {
649       for (const auto &scalar : posCon->values()) {
650         std::int64_t posVal{scalar.ToInt64()};
651         if (posVal < 0) {
652           context.messages().Say(
653               "bit position for %s (%jd) is negative"_err_en_US, name,
654               std::intmax_t{posVal});
655           break;
656         } else if (posVal >= T::Scalar::bits) {
657           context.messages().Say(
658               "bit position for %s (%jd) is not less than %d"_err_en_US, name,
659               std::intmax_t{posVal}, T::Scalar::bits);
660           break;
661         }
662       }
663     }
664     return FoldElementalIntrinsic<T, T, Int4>(context, std::move(funcRef),
665         ScalarFunc<T, T, Int4>(
666             [&](const Scalar<T> &i, const Scalar<Int4> &pos) -> Scalar<T> {
667               return std::invoke(fptr, i, static_cast<int>(pos.ToInt64()));
668             }));
669   } else if (name == "ibits") {
670     const auto *posCon{Folder<Int4>(context).Folding(args[1])};
671     const auto *lenCon{Folder<Int4>(context).Folding(args[2])};
672     if (const auto *argCon{Folder<T>(context).Folding(args[0])};
673         argCon && argCon->empty()) {
674     } else {
675       std::size_t posCt{posCon ? posCon->size() : 0};
676       std::size_t lenCt{lenCon ? lenCon->size() : 0};
677       std::size_t n{std::max(posCt, lenCt)};
678       for (std::size_t j{0}; j < n; ++j) {
679         int posVal{j < posCt || posCt == 1
680                 ? static_cast<int>(posCon->values()[j % posCt].ToInt64())
681                 : 0};
682         int lenVal{j < lenCt || lenCt == 1
683                 ? static_cast<int>(lenCon->values()[j % lenCt].ToInt64())
684                 : 0};
685         if (posVal < 0) {
686           context.messages().Say(
687               "bit position for IBITS(POS=%jd) is negative"_err_en_US,
688               std::intmax_t{posVal});
689           break;
690         } else if (lenVal < 0) {
691           context.messages().Say(
692               "bit length for IBITS(LEN=%jd) is negative"_err_en_US,
693               std::intmax_t{lenVal});
694           break;
695         } else if (posVal + lenVal > T::Scalar::bits) {
696           context.messages().Say(
697               "IBITS() must have POS+LEN (>=%jd) no greater than %d"_err_en_US,
698               std::intmax_t{posVal + lenVal}, T::Scalar::bits);
699           break;
700         }
701       }
702     }
703     return FoldElementalIntrinsic<T, T, Int4, Int4>(context, std::move(funcRef),
704         ScalarFunc<T, T, Int4, Int4>(
705             [&](const Scalar<T> &i, const Scalar<Int4> &pos,
706                 const Scalar<Int4> &len) -> Scalar<T> {
707               return i.IBITS(static_cast<int>(pos.ToInt64()),
708                   static_cast<int>(len.ToInt64()));
709             }));
710   } else if (name == "int" || name == "int2" || name == "int8" ||
711       name == "uint") {
712     if (auto *expr{UnwrapExpr<Expr<SomeType>>(args[0])}) {
713       return common::visit(
714           [&](auto &&x) -> Expr<T> {
715             using From = std::decay_t<decltype(x)>;
716             if constexpr (std::is_same_v<From, BOZLiteralConstant> ||
717                 IsNumericCategoryExpr<From>()) {
718               return Fold(context, ConvertToType<T>(std::move(x)));
719             }
720             DIE("int() argument type not valid");
721           },
722           std::move(expr->u));
723     }
724   } else if (name == "iparity") {
725     return FoldBitReduction(
726         context, std::move(funcRef), &Scalar<T>::IEOR, Scalar<T>{});
727   } else if (name == "ishft" || name == "ishftc") {
728     const auto *argCon{Folder<T>(context).Folding(args[0])};
729     const auto *shiftCon{Folder<Int4>(context).Folding(args[1])};
730     const auto *shiftVals{shiftCon ? &shiftCon->values() : nullptr};
731     const auto *sizeCon{args.size() == 3
732             ? Folder<Int4>{context, /*forOptionalArgument=*/true}.Folding(
733                   args[2])
734             : nullptr};
735     const auto *sizeVals{sizeCon ? &sizeCon->values() : nullptr};
736     if ((argCon && argCon->empty()) || !shiftVals || shiftVals->empty() ||
737         (sizeVals && sizeVals->empty())) {
738       // size= and shift= values don't need to be checked
739     } else {
740       for (const auto &scalar : *shiftVals) {
741         std::int64_t shiftVal{scalar.ToInt64()};
742         if (shiftVal < -T::Scalar::bits) {
743           context.messages().Say(
744               "SHIFT=%jd count for %s is less than %d"_err_en_US,
745               std::intmax_t{shiftVal}, name, -T::Scalar::bits);
746           break;
747         } else if (shiftVal > T::Scalar::bits) {
748           context.messages().Say(
749               "SHIFT=%jd count for %s is greater than %d"_err_en_US,
750               std::intmax_t{shiftVal}, name, T::Scalar::bits);
751           break;
752         }
753       }
754       if (sizeVals) {
755         for (const auto &scalar : *sizeVals) {
756           std::int64_t sizeVal{scalar.ToInt64()};
757           if (sizeVal <= 0) {
758             context.messages().Say(
759                 "SIZE=%jd count for ishftc is not positive"_err_en_US,
760                 std::intmax_t{sizeVal}, name);
761             break;
762           } else if (sizeVal > T::Scalar::bits) {
763             context.messages().Say(
764                 "SIZE=%jd count for ishftc is greater than %d"_err_en_US,
765                 std::intmax_t{sizeVal}, T::Scalar::bits);
766             break;
767           }
768         }
769         if (shiftVals->size() == 1 || sizeVals->size() == 1 ||
770             shiftVals->size() == sizeVals->size()) {
771           auto iters{std::max(shiftVals->size(), sizeVals->size())};
772           for (std::size_t j{0}; j < iters; ++j) {
773             auto shiftVal{static_cast<int>(
774                 (*shiftVals)[j % shiftVals->size()].ToInt64())};
775             auto sizeVal{
776                 static_cast<int>((*sizeVals)[j % sizeVals->size()].ToInt64())};
777             if (sizeVal > 0 && std::abs(shiftVal) > sizeVal) {
778               context.messages().Say(
779                   "SHIFT=%jd count for ishftc is greater in magnitude than SIZE=%jd"_err_en_US,
780                   std::intmax_t{shiftVal}, std::intmax_t{sizeVal});
781               break;
782             }
783           }
784         }
785       }
786     }
787     if (name == "ishft") {
788       return FoldElementalIntrinsic<T, T, Int4>(context, std::move(funcRef),
789           ScalarFunc<T, T, Int4>(
790               [&](const Scalar<T> &i, const Scalar<Int4> &shift) -> Scalar<T> {
791                 return i.ISHFT(static_cast<int>(shift.ToInt64()));
792               }));
793     } else if (!args.at(2)) { // ISHFTC(no SIZE=)
794       return FoldElementalIntrinsic<T, T, Int4>(context, std::move(funcRef),
795           ScalarFunc<T, T, Int4>(
796               [&](const Scalar<T> &i, const Scalar<Int4> &shift) -> Scalar<T> {
797                 return i.ISHFTC(static_cast<int>(shift.ToInt64()));
798               }));
799     } else { // ISHFTC(with SIZE=)
800       return FoldElementalIntrinsic<T, T, Int4, Int4>(context,
801           std::move(funcRef),
802           ScalarFunc<T, T, Int4, Int4>(
803               [&](const Scalar<T> &i, const Scalar<Int4> &shift,
804                   const Scalar<Int4> &size) -> Scalar<T> {
805                 auto shiftVal{static_cast<int>(shift.ToInt64())};
806                 auto sizeVal{static_cast<int>(size.ToInt64())};
807                 return i.ISHFTC(shiftVal, sizeVal);
808               }),
809           /*hasOptionalArgument=*/true);
810     }
811   } else if (name == "izext" || name == "jzext") {
812     if (args.size() == 1) {
813       if (auto *expr{UnwrapExpr<Expr<SomeKind<T::category>>>(args[0])}) {
814         // Rewrite to IAND(INT(n,k),255_k) for k=KIND(T)
815         intrinsic->name = "iand";
816         auto converted{ConvertToType<T>(std::move(*expr))};
817         *expr =
818             Fold(context, Expr<SomeKind<T::category>>{std::move(converted)});
819         args.emplace_back(AsGenericExpr(Expr<T>{Scalar<T>{255}}));
820         return FoldIntrinsicFunction(context, std::move(funcRef));
821       }
822     }
823   } else if (name == "maskl" || name == "maskr" || name == "umaskl" ||
824       name == "umaskr") {
825     // Argument can be of any kind but value has to be smaller than BIT_SIZE.
826     // It can be safely converted to Int4 to simplify.
827     const auto fptr{name == "maskl" || name == "umaskl" ? &Scalar<T>::MASKL
828                                                         : &Scalar<T>::MASKR};
829     return FoldElementalIntrinsic<T, Int4>(context, std::move(funcRef),
830         ScalarFunc<T, Int4>([&fptr](const Scalar<Int4> &places) -> Scalar<T> {
831           return fptr(static_cast<int>(places.ToInt64()));
832         }));
833   } else if (name == "matmul") {
834     return FoldMatmul(context, std::move(funcRef));
835   } else if (name == "max") {
836     return FoldMINorMAX(context, std::move(funcRef), Ordering::Greater);
837   } else if (name == "maxval") {
838     return FoldMaxvalMinval<T>(context, std::move(funcRef),
839         RelationalOperator::GT,
840         T::category == TypeCategory::Unsigned ? typename T::Scalar{}
841                                               : T::Scalar::Least());
842   } else if (name == "merge_bits") {
843     return FoldElementalIntrinsic<T, T, T, T>(
844         context, std::move(funcRef), &Scalar<T>::MERGE_BITS);
845   } else if (name == "min") {
846     return FoldMINorMAX(context, std::move(funcRef), Ordering::Less);
847   } else if (name == "minval") {
848     return FoldMaxvalMinval<T>(context, std::move(funcRef),
849         RelationalOperator::LT,
850         T::category == TypeCategory::Unsigned ? typename T::Scalar{}.NOT()
851                                               : T::Scalar::HUGE());
852   } else if (name == "not") {
853     return FoldElementalIntrinsic<T, T>(
854         context, std::move(funcRef), &Scalar<T>::NOT);
855   } else if (name == "product") {
856     return FoldProduct<T>(context, std::move(funcRef), Scalar<T>{1});
857   } else if (name == "radix") {
858     return Expr<T>{2};
859   } else if (name == "shifta" || name == "shiftr" || name == "shiftl") {
860     // Second argument can be of any kind. However, it must be smaller or
861     // equal than BIT_SIZE. It can be converted to Int4 to simplify.
862     auto fptr{&Scalar<T>::SHIFTA};
863     if (name == "shifta") { // done in fptr definition
864     } else if (name == "shiftr") {
865       fptr = &Scalar<T>::SHIFTR;
866     } else if (name == "shiftl") {
867       fptr = &Scalar<T>::SHIFTL;
868     } else {
869       common::die("missing case to fold intrinsic function %s", name.c_str());
870     }
871     if (const auto *argCon{Folder<T>(context).Folding(args[0])};
872         argCon && argCon->empty()) {
873     } else if (const auto *shiftCon{Folder<Int4>(context).Folding(args[1])}) {
874       for (const auto &scalar : shiftCon->values()) {
875         std::int64_t shiftVal{scalar.ToInt64()};
876         if (shiftVal < 0) {
877           context.messages().Say("SHIFT=%jd count for %s is negative"_err_en_US,
878               std::intmax_t{shiftVal}, name, -T::Scalar::bits);
879           break;
880         } else if (shiftVal > T::Scalar::bits) {
881           context.messages().Say(
882               "SHIFT=%jd count for %s is greater than %d"_err_en_US,
883               std::intmax_t{shiftVal}, name, T::Scalar::bits);
884           break;
885         }
886       }
887     }
888     return FoldElementalIntrinsic<T, T, Int4>(context, std::move(funcRef),
889         ScalarFunc<T, T, Int4>(
890             [&](const Scalar<T> &i, const Scalar<Int4> &shift) -> Scalar<T> {
891               return std::invoke(fptr, i, static_cast<int>(shift.ToInt64()));
892             }));
893   } else if (name == "sum") {
894     return FoldSum<T>(context, std::move(funcRef));
895   }
896   return std::nullopt;
897 }
898 
899 template <int KIND>
900 Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
901     FoldingContext &context,
902     FunctionRef<Type<TypeCategory::Integer, KIND>> &&funcRef) {
903   if (auto foldedCommon{FoldIntrinsicFunctionCommon(context, funcRef)}) {
904     return std::move(*foldedCommon);
905   }
906 
907   using T = Type<TypeCategory::Integer, KIND>;
908   ActualArguments &args{funcRef.arguments()};
909   auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)};
910   CHECK(intrinsic);
911   std::string name{intrinsic->name};
912 
913   auto FromInt64{[&name, &context](std::int64_t n) {
914     Scalar<T> result{n};
915     if (result.ToInt64() != n &&
916         context.languageFeatures().ShouldWarn(
917             common::UsageWarning::FoldingException)) {
918       context.messages().Say(common::UsageWarning::FoldingException,
919           "Result of intrinsic function '%s' (%jd) overflows its result type"_warn_en_US,
920           name, std::intmax_t{n});
921     }
922     return result;
923   }};
924 
925   if (name == "abs") { // incl. babs, iiabs, jiaabs, & kiabs
926     return FoldElementalIntrinsic<T, T>(context, std::move(funcRef),
927         ScalarFunc<T, T>([&context](const Scalar<T> &i) -> Scalar<T> {
928           typename Scalar<T>::ValueWithOverflow j{i.ABS()};
929           if (j.overflow &&
930               context.languageFeatures().ShouldWarn(
931                   common::UsageWarning::FoldingException)) {
932             context.messages().Say(common::UsageWarning::FoldingException,
933                 "abs(integer(kind=%d)) folding overflowed"_warn_en_US, KIND);
934           }
935           return j.value;
936         }));
937   } else if (name == "ceiling" || name == "floor" || name == "nint") {
938     if (const auto *cx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
939       // NINT rounds ties away from zero, not to even
940       common::RoundingMode mode{name == "ceiling" ? common::RoundingMode::Up
941               : name == "floor"                   ? common::RoundingMode::Down
942                                 : common::RoundingMode::TiesAwayFromZero};
943       return common::visit(
944           [&](const auto &kx) {
945             using TR = ResultType<decltype(kx)>;
946             return FoldElementalIntrinsic<T, TR>(context, std::move(funcRef),
947                 ScalarFunc<T, TR>([&](const Scalar<TR> &x) {
948                   auto y{x.template ToInteger<Scalar<T>>(mode)};
949                   if (y.flags.test(RealFlag::Overflow) &&
950                       context.languageFeatures().ShouldWarn(
951                           common::UsageWarning::FoldingException)) {
952                     context.messages().Say(
953                         common::UsageWarning::FoldingException,
954                         "%s intrinsic folding overflow"_warn_en_US, name);
955                   }
956                   return y.value;
957                 }));
958           },
959           cx->u);
960     }
961   } else if (name == "count") {
962     int maskKind = args[0]->GetType()->kind();
963     switch (maskKind) {
964       SWITCH_COVERS_ALL_CASES
965     case 1:
966       return FoldCount<T, 1>(context, std::move(funcRef));
967     case 2:
968       return FoldCount<T, 2>(context, std::move(funcRef));
969     case 4:
970       return FoldCount<T, 4>(context, std::move(funcRef));
971     case 8:
972       return FoldCount<T, 8>(context, std::move(funcRef));
973     }
974   } else if (name == "dim") {
975     return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
976         ScalarFunc<T, T, T>(
977             [&context](const Scalar<T> &x, const Scalar<T> &y) -> Scalar<T> {
978               auto result{x.DIM(y)};
979               if (result.overflow &&
980                   context.languageFeatures().ShouldWarn(
981                       common::UsageWarning::FoldingException)) {
982                 context.messages().Say(common::UsageWarning::FoldingException,
983                     "DIM intrinsic folding overflow"_warn_en_US);
984               }
985               return result.value;
986             }));
987   } else if (name == "exponent") {
988     if (auto *sx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
989       return common::visit(
990           [&funcRef, &context](const auto &x) -> Expr<T> {
991             using TR = typename std::decay_t<decltype(x)>::Result;
992             return FoldElementalIntrinsic<T, TR>(context, std::move(funcRef),
993                 &Scalar<TR>::template EXPONENT<Scalar<T>>);
994           },
995           sx->u);
996     } else {
997       DIE("exponent argument must be real");
998     }
999   } else if (name == "findloc") {
1000     return FoldLocation<WhichLocation::Findloc, T>(context, std::move(funcRef));
1001   } else if (name == "huge") {
1002     return Expr<T>{Scalar<T>::HUGE()};
1003   } else if (name == "iachar" || name == "ichar") {
1004     auto *someChar{UnwrapExpr<Expr<SomeCharacter>>(args[0])};
1005     CHECK(someChar);
1006     if (auto len{ToInt64(someChar->LEN())}) {
1007       if (len.value() < 1) {
1008         context.messages().Say(
1009             "Character in intrinsic function %s must have length one"_err_en_US,
1010             name);
1011       } else if (len.value() > 1 &&
1012           context.languageFeatures().ShouldWarn(
1013               common::UsageWarning::Portability)) {
1014         // Do not die, this was not checked before
1015         context.messages().Say(common::UsageWarning::Portability,
1016             "Character in intrinsic function %s should have length one"_port_en_US,
1017             name);
1018       } else {
1019         return common::visit(
1020             [&funcRef, &context, &FromInt64](const auto &str) -> Expr<T> {
1021               using Char = typename std::decay_t<decltype(str)>::Result;
1022               (void)FromInt64;
1023               return FoldElementalIntrinsic<T, Char>(context,
1024                   std::move(funcRef),
1025                   ScalarFunc<T, Char>(
1026 #ifndef _MSC_VER
1027                       [&FromInt64](const Scalar<Char> &c) {
1028                         return FromInt64(CharacterUtils<Char::kind>::ICHAR(
1029                             CharacterUtils<Char::kind>::Resize(c, 1)));
1030                       }));
1031 #else // _MSC_VER
1032       // MSVC 14 get confused by the original code above and
1033       // ends up emitting an error about passing a std::string
1034       // to the std::u16string instantiation of
1035       // CharacterUtils<2>::ICHAR(). Can't find a work-around,
1036       // so remove the FromInt64 error checking lambda that
1037       // seems to have caused the proble.
1038                       [](const Scalar<Char> &c) {
1039                         return CharacterUtils<Char::kind>::ICHAR(
1040                             CharacterUtils<Char::kind>::Resize(c, 1));
1041                       }));
1042 #endif // _MSC_VER
1043             },
1044             someChar->u);
1045       }
1046     }
1047   } else if (name == "index" || name == "scan" || name == "verify") {
1048     if (auto *charExpr{UnwrapExpr<Expr<SomeCharacter>>(args[0])}) {
1049       return common::visit(
1050           [&](const auto &kch) -> Expr<T> {
1051             using TC = typename std::decay_t<decltype(kch)>::Result;
1052             if (UnwrapExpr<Expr<SomeLogical>>(args[2])) { // BACK=
1053               return FoldElementalIntrinsic<T, TC, TC, LogicalResult>(context,
1054                   std::move(funcRef),
1055                   ScalarFunc<T, TC, TC, LogicalResult>{
1056                       [&name, &FromInt64](const Scalar<TC> &str,
1057                           const Scalar<TC> &other,
1058                           const Scalar<LogicalResult> &back) {
1059                         return FromInt64(name == "index"
1060                                 ? CharacterUtils<TC::kind>::INDEX(
1061                                       str, other, back.IsTrue())
1062                                 : name == "scan"
1063                                 ? CharacterUtils<TC::kind>::SCAN(
1064                                       str, other, back.IsTrue())
1065                                 : CharacterUtils<TC::kind>::VERIFY(
1066                                       str, other, back.IsTrue()));
1067                       }});
1068             } else {
1069               return FoldElementalIntrinsic<T, TC, TC>(context,
1070                   std::move(funcRef),
1071                   ScalarFunc<T, TC, TC>{
1072                       [&name, &FromInt64](
1073                           const Scalar<TC> &str, const Scalar<TC> &other) {
1074                         return FromInt64(name == "index"
1075                                 ? CharacterUtils<TC::kind>::INDEX(str, other)
1076                                 : name == "scan"
1077                                 ? CharacterUtils<TC::kind>::SCAN(str, other)
1078                                 : CharacterUtils<TC::kind>::VERIFY(str, other));
1079                       }});
1080             }
1081           },
1082           charExpr->u);
1083     } else {
1084       DIE("first argument must be CHARACTER");
1085     }
1086   } else if (name == "int_ptr_kind") {
1087     return Expr<T>{8};
1088   } else if (name == "kind") {
1089     // FoldOperation(FunctionRef &&) in fold-implementation.h will not
1090     // have folded the argument; in the case of TypeParamInquiry,
1091     // try to get the type of the parameter itself.
1092     if (const auto *expr{args[0] ? args[0]->UnwrapExpr() : nullptr}) {
1093       if (const auto *inquiry{UnwrapExpr<TypeParamInquiry>(*expr)}) {
1094         if (const auto *typeSpec{inquiry->parameter().GetType()}) {
1095           if (const auto *intrinType{typeSpec->AsIntrinsic()}) {
1096             if (auto k{ToInt64(Fold(
1097                     context, Expr<SubscriptInteger>{intrinType->kind()}))}) {
1098               return Expr<T>{*k};
1099             }
1100           }
1101         }
1102       } else if (auto dyType{expr->GetType()}) {
1103         return Expr<T>{dyType->kind()};
1104       }
1105     }
1106   } else if (name == "lbound") {
1107     return LBOUND(context, std::move(funcRef));
1108   } else if (name == "leadz" || name == "trailz" || name == "poppar" ||
1109       name == "popcnt") {
1110     if (auto *sn{UnwrapExpr<Expr<SomeKind<T::category>>>(args[0])}) {
1111       return common::visit(
1112           [&funcRef, &context, &name](const auto &n) -> Expr<T> {
1113             using TI = typename std::decay_t<decltype(n)>::Result;
1114             if (name == "poppar") {
1115               return FoldElementalIntrinsic<T, TI>(context, std::move(funcRef),
1116                   ScalarFunc<T, TI>([](const Scalar<TI> &i) -> Scalar<T> {
1117                     return Scalar<T>{i.POPPAR() ? 1 : 0};
1118                   }));
1119             }
1120             auto fptr{&Scalar<TI>::LEADZ};
1121             if (name == "leadz") { // done in fptr definition
1122             } else if (name == "trailz") {
1123               fptr = &Scalar<TI>::TRAILZ;
1124             } else if (name == "popcnt") {
1125               fptr = &Scalar<TI>::POPCNT;
1126             } else {
1127               common::die(
1128                   "missing case to fold intrinsic function %s", name.c_str());
1129             }
1130             return FoldElementalIntrinsic<T, TI>(context, std::move(funcRef),
1131                 // `i` should be declared as `const Scalar<TI>&`.
1132                 // We declare it as `auto` to workaround an msvc bug:
1133                 // https://developercommunity.visualstudio.com/t/Regression:-nested-closure-assumes-wrong/10130223
1134                 ScalarFunc<T, TI>([&fptr](const auto &i) -> Scalar<T> {
1135                   return Scalar<T>{std::invoke(fptr, i)};
1136                 }));
1137           },
1138           sn->u);
1139     } else {
1140       DIE("leadz argument must be integer");
1141     }
1142   } else if (name == "len") {
1143     if (auto *charExpr{UnwrapExpr<Expr<SomeCharacter>>(args[0])}) {
1144       return common::visit(
1145           [&](auto &kx) {
1146             if (auto len{kx.LEN()}) {
1147               if (IsScopeInvariantExpr(*len)) {
1148                 return Fold(context, ConvertToType<T>(*std::move(len)));
1149               } else {
1150                 return Expr<T>{std::move(funcRef)};
1151               }
1152             } else {
1153               return Expr<T>{std::move(funcRef)};
1154             }
1155           },
1156           charExpr->u);
1157     } else {
1158       DIE("len() argument must be of character type");
1159     }
1160   } else if (name == "len_trim") {
1161     if (auto *charExpr{UnwrapExpr<Expr<SomeCharacter>>(args[0])}) {
1162       return common::visit(
1163           [&](const auto &kch) -> Expr<T> {
1164             using TC = typename std::decay_t<decltype(kch)>::Result;
1165             return FoldElementalIntrinsic<T, TC>(context, std::move(funcRef),
1166                 ScalarFunc<T, TC>{[&FromInt64](const Scalar<TC> &str) {
1167                   return FromInt64(CharacterUtils<TC::kind>::LEN_TRIM(str));
1168                 }});
1169           },
1170           charExpr->u);
1171     } else {
1172       DIE("len_trim() argument must be of character type");
1173     }
1174   } else if (name == "max0" || name == "max1") {
1175     return RewriteSpecificMINorMAX(context, std::move(funcRef));
1176   } else if (name == "maxexponent") {
1177     if (auto *sx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
1178       return common::visit(
1179           [](const auto &x) {
1180             using TR = typename std::decay_t<decltype(x)>::Result;
1181             return Expr<T>{Scalar<TR>::MAXEXPONENT};
1182           },
1183           sx->u);
1184     }
1185   } else if (name == "maxloc") {
1186     return FoldLocation<WhichLocation::Maxloc, T>(context, std::move(funcRef));
1187   } else if (name == "min0" || name == "min1") {
1188     return RewriteSpecificMINorMAX(context, std::move(funcRef));
1189   } else if (name == "minexponent") {
1190     if (auto *sx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
1191       return common::visit(
1192           [](const auto &x) {
1193             using TR = typename std::decay_t<decltype(x)>::Result;
1194             return Expr<T>{Scalar<TR>::MINEXPONENT};
1195           },
1196           sx->u);
1197     }
1198   } else if (name == "minloc") {
1199     return FoldLocation<WhichLocation::Minloc, T>(context, std::move(funcRef));
1200   } else if (name == "mod") {
1201     bool badPConst{false};
1202     if (auto *pExpr{UnwrapExpr<Expr<T>>(args[1])}) {
1203       *pExpr = Fold(context, std::move(*pExpr));
1204       if (auto pConst{GetScalarConstantValue<T>(*pExpr)}; pConst &&
1205           pConst->IsZero() &&
1206           context.languageFeatures().ShouldWarn(
1207               common::UsageWarning::FoldingAvoidsRuntimeCrash)) {
1208         context.messages().Say(common::UsageWarning::FoldingAvoidsRuntimeCrash,
1209             "MOD: P argument is zero"_warn_en_US);
1210         badPConst = true;
1211       }
1212     }
1213     return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
1214         ScalarFuncWithContext<T, T, T>(
1215             [badPConst](FoldingContext &context, const Scalar<T> &x,
1216                 const Scalar<T> &y) -> Scalar<T> {
1217               auto quotRem{x.DivideSigned(y)};
1218               if (context.languageFeatures().ShouldWarn(
1219                       common::UsageWarning::FoldingAvoidsRuntimeCrash)) {
1220                 if (!badPConst && quotRem.divisionByZero) {
1221                   context.messages().Say(
1222                       common::UsageWarning::FoldingAvoidsRuntimeCrash,
1223                       "mod() by zero"_warn_en_US);
1224                 } else if (quotRem.overflow) {
1225                   context.messages().Say(
1226                       common::UsageWarning::FoldingAvoidsRuntimeCrash,
1227                       "mod() folding overflowed"_warn_en_US);
1228                 }
1229               }
1230               return quotRem.remainder;
1231             }));
1232   } else if (name == "modulo") {
1233     bool badPConst{false};
1234     if (auto *pExpr{UnwrapExpr<Expr<T>>(args[1])}) {
1235       *pExpr = Fold(context, std::move(*pExpr));
1236       if (auto pConst{GetScalarConstantValue<T>(*pExpr)}; pConst &&
1237           pConst->IsZero() &&
1238           context.languageFeatures().ShouldWarn(
1239               common::UsageWarning::FoldingAvoidsRuntimeCrash)) {
1240         context.messages().Say(common::UsageWarning::FoldingAvoidsRuntimeCrash,
1241             "MODULO: P argument is zero"_warn_en_US);
1242         badPConst = true;
1243       }
1244     }
1245     return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
1246         ScalarFuncWithContext<T, T, T>([badPConst](FoldingContext &context,
1247                                            const Scalar<T> &x,
1248                                            const Scalar<T> &y) -> Scalar<T> {
1249           auto result{x.MODULO(y)};
1250           if (!badPConst && result.overflow &&
1251               context.languageFeatures().ShouldWarn(
1252                   common::UsageWarning::FoldingException)) {
1253             context.messages().Say(common::UsageWarning::FoldingException,
1254                 "modulo() folding overflowed"_warn_en_US);
1255           }
1256           return result.value;
1257         }));
1258   } else if (name == "precision") {
1259     if (const auto *cx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
1260       return Expr<T>{common::visit(
1261           [](const auto &kx) {
1262             return Scalar<ResultType<decltype(kx)>>::PRECISION;
1263           },
1264           cx->u)};
1265     } else if (const auto *cx{UnwrapExpr<Expr<SomeComplex>>(args[0])}) {
1266       return Expr<T>{common::visit(
1267           [](const auto &kx) {
1268             return Scalar<typename ResultType<decltype(kx)>::Part>::PRECISION;
1269           },
1270           cx->u)};
1271     }
1272   } else if (name == "range") {
1273     if (const auto *cx{UnwrapExpr<Expr<SomeInteger>>(args[0])}) {
1274       return Expr<T>{common::visit(
1275           [](const auto &kx) {
1276             return Scalar<ResultType<decltype(kx)>>::RANGE;
1277           },
1278           cx->u)};
1279     } else if (const auto *cx{UnwrapExpr<Expr<SomeUnsigned>>(args[0])}) {
1280       return Expr<T>{common::visit(
1281           [](const auto &kx) {
1282             return Scalar<ResultType<decltype(kx)>>::UnsignedRANGE;
1283           },
1284           cx->u)};
1285     } else if (const auto *cx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
1286       return Expr<T>{common::visit(
1287           [](const auto &kx) {
1288             return Scalar<ResultType<decltype(kx)>>::RANGE;
1289           },
1290           cx->u)};
1291     } else if (const auto *cx{UnwrapExpr<Expr<SomeComplex>>(args[0])}) {
1292       return Expr<T>{common::visit(
1293           [](const auto &kx) {
1294             return Scalar<typename ResultType<decltype(kx)>::Part>::RANGE;
1295           },
1296           cx->u)};
1297     }
1298   } else if (name == "rank") {
1299     if (args[0]) {
1300       const Symbol *symbol{nullptr};
1301       if (auto dataRef{ExtractDataRef(args[0])}) {
1302         symbol = &dataRef->GetLastSymbol();
1303       } else {
1304         symbol = args[0]->GetAssumedTypeDummy();
1305       }
1306       if (symbol && IsAssumedRank(*symbol)) {
1307         // DescriptorInquiry can only be placed in expression of kind
1308         // DescriptorInquiry::Result::kind.
1309         return ConvertToType<T>(
1310             Expr<Type<TypeCategory::Integer, DescriptorInquiry::Result::kind>>{
1311                 DescriptorInquiry{
1312                     NamedEntity{*symbol}, DescriptorInquiry::Field::Rank}});
1313       }
1314       return Expr<T>{args[0]->Rank()};
1315     }
1316   } else if (name == "selected_char_kind") {
1317     if (const auto *chCon{UnwrapExpr<Constant<TypeOf<std::string>>>(args[0])}) {
1318       if (std::optional<std::string> value{chCon->GetScalarValue()}) {
1319         int defaultKind{
1320             context.defaults().GetDefaultKind(TypeCategory::Character)};
1321         return Expr<T>{SelectedCharKind(*value, defaultKind)};
1322       }
1323     }
1324   } else if (name == "selected_int_kind" || name == "selected_unsigned_kind") {
1325     if (auto p{ToInt64(args[0])}) {
1326       return Expr<T>{context.targetCharacteristics().SelectedIntKind(*p)};
1327     }
1328   } else if (name == "selected_logical_kind") {
1329     if (auto p{ToInt64(args[0])}) {
1330       return Expr<T>{context.targetCharacteristics().SelectedLogicalKind(*p)};
1331     }
1332   } else if (name == "selected_real_kind" ||
1333       name == "__builtin_ieee_selected_real_kind") {
1334     if (auto p{GetInt64ArgOr(args[0], 0)}) {
1335       if (auto r{GetInt64ArgOr(args[1], 0)}) {
1336         if (auto radix{GetInt64ArgOr(args[2], 2)}) {
1337           return Expr<T>{
1338               context.targetCharacteristics().SelectedRealKind(*p, *r, *radix)};
1339         }
1340       }
1341     }
1342   } else if (name == "shape") {
1343     if (auto shape{GetContextFreeShape(context, args[0])}) {
1344       if (auto shapeExpr{AsExtentArrayExpr(*shape)}) {
1345         return Fold(context, ConvertToType<T>(std::move(*shapeExpr)));
1346       }
1347     }
1348   } else if (name == "sign") {
1349     return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
1350         ScalarFunc<T, T, T>([&context](const Scalar<T> &j,
1351                                 const Scalar<T> &k) -> Scalar<T> {
1352           typename Scalar<T>::ValueWithOverflow result{j.SIGN(k)};
1353           if (result.overflow &&
1354               context.languageFeatures().ShouldWarn(
1355                   common::UsageWarning::FoldingException)) {
1356             context.messages().Say(common::UsageWarning::FoldingException,
1357                 "sign(integer(kind=%d)) folding overflowed"_warn_en_US, KIND);
1358           }
1359           return result.value;
1360         }));
1361   } else if (name == "size") {
1362     if (auto shape{GetContextFreeShape(context, args[0])}) {
1363       if (args[1]) { // DIM= is present, get one extent
1364         std::optional<int> dim;
1365         if (const auto *array{args[0].value().UnwrapExpr()}; array &&
1366             !CheckDimArg(args[1], *array, context.messages(), false, dim)) {
1367           return MakeInvalidIntrinsic<T>(std::move(funcRef));
1368         } else if (dim) {
1369           if (auto &extent{shape->at(*dim)}) {
1370             return Fold(context, ConvertToType<T>(std::move(*extent)));
1371           }
1372         }
1373       } else if (auto extents{common::AllElementsPresent(std::move(*shape))}) {
1374         // DIM= is absent; compute PRODUCT(SHAPE())
1375         ExtentExpr product{1};
1376         for (auto &&extent : std::move(*extents)) {
1377           product = std::move(product) * std::move(extent);
1378         }
1379         return Expr<T>{ConvertToType<T>(Fold(context, std::move(product)))};
1380       }
1381     }
1382   } else if (name == "sizeof") { // in bytes; extension
1383     if (auto info{
1384             characteristics::TypeAndShape::Characterize(args[0], context)}) {
1385       if (auto bytes{info->MeasureSizeInBytes(context)}) {
1386         return Expr<T>{Fold(context, ConvertToType<T>(std::move(*bytes)))};
1387       }
1388     }
1389   } else if (name == "storage_size") { // in bits
1390     if (auto info{
1391             characteristics::TypeAndShape::Characterize(args[0], context)}) {
1392       if (auto bytes{info->MeasureElementSizeInBytes(context, true)}) {
1393         return Expr<T>{
1394             Fold(context, Expr<T>{8} * ConvertToType<T>(std::move(*bytes)))};
1395       }
1396     }
1397   } else if (name == "ubound") {
1398     return UBOUND(context, std::move(funcRef));
1399   } else if (name == "__builtin_numeric_storage_size") {
1400     if (!context.moduleFileName()) {
1401       // Don't fold this reference until it appears in the module file
1402       // for ISO_FORTRAN_ENV -- the value depends on the compiler options
1403       // that might be in force.
1404     } else {
1405       auto intBytes{
1406           context.targetCharacteristics().GetByteSize(TypeCategory::Integer,
1407               context.defaults().GetDefaultKind(TypeCategory::Integer))};
1408       auto realBytes{
1409           context.targetCharacteristics().GetByteSize(TypeCategory::Real,
1410               context.defaults().GetDefaultKind(TypeCategory::Real))};
1411       if (intBytes != realBytes &&
1412           context.languageFeatures().ShouldWarn(
1413               common::UsageWarning::FoldingValueChecks)) {
1414         context.messages().Say(common::UsageWarning::FoldingValueChecks,
1415             *context.moduleFileName(),
1416             "NUMERIC_STORAGE_SIZE from ISO_FORTRAN_ENV is not well-defined when default INTEGER and REAL are not consistent due to compiler options"_warn_en_US);
1417       }
1418       return Expr<T>{8 * std::min(intBytes, realBytes)};
1419     }
1420   }
1421   return Expr<T>{std::move(funcRef)};
1422 }
1423 
1424 template <int KIND>
1425 Expr<Type<TypeCategory::Unsigned, KIND>> FoldIntrinsicFunction(
1426     FoldingContext &context,
1427     FunctionRef<Type<TypeCategory::Unsigned, KIND>> &&funcRef) {
1428   if (auto foldedCommon{FoldIntrinsicFunctionCommon(context, funcRef)}) {
1429     return std::move(*foldedCommon);
1430   }
1431   using T = Type<TypeCategory::Unsigned, KIND>;
1432   ActualArguments &args{funcRef.arguments()};
1433   auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)};
1434   CHECK(intrinsic);
1435   std::string name{intrinsic->name};
1436   if (name == "huge") {
1437     return Expr<T>{Scalar<T>{}.NOT()};
1438   } else if (name == "mod" || name == "modulo") {
1439     bool badPConst{false};
1440     if (auto *pExpr{UnwrapExpr<Expr<T>>(args[1])}) {
1441       *pExpr = Fold(context, std::move(*pExpr));
1442       if (auto pConst{GetScalarConstantValue<T>(*pExpr)}; pConst &&
1443           pConst->IsZero() &&
1444           context.languageFeatures().ShouldWarn(
1445               common::UsageWarning::FoldingAvoidsRuntimeCrash)) {
1446         context.messages().Say(common::UsageWarning::FoldingAvoidsRuntimeCrash,
1447             "%s: P argument is zero"_warn_en_US, name);
1448         badPConst = true;
1449       }
1450     }
1451     return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
1452         ScalarFuncWithContext<T, T, T>(
1453             [badPConst, &name](FoldingContext &context, const Scalar<T> &x,
1454                 const Scalar<T> &y) -> Scalar<T> {
1455               auto quotRem{x.DivideUnsigned(y)};
1456               if (context.languageFeatures().ShouldWarn(
1457                       common::UsageWarning::FoldingAvoidsRuntimeCrash)) {
1458                 if (!badPConst && quotRem.divisionByZero) {
1459                   context.messages().Say(
1460                       common::UsageWarning::FoldingAvoidsRuntimeCrash,
1461                       "%s() by zero"_warn_en_US, name);
1462                 }
1463               }
1464               return quotRem.remainder;
1465             }));
1466   }
1467   return Expr<T>{std::move(funcRef)};
1468 }
1469 
1470 // Substitutes a bare type parameter reference with its value if it has one now
1471 // in an instantiation.  Bare LEN type parameters are substituted only when
1472 // the known value is constant.
1473 Expr<TypeParamInquiry::Result> FoldOperation(
1474     FoldingContext &context, TypeParamInquiry &&inquiry) {
1475   std::optional<NamedEntity> base{inquiry.base()};
1476   parser::CharBlock parameterName{inquiry.parameter().name()};
1477   if (base) {
1478     // Handling "designator%typeParam".  Get the value of the type parameter
1479     // from the instantiation of the base
1480     if (const semantics::DeclTypeSpec *
1481         declType{base->GetLastSymbol().GetType()}) {
1482       if (const semantics::ParamValue *
1483           paramValue{
1484               declType->derivedTypeSpec().FindParameter(parameterName)}) {
1485         const semantics::MaybeIntExpr &paramExpr{paramValue->GetExplicit()};
1486         if (paramExpr && IsConstantExpr(*paramExpr)) {
1487           Expr<SomeInteger> intExpr{*paramExpr};
1488           return Fold(context,
1489               ConvertToType<TypeParamInquiry::Result>(std::move(intExpr)));
1490         }
1491       }
1492     }
1493   } else {
1494     // A "bare" type parameter: replace with its value, if that's now known
1495     // in a current derived type instantiation.
1496     if (const auto *pdt{context.pdtInstance()}) {
1497       auto restorer{context.WithoutPDTInstance()}; // don't loop
1498       bool isLen{false};
1499       if (const semantics::Scope * scope{pdt->scope()}) {
1500         auto iter{scope->find(parameterName)};
1501         if (iter != scope->end()) {
1502           const Symbol &symbol{*iter->second};
1503           const auto *details{symbol.detailsIf<semantics::TypeParamDetails>()};
1504           if (details) {
1505             isLen = details->attr() == common::TypeParamAttr::Len;
1506             const semantics::MaybeIntExpr &initExpr{details->init()};
1507             if (initExpr && IsConstantExpr(*initExpr) &&
1508                 (!isLen || ToInt64(*initExpr))) {
1509               Expr<SomeInteger> expr{*initExpr};
1510               return Fold(context,
1511                   ConvertToType<TypeParamInquiry::Result>(std::move(expr)));
1512             }
1513           }
1514         }
1515       }
1516       if (const auto *value{pdt->FindParameter(parameterName)}) {
1517         if (value->isExplicit()) {
1518           auto folded{Fold(context,
1519               AsExpr(ConvertToType<TypeParamInquiry::Result>(
1520                   Expr<SomeInteger>{value->GetExplicit().value()})))};
1521           if (!isLen || ToInt64(folded)) {
1522             return folded;
1523           }
1524         }
1525       }
1526     }
1527   }
1528   return AsExpr(std::move(inquiry));
1529 }
1530 
1531 std::optional<std::int64_t> ToInt64(const Expr<SomeInteger> &expr) {
1532   return common::visit(
1533       [](const auto &kindExpr) { return ToInt64(kindExpr); }, expr.u);
1534 }
1535 
1536 std::optional<std::int64_t> ToInt64(const Expr<SomeUnsigned> &expr) {
1537   return common::visit(
1538       [](const auto &kindExpr) { return ToInt64(kindExpr); }, expr.u);
1539 }
1540 
1541 std::optional<std::int64_t> ToInt64(const Expr<SomeType> &expr) {
1542   if (const auto *intExpr{UnwrapExpr<Expr<SomeInteger>>(expr)}) {
1543     return ToInt64(*intExpr);
1544   } else if (const auto *unsignedExpr{UnwrapExpr<Expr<SomeUnsigned>>(expr)}) {
1545     return ToInt64(*unsignedExpr);
1546   } else {
1547     return std::nullopt;
1548   }
1549 }
1550 
1551 std::optional<std::int64_t> ToInt64(const ActualArgument &arg) {
1552   return ToInt64(arg.UnwrapExpr());
1553 }
1554 
1555 #ifdef _MSC_VER // disable bogus warning about missing definitions
1556 #pragma warning(disable : 4661)
1557 #endif
1558 FOR_EACH_INTEGER_KIND(template class ExpressionBase, )
1559 FOR_EACH_UNSIGNED_KIND(template class ExpressionBase, )
1560 template class ExpressionBase<SomeInteger>;
1561 template class ExpressionBase<SomeUnsigned>;
1562 } // namespace Fortran::evaluate
1563