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