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