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<ConstantSubscript> dim;
186     if (arg.size() > 1 && arg[1]) {
187       dim = CheckDIM(context, arg[1], mask->Rank());
188       if (!dim) {
189         mask = nullptr;
190       }
191     }
192     if (mask) {
193       auto accumulator{[&](Scalar<T> &element, const ConstantSubscripts &at) {
194         if (mask->At(at).IsTrue()) {
195           element = element.AddSigned(Scalar<T>{1}).value;
196         }
197       }};
198       return Expr<T>{DoReduction<T>(*mask, dim, Scalar<T>{}, accumulator)};
199     }
200   }
201   return Expr<T>{std::move(ref)};
202 }
203 
204 // for IALL, IANY, & IPARITY
205 template <typename T>
206 static Expr<T> FoldBitReduction(FoldingContext &context, FunctionRef<T> &&ref,
207     Scalar<T> (Scalar<T>::*operation)(const Scalar<T> &) const,
208     Scalar<T> identity) {
209   static_assert(T::category == TypeCategory::Integer);
210   std::optional<ConstantSubscript> dim;
211   if (std::optional<Constant<T>> array{
212           ProcessReductionArgs<T>(context, ref.arguments(), dim, identity,
213               /*ARRAY=*/0, /*DIM=*/1, /*MASK=*/2)}) {
214     auto accumulator{[&](Scalar<T> &element, const ConstantSubscripts &at) {
215       element = (element.*operation)(array->At(at));
216     }};
217     return Expr<T>{DoReduction<T>(*array, dim, identity, accumulator)};
218   }
219   return Expr<T>{std::move(ref)};
220 }
221 
222 template <int KIND>
223 Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
224     FoldingContext &context,
225     FunctionRef<Type<TypeCategory::Integer, KIND>> &&funcRef) {
226   using T = Type<TypeCategory::Integer, KIND>;
227   using Int4 = Type<TypeCategory::Integer, 4>;
228   ActualArguments &args{funcRef.arguments()};
229   auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)};
230   CHECK(intrinsic);
231   std::string name{intrinsic->name};
232   if (name == "abs") {
233     return FoldElementalIntrinsic<T, T>(context, std::move(funcRef),
234         ScalarFunc<T, T>([&context](const Scalar<T> &i) -> Scalar<T> {
235           typename Scalar<T>::ValueWithOverflow j{i.ABS()};
236           if (j.overflow) {
237             context.messages().Say(
238                 "abs(integer(kind=%d)) folding overflowed"_en_US, KIND);
239           }
240           return j.value;
241         }));
242   } else if (name == "bit_size") {
243     return Expr<T>{Scalar<T>::bits};
244   } else if (name == "ceiling" || name == "floor" || name == "nint") {
245     if (const auto *cx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
246       // NINT rounds ties away from zero, not to even
247       common::RoundingMode mode{name == "ceiling" ? common::RoundingMode::Up
248               : name == "floor"                   ? common::RoundingMode::Down
249                                 : common::RoundingMode::TiesAwayFromZero};
250       return std::visit(
251           [&](const auto &kx) {
252             using TR = ResultType<decltype(kx)>;
253             return FoldElementalIntrinsic<T, TR>(context, std::move(funcRef),
254                 ScalarFunc<T, TR>([&](const Scalar<TR> &x) {
255                   auto y{x.template ToInteger<Scalar<T>>(mode)};
256                   if (y.flags.test(RealFlag::Overflow)) {
257                     context.messages().Say(
258                         "%s intrinsic folding overflow"_en_US, name);
259                   }
260                   return y.value;
261                 }));
262           },
263           cx->u);
264     }
265   } else if (name == "count") {
266     return FoldCount<T>(context, std::move(funcRef));
267   } else if (name == "digits") {
268     if (const auto *cx{UnwrapExpr<Expr<SomeInteger>>(args[0])}) {
269       return Expr<T>{std::visit(
270           [](const auto &kx) {
271             return Scalar<ResultType<decltype(kx)>>::DIGITS;
272           },
273           cx->u)};
274     } else if (const auto *cx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
275       return Expr<T>{std::visit(
276           [](const auto &kx) {
277             return Scalar<ResultType<decltype(kx)>>::DIGITS;
278           },
279           cx->u)};
280     } else if (const auto *cx{UnwrapExpr<Expr<SomeComplex>>(args[0])}) {
281       return Expr<T>{std::visit(
282           [](const auto &kx) {
283             return Scalar<typename ResultType<decltype(kx)>::Part>::DIGITS;
284           },
285           cx->u)};
286     }
287   } else if (name == "dim") {
288     return FoldElementalIntrinsic<T, T, T>(
289         context, std::move(funcRef), &Scalar<T>::DIM);
290   } else if (name == "dshiftl" || name == "dshiftr") {
291     const auto fptr{
292         name == "dshiftl" ? &Scalar<T>::DSHIFTL : &Scalar<T>::DSHIFTR};
293     // Third argument can be of any kind. However, it must be smaller or equal
294     // than BIT_SIZE. It can be converted to Int4 to simplify.
295     return FoldElementalIntrinsic<T, T, T, Int4>(context, std::move(funcRef),
296         ScalarFunc<T, T, T, Int4>(
297             [&fptr](const Scalar<T> &i, const Scalar<T> &j,
298                 const Scalar<Int4> &shift) -> Scalar<T> {
299               return std::invoke(fptr, i, j, static_cast<int>(shift.ToInt64()));
300             }));
301   } else if (name == "exponent") {
302     if (auto *sx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
303       return std::visit(
304           [&funcRef, &context](const auto &x) -> Expr<T> {
305             using TR = typename std::decay_t<decltype(x)>::Result;
306             return FoldElementalIntrinsic<T, TR>(context, std::move(funcRef),
307                 &Scalar<TR>::template EXPONENT<Scalar<T>>);
308           },
309           sx->u);
310     } else {
311       DIE("exponent argument must be real");
312     }
313   } else if (name == "huge") {
314     return Expr<T>{Scalar<T>::HUGE()};
315   } else if (name == "iachar" || name == "ichar") {
316     auto *someChar{UnwrapExpr<Expr<SomeCharacter>>(args[0])};
317     CHECK(someChar);
318     if (auto len{ToInt64(someChar->LEN())}) {
319       if (len.value() != 1) {
320         // Do not die, this was not checked before
321         context.messages().Say(
322             "Character in intrinsic function %s must have length one"_en_US,
323             name);
324       } else {
325         return std::visit(
326             [&funcRef, &context](const auto &str) -> Expr<T> {
327               using Char = typename std::decay_t<decltype(str)>::Result;
328               return FoldElementalIntrinsic<T, Char>(context,
329                   std::move(funcRef),
330                   ScalarFunc<T, Char>([](const Scalar<Char> &c) {
331                     return Scalar<T>{CharacterUtils<Char::kind>::ICHAR(c)};
332                   }));
333             },
334             someChar->u);
335       }
336     }
337   } else if (name == "iand" || name == "ior" || name == "ieor") {
338     auto fptr{&Scalar<T>::IAND};
339     if (name == "iand") { // done in fptr declaration
340     } else if (name == "ior") {
341       fptr = &Scalar<T>::IOR;
342     } else if (name == "ieor") {
343       fptr = &Scalar<T>::IEOR;
344     } else {
345       common::die("missing case to fold intrinsic function %s", name.c_str());
346     }
347     return FoldElementalIntrinsic<T, T, T>(
348         context, std::move(funcRef), ScalarFunc<T, T, T>(fptr));
349   } else if (name == "iall") {
350     return FoldBitReduction(
351         context, std::move(funcRef), &Scalar<T>::IAND, Scalar<T>{}.NOT());
352   } else if (name == "iany") {
353     return FoldBitReduction(
354         context, std::move(funcRef), &Scalar<T>::IOR, Scalar<T>{});
355   } else if (name == "ibclr" || name == "ibset" || name == "ishft" ||
356       name == "shifta" || name == "shiftr" || name == "shiftl") {
357     // Second argument can be of any kind. However, it must be smaller or
358     // equal than BIT_SIZE. It can be converted to Int4 to simplify.
359     auto fptr{&Scalar<T>::IBCLR};
360     if (name == "ibclr") { // done in fprt definition
361     } else if (name == "ibset") {
362       fptr = &Scalar<T>::IBSET;
363     } else if (name == "ishft") {
364       fptr = &Scalar<T>::ISHFT;
365     } else if (name == "shifta") {
366       fptr = &Scalar<T>::SHIFTA;
367     } else if (name == "shiftr") {
368       fptr = &Scalar<T>::SHIFTR;
369     } else if (name == "shiftl") {
370       fptr = &Scalar<T>::SHIFTL;
371     } else {
372       common::die("missing case to fold intrinsic function %s", name.c_str());
373     }
374     return FoldElementalIntrinsic<T, T, Int4>(context, std::move(funcRef),
375         ScalarFunc<T, T, Int4>(
376             [&fptr](const Scalar<T> &i, const Scalar<Int4> &pos) -> Scalar<T> {
377               return std::invoke(fptr, i, static_cast<int>(pos.ToInt64()));
378             }));
379   } else if (name == "index" || name == "scan" || name == "verify") {
380     if (auto *charExpr{UnwrapExpr<Expr<SomeCharacter>>(args[0])}) {
381       return std::visit(
382           [&](const auto &kch) -> Expr<T> {
383             using TC = typename std::decay_t<decltype(kch)>::Result;
384             if (UnwrapExpr<Expr<SomeLogical>>(args[2])) { // BACK=
385               return FoldElementalIntrinsic<T, TC, TC, LogicalResult>(context,
386                   std::move(funcRef),
387                   ScalarFunc<T, TC, TC, LogicalResult>{
388                       [&name](const Scalar<TC> &str, const Scalar<TC> &other,
389                           const Scalar<LogicalResult> &back) -> Scalar<T> {
390                         return name == "index"
391                             ? CharacterUtils<TC::kind>::INDEX(
392                                   str, other, back.IsTrue())
393                             : name == "scan" ? CharacterUtils<TC::kind>::SCAN(
394                                                    str, other, back.IsTrue())
395                                              : CharacterUtils<TC::kind>::VERIFY(
396                                                    str, other, back.IsTrue());
397                       }});
398             } else {
399               return FoldElementalIntrinsic<T, TC, TC>(context,
400                   std::move(funcRef),
401                   ScalarFunc<T, TC, TC>{
402                       [&name](const Scalar<TC> &str,
403                           const Scalar<TC> &other) -> Scalar<T> {
404                         return name == "index"
405                             ? CharacterUtils<TC::kind>::INDEX(str, other)
406                             : name == "scan"
407                             ? CharacterUtils<TC::kind>::SCAN(str, other)
408                             : CharacterUtils<TC::kind>::VERIFY(str, other);
409                       }});
410             }
411           },
412           charExpr->u);
413     } else {
414       DIE("first argument must be CHARACTER");
415     }
416   } else if (name == "int") {
417     if (auto *expr{UnwrapExpr<Expr<SomeType>>(args[0])}) {
418       return std::visit(
419           [&](auto &&x) -> Expr<T> {
420             using From = std::decay_t<decltype(x)>;
421             if constexpr (std::is_same_v<From, BOZLiteralConstant> ||
422                 IsNumericCategoryExpr<From>()) {
423               return Fold(context, ConvertToType<T>(std::move(x)));
424             }
425             DIE("int() argument type not valid");
426           },
427           std::move(expr->u));
428     }
429   } else if (name == "int_ptr_kind") {
430     return Expr<T>{8};
431   } else if (name == "kind") {
432     if constexpr (common::HasMember<T, IntegerTypes>) {
433       return Expr<T>{args[0].value().GetType()->kind()};
434     } else {
435       DIE("kind() result not integral");
436     }
437   } else if (name == "iparity") {
438     return FoldBitReduction(
439         context, std::move(funcRef), &Scalar<T>::IEOR, Scalar<T>{});
440   } else if (name == "lbound") {
441     return LBOUND(context, std::move(funcRef));
442   } else if (name == "leadz" || name == "trailz" || name == "poppar" ||
443       name == "popcnt") {
444     if (auto *sn{UnwrapExpr<Expr<SomeInteger>>(args[0])}) {
445       return std::visit(
446           [&funcRef, &context, &name](const auto &n) -> Expr<T> {
447             using TI = typename std::decay_t<decltype(n)>::Result;
448             if (name == "poppar") {
449               return FoldElementalIntrinsic<T, TI>(context, std::move(funcRef),
450                   ScalarFunc<T, TI>([](const Scalar<TI> &i) -> Scalar<T> {
451                     return Scalar<T>{i.POPPAR() ? 1 : 0};
452                   }));
453             }
454             auto fptr{&Scalar<TI>::LEADZ};
455             if (name == "leadz") { // done in fptr definition
456             } else if (name == "trailz") {
457               fptr = &Scalar<TI>::TRAILZ;
458             } else if (name == "popcnt") {
459               fptr = &Scalar<TI>::POPCNT;
460             } else {
461               common::die(
462                   "missing case to fold intrinsic function %s", name.c_str());
463             }
464             return FoldElementalIntrinsic<T, TI>(context, std::move(funcRef),
465                 ScalarFunc<T, TI>([&fptr](const Scalar<TI> &i) -> Scalar<T> {
466                   return Scalar<T>{std::invoke(fptr, i)};
467                 }));
468           },
469           sn->u);
470     } else {
471       DIE("leadz argument must be integer");
472     }
473   } else if (name == "len") {
474     if (auto *charExpr{UnwrapExpr<Expr<SomeCharacter>>(args[0])}) {
475       return std::visit(
476           [&](auto &kx) {
477             if (auto len{kx.LEN()}) {
478               return Fold(context, ConvertToType<T>(*std::move(len)));
479             } else {
480               return Expr<T>{std::move(funcRef)};
481             }
482           },
483           charExpr->u);
484     } else {
485       DIE("len() argument must be of character type");
486     }
487   } else if (name == "len_trim") {
488     if (auto *charExpr{UnwrapExpr<Expr<SomeCharacter>>(args[0])}) {
489       return std::visit(
490           [&](const auto &kch) -> Expr<T> {
491             using TC = typename std::decay_t<decltype(kch)>::Result;
492             return FoldElementalIntrinsic<T, TC>(context, std::move(funcRef),
493                 ScalarFunc<T, TC>{[](const Scalar<TC> &str) -> Scalar<T> {
494                   return CharacterUtils<TC::kind>::LEN_TRIM(str);
495                 }});
496           },
497           charExpr->u);
498     } else {
499       DIE("len_trim() argument must be of character type");
500     }
501   } else if (name == "maskl" || name == "maskr") {
502     // Argument can be of any kind but value has to be smaller than BIT_SIZE.
503     // It can be safely converted to Int4 to simplify.
504     const auto fptr{name == "maskl" ? &Scalar<T>::MASKL : &Scalar<T>::MASKR};
505     return FoldElementalIntrinsic<T, Int4>(context, std::move(funcRef),
506         ScalarFunc<T, Int4>([&fptr](const Scalar<Int4> &places) -> Scalar<T> {
507           return fptr(static_cast<int>(places.ToInt64()));
508         }));
509   } else if (name == "max") {
510     return FoldMINorMAX(context, std::move(funcRef), Ordering::Greater);
511   } else if (name == "max0" || name == "max1") {
512     return RewriteSpecificMINorMAX(context, std::move(funcRef));
513   } else if (name == "maxexponent") {
514     if (auto *sx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
515       return std::visit(
516           [](const auto &x) {
517             using TR = typename std::decay_t<decltype(x)>::Result;
518             return Expr<T>{Scalar<TR>::MAXEXPONENT};
519           },
520           sx->u);
521     }
522   } else if (name == "maxval") {
523     return FoldMaxvalMinval<T>(context, std::move(funcRef),
524         RelationalOperator::GT, T::Scalar::Least());
525   } else if (name == "merge") {
526     return FoldMerge<T>(context, std::move(funcRef));
527   } else if (name == "merge_bits") {
528     return FoldElementalIntrinsic<T, T, T, T>(
529         context, std::move(funcRef), &Scalar<T>::MERGE_BITS);
530   } else if (name == "minexponent") {
531     if (auto *sx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
532       return std::visit(
533           [](const auto &x) {
534             using TR = typename std::decay_t<decltype(x)>::Result;
535             return Expr<T>{Scalar<TR>::MINEXPONENT};
536           },
537           sx->u);
538     }
539   } else if (name == "min") {
540     return FoldMINorMAX(context, std::move(funcRef), Ordering::Less);
541   } else if (name == "min0" || name == "min1") {
542     return RewriteSpecificMINorMAX(context, std::move(funcRef));
543   } else if (name == "minval") {
544     return FoldMaxvalMinval<T>(
545         context, std::move(funcRef), RelationalOperator::LT, T::Scalar::HUGE());
546   } else if (name == "mod") {
547     return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
548         ScalarFuncWithContext<T, T, T>(
549             [](FoldingContext &context, const Scalar<T> &x,
550                 const Scalar<T> &y) -> Scalar<T> {
551               auto quotRem{x.DivideSigned(y)};
552               if (quotRem.divisionByZero) {
553                 context.messages().Say("mod() by zero"_en_US);
554               } else if (quotRem.overflow) {
555                 context.messages().Say("mod() folding overflowed"_en_US);
556               }
557               return quotRem.remainder;
558             }));
559   } else if (name == "modulo") {
560     return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
561         ScalarFuncWithContext<T, T, T>(
562             [](FoldingContext &context, const Scalar<T> &x,
563                 const Scalar<T> &y) -> Scalar<T> {
564               auto result{x.MODULO(y)};
565               if (result.overflow) {
566                 context.messages().Say("modulo() folding overflowed"_en_US);
567               }
568               return result.value;
569             }));
570   } else if (name == "not") {
571     return FoldElementalIntrinsic<T, T>(
572         context, std::move(funcRef), &Scalar<T>::NOT);
573   } else if (name == "precision") {
574     if (const auto *cx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
575       return Expr<T>{std::visit(
576           [](const auto &kx) {
577             return Scalar<ResultType<decltype(kx)>>::PRECISION;
578           },
579           cx->u)};
580     } else if (const auto *cx{UnwrapExpr<Expr<SomeComplex>>(args[0])}) {
581       return Expr<T>{std::visit(
582           [](const auto &kx) {
583             return Scalar<typename ResultType<decltype(kx)>::Part>::PRECISION;
584           },
585           cx->u)};
586     }
587   } else if (name == "product") {
588     return FoldProduct<T>(context, std::move(funcRef), Scalar<T>{1});
589   } else if (name == "radix") {
590     return Expr<T>{2};
591   } else if (name == "range") {
592     if (const auto *cx{UnwrapExpr<Expr<SomeInteger>>(args[0])}) {
593       return Expr<T>{std::visit(
594           [](const auto &kx) {
595             return Scalar<ResultType<decltype(kx)>>::RANGE;
596           },
597           cx->u)};
598     } else if (const auto *cx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
599       return Expr<T>{std::visit(
600           [](const auto &kx) {
601             return Scalar<ResultType<decltype(kx)>>::RANGE;
602           },
603           cx->u)};
604     } else if (const auto *cx{UnwrapExpr<Expr<SomeComplex>>(args[0])}) {
605       return Expr<T>{std::visit(
606           [](const auto &kx) {
607             return Scalar<typename ResultType<decltype(kx)>::Part>::RANGE;
608           },
609           cx->u)};
610     }
611   } else if (name == "rank") {
612     if (const auto *array{UnwrapExpr<Expr<SomeType>>(args[0])}) {
613       if (auto named{ExtractNamedEntity(*array)}) {
614         const Symbol &symbol{named->GetLastSymbol()};
615         if (IsAssumedRank(symbol)) {
616           // DescriptorInquiry can only be placed in expression of kind
617           // DescriptorInquiry::Result::kind.
618           return ConvertToType<T>(Expr<
619               Type<TypeCategory::Integer, DescriptorInquiry::Result::kind>>{
620               DescriptorInquiry{*named, DescriptorInquiry::Field::Rank}});
621         }
622       }
623       return Expr<T>{args[0].value().Rank()};
624     }
625     return Expr<T>{args[0].value().Rank()};
626   } else if (name == "selected_char_kind") {
627     if (const auto *chCon{UnwrapExpr<Constant<TypeOf<std::string>>>(args[0])}) {
628       if (std::optional<std::string> value{chCon->GetScalarValue()}) {
629         int defaultKind{
630             context.defaults().GetDefaultKind(TypeCategory::Character)};
631         return Expr<T>{SelectedCharKind(*value, defaultKind)};
632       }
633     }
634   } else if (name == "selected_int_kind") {
635     if (auto p{GetInt64Arg(args[0])}) {
636       return Expr<T>{SelectedIntKind(*p)};
637     }
638   } else if (name == "selected_real_kind" ||
639       name == "__builtin_ieee_selected_real_kind") {
640     if (auto p{GetInt64ArgOr(args[0], 0)}) {
641       if (auto r{GetInt64ArgOr(args[1], 0)}) {
642         if (auto radix{GetInt64ArgOr(args[2], 2)}) {
643           return Expr<T>{SelectedRealKind(*p, *r, *radix)};
644         }
645       }
646     }
647   } else if (name == "shape") {
648     if (auto shape{GetShape(context, args[0])}) {
649       if (auto shapeExpr{AsExtentArrayExpr(*shape)}) {
650         return Fold(context, ConvertToType<T>(std::move(*shapeExpr)));
651       }
652     }
653   } else if (name == "sign") {
654     return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
655         ScalarFunc<T, T, T>(
656             [&context](const Scalar<T> &j, const Scalar<T> &k) -> Scalar<T> {
657               typename Scalar<T>::ValueWithOverflow result{j.SIGN(k)};
658               if (result.overflow) {
659                 context.messages().Say(
660                     "sign(integer(kind=%d)) folding overflowed"_en_US, KIND);
661               }
662               return result.value;
663             }));
664   } else if (name == "size") {
665     if (auto shape{GetShape(context, args[0])}) {
666       if (auto &dimArg{args[1]}) { // DIM= is present, get one extent
667         if (auto dim{GetInt64Arg(args[1])}) {
668           int rank{GetRank(*shape)};
669           if (*dim >= 1 && *dim <= rank) {
670             const Symbol *symbol{UnwrapWholeSymbolDataRef(args[0])};
671             if (symbol && IsAssumedSizeArray(*symbol) && *dim == rank) {
672               context.messages().Say(
673                   "size(array,dim=%jd) of last dimension is not available for rank-%d assumed-size array dummy argument"_err_en_US,
674                   *dim, rank);
675               return MakeInvalidIntrinsic<T>(std::move(funcRef));
676             } else if (auto &extent{shape->at(*dim - 1)}) {
677               return Fold(context, ConvertToType<T>(std::move(*extent)));
678             }
679           } else {
680             context.messages().Say(
681                 "size(array,dim=%jd) dimension is out of range for rank-%d array"_en_US,
682                 *dim, rank);
683           }
684         }
685       } else if (auto extents{common::AllElementsPresent(std::move(*shape))}) {
686         // DIM= is absent; compute PRODUCT(SHAPE())
687         ExtentExpr product{1};
688         for (auto &&extent : std::move(*extents)) {
689           product = std::move(product) * std::move(extent);
690         }
691         return Expr<T>{ConvertToType<T>(Fold(context, std::move(product)))};
692       }
693     }
694   } else if (name == "sizeof") { // in bytes; extension
695     if (auto info{
696             characteristics::TypeAndShape::Characterize(args[0], context)}) {
697       if (auto bytes{info->MeasureSizeInBytes(context)}) {
698         return Expr<T>{Fold(context, ConvertToType<T>(std::move(*bytes)))};
699       }
700     }
701   } else if (name == "storage_size") { // in bits
702     if (auto info{
703             characteristics::TypeAndShape::Characterize(args[0], context)}) {
704       if (auto bytes{info->MeasureElementSizeInBytes(context, true)}) {
705         return Expr<T>{
706             Fold(context, Expr<T>{8} * ConvertToType<T>(std::move(*bytes)))};
707       }
708     }
709   } else if (name == "sum") {
710     return FoldSum<T>(context, std::move(funcRef));
711   } else if (name == "ubound") {
712     return UBOUND(context, std::move(funcRef));
713   }
714   // TODO: dot_product, findloc, ibits, image_status, ishftc,
715   // matmul, maxloc, minloc, sign, transfer
716   return Expr<T>{std::move(funcRef)};
717 }
718 
719 // Substitutes a bare type parameter reference with its value if it has one now
720 // in an instantiation.  Bare LEN type parameters are substituted only when
721 // the known value is constant.
722 Expr<TypeParamInquiry::Result> FoldOperation(
723     FoldingContext &context, TypeParamInquiry &&inquiry) {
724   std::optional<NamedEntity> base{inquiry.base()};
725   parser::CharBlock parameterName{inquiry.parameter().name()};
726   if (base) {
727     // Handling "designator%typeParam".  Get the value of the type parameter
728     // from the instantiation of the base
729     if (const semantics::DeclTypeSpec *
730         declType{base->GetLastSymbol().GetType()}) {
731       if (const semantics::ParamValue *
732           paramValue{
733               declType->derivedTypeSpec().FindParameter(parameterName)}) {
734         const semantics::MaybeIntExpr &paramExpr{paramValue->GetExplicit()};
735         if (paramExpr && IsConstantExpr(*paramExpr)) {
736           Expr<SomeInteger> intExpr{*paramExpr};
737           return Fold(context,
738               ConvertToType<TypeParamInquiry::Result>(std::move(intExpr)));
739         }
740       }
741     }
742   } else {
743     // A "bare" type parameter: replace with its value, if that's now known
744     // in a current derived type instantiation, for KIND type parameters.
745     if (const auto *pdt{context.pdtInstance()}) {
746       bool isLen{false};
747       if (const semantics::Scope * scope{context.pdtInstance()->scope()}) {
748         auto iter{scope->find(parameterName)};
749         if (iter != scope->end()) {
750           const Symbol &symbol{*iter->second};
751           const auto *details{symbol.detailsIf<semantics::TypeParamDetails>()};
752           if (details) {
753             isLen = details->attr() == common::TypeParamAttr::Len;
754             const semantics::MaybeIntExpr &initExpr{details->init()};
755             if (initExpr && IsConstantExpr(*initExpr) &&
756                 (!isLen || ToInt64(*initExpr))) {
757               Expr<SomeInteger> expr{*initExpr};
758               return Fold(context,
759                   ConvertToType<TypeParamInquiry::Result>(std::move(expr)));
760             }
761           }
762         }
763       }
764       if (const auto *value{pdt->FindParameter(parameterName)}) {
765         if (value->isExplicit()) {
766           auto folded{Fold(context,
767               AsExpr(ConvertToType<TypeParamInquiry::Result>(
768                   Expr<SomeInteger>{value->GetExplicit().value()})))};
769           if (!isLen || ToInt64(folded)) {
770             return folded;
771           }
772         }
773       }
774     }
775   }
776   return AsExpr(std::move(inquiry));
777 }
778 
779 std::optional<std::int64_t> ToInt64(const Expr<SomeInteger> &expr) {
780   return std::visit(
781       [](const auto &kindExpr) { return ToInt64(kindExpr); }, expr.u);
782 }
783 
784 std::optional<std::int64_t> ToInt64(const Expr<SomeType> &expr) {
785   if (const auto *intExpr{UnwrapExpr<Expr<SomeInteger>>(expr)}) {
786     return ToInt64(*intExpr);
787   } else {
788     return std::nullopt;
789   }
790 }
791 
792 FOR_EACH_INTEGER_KIND(template class ExpressionBase, )
793 template class ExpressionBase<SomeInteger>;
794 } // namespace Fortran::evaluate
795