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