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{GetContextFreeShape(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(), MAXLOC(), & MINLOC()
199 enum class WhichLocation { Findloc, Maxloc, Minloc };
200 template <WhichLocation WHICH> class LocationHelper {
201 public:
202   LocationHelper(
203       DynamicType &&type, ActualArguments &arg, FoldingContext &context)
204       : type_{type}, arg_{arg}, context_{context} {}
205   using Result = std::optional<Constant<SubscriptInteger>>;
206   using Types = std::conditional_t<WHICH == WhichLocation::Findloc,
207       AllIntrinsicTypes, RelationalTypes>;
208 
209   template <typename T> Result Test() const {
210     if (T::category != type_.category() || T::kind != type_.kind()) {
211       return std::nullopt;
212     }
213     CHECK(arg_.size() == (WHICH == WhichLocation::Findloc ? 6 : 5));
214     Folder<T> folder{context_};
215     Constant<T> *array{folder.Folding(arg_[0])};
216     if (!array) {
217       return std::nullopt;
218     }
219     std::optional<Constant<T>> value;
220     if constexpr (WHICH == WhichLocation::Findloc) {
221       if (const Constant<T> *p{folder.Folding(arg_[1])}) {
222         value.emplace(*p);
223       } else {
224         return std::nullopt;
225       }
226     }
227     std::optional<int> dim;
228     Constant<LogicalResult> *mask{
229         GetReductionMASK(arg_[maskArg], array->shape(), context_)};
230     if ((!mask && arg_[maskArg]) ||
231         !CheckReductionDIM(dim, context_, arg_, dimArg, array->Rank())) {
232       return std::nullopt;
233     }
234     bool back{false};
235     if (arg_[backArg]) {
236       const auto *backConst{
237           Folder<LogicalResult>{context_}.Folding(arg_[backArg])};
238       if (backConst) {
239         back = backConst->GetScalarValue().value().IsTrue();
240       } else {
241         return std::nullopt;
242       }
243     }
244     const RelationalOperator relation{WHICH == WhichLocation::Findloc
245             ? RelationalOperator::EQ
246             : WHICH == WhichLocation::Maxloc
247             ? (back ? RelationalOperator::GE : RelationalOperator::GT)
248             : back ? RelationalOperator::LE
249                    : RelationalOperator::LT};
250     // Use lower bounds of 1 exclusively.
251     array->SetLowerBoundsToOne();
252     ConstantSubscripts at{array->lbounds()}, maskAt, resultIndices, resultShape;
253     if (mask) {
254       mask->SetLowerBoundsToOne();
255       maskAt = mask->lbounds();
256     }
257     if (dim) { // DIM=
258       if (*dim < 1 || *dim > array->Rank()) {
259         context_.messages().Say("DIM=%d is out of range"_err_en_US, *dim);
260         return std::nullopt;
261       }
262       int zbDim{*dim - 1};
263       resultShape = array->shape();
264       resultShape.erase(
265           resultShape.begin() + zbDim); // scalar if array is vector
266       ConstantSubscript dimLength{array->shape()[zbDim]};
267       ConstantSubscript n{GetSize(resultShape)};
268       for (ConstantSubscript j{0}; j < n; ++j) {
269         ConstantSubscript hit{0};
270         if constexpr (WHICH == WhichLocation::Maxloc ||
271             WHICH == WhichLocation::Minloc) {
272           value.reset();
273         }
274         for (ConstantSubscript k{0}; k < dimLength;
275              ++k, ++at[zbDim], mask && ++maskAt[zbDim]) {
276           if ((!mask || mask->At(maskAt).IsTrue()) &&
277               IsHit(array->At(at), value, relation)) {
278             hit = at[zbDim];
279             if constexpr (WHICH == WhichLocation::Findloc) {
280               if (!back) {
281                 break;
282               }
283             }
284           }
285         }
286         resultIndices.emplace_back(hit);
287         at[zbDim] = std::max<ConstantSubscript>(dimLength, 1);
288         array->IncrementSubscripts(at);
289         at[zbDim] = 1;
290         if (mask) {
291           maskAt[zbDim] = mask->lbounds()[zbDim] +
292               std::max<ConstantSubscript>(dimLength, 1) - 1;
293           mask->IncrementSubscripts(maskAt);
294           maskAt[zbDim] = mask->lbounds()[zbDim];
295         }
296       }
297     } else { // no DIM=
298       resultShape = ConstantSubscripts{array->Rank()}; // always a vector
299       ConstantSubscript n{GetSize(array->shape())};
300       resultIndices = ConstantSubscripts(array->Rank(), 0);
301       for (ConstantSubscript j{0}; j < n; ++j, array->IncrementSubscripts(at),
302            mask && mask->IncrementSubscripts(maskAt)) {
303         if ((!mask || mask->At(maskAt).IsTrue()) &&
304             IsHit(array->At(at), value, relation)) {
305           resultIndices = at;
306           if constexpr (WHICH == WhichLocation::Findloc) {
307             if (!back) {
308               break;
309             }
310           }
311         }
312       }
313     }
314     std::vector<Scalar<SubscriptInteger>> resultElements;
315     for (ConstantSubscript j : resultIndices) {
316       resultElements.emplace_back(j);
317     }
318     return Constant<SubscriptInteger>{
319         std::move(resultElements), std::move(resultShape)};
320   }
321 
322 private:
323   template <typename T>
324   bool IsHit(typename Constant<T>::Element element,
325       std::optional<Constant<T>> &value,
326       [[maybe_unused]] RelationalOperator relation) const {
327     std::optional<Expr<LogicalResult>> cmp;
328     bool result{true};
329     if (value) {
330       if constexpr (T::category == TypeCategory::Logical) {
331         // array(at) .EQV. value?
332         static_assert(WHICH == WhichLocation::Findloc);
333         cmp.emplace(
334             ConvertToType<LogicalResult>(Expr<T>{LogicalOperation<T::kind>{
335                 LogicalOperator::Eqv, Expr<T>{Constant<T>{std::move(element)}},
336                 Expr<T>{Constant<T>{*value}}}}));
337       } else { // compare array(at) to value
338         cmp.emplace(
339             PackageRelation(relation, Expr<T>{Constant<T>{std::move(element)}},
340                 Expr<T>{Constant<T>{*value}}));
341       }
342       Expr<LogicalResult> folded{Fold(context_, std::move(*cmp))};
343       result = GetScalarConstantValue<LogicalResult>(folded).value().IsTrue();
344     } else {
345       // first unmasked element for MAXLOC/MINLOC - always take it
346     }
347     if constexpr (WHICH == WhichLocation::Maxloc ||
348         WHICH == WhichLocation::Minloc) {
349       if (result) {
350         value.emplace(std::move(element));
351       }
352     }
353     return result;
354   }
355 
356   static constexpr int dimArg{WHICH == WhichLocation::Findloc ? 2 : 1};
357   static constexpr int maskArg{dimArg + 1};
358   static constexpr int backArg{maskArg + 2};
359 
360   DynamicType type_;
361   ActualArguments &arg_;
362   FoldingContext &context_;
363 };
364 
365 template <WhichLocation which>
366 static std::optional<Constant<SubscriptInteger>> FoldLocationCall(
367     ActualArguments &arg, FoldingContext &context) {
368   if (arg[0]) {
369     if (auto type{arg[0]->GetType()}) {
370       return common::SearchTypes(
371           LocationHelper<which>{std::move(*type), arg, context});
372     }
373   }
374   return std::nullopt;
375 }
376 
377 template <WhichLocation which, typename T>
378 static Expr<T> FoldLocation(FoldingContext &context, FunctionRef<T> &&ref) {
379   static_assert(T::category == TypeCategory::Integer);
380   if (std::optional<Constant<SubscriptInteger>> found{
381           FoldLocationCall<which>(ref.arguments(), context)}) {
382     return Expr<T>{Fold(
383         context, ConvertToType<T>(Expr<SubscriptInteger>{std::move(*found)}))};
384   } else {
385     return Expr<T>{std::move(ref)};
386   }
387 }
388 
389 // for IALL, IANY, & IPARITY
390 template <typename T>
391 static Expr<T> FoldBitReduction(FoldingContext &context, FunctionRef<T> &&ref,
392     Scalar<T> (Scalar<T>::*operation)(const Scalar<T> &) const,
393     Scalar<T> identity) {
394   static_assert(T::category == TypeCategory::Integer);
395   std::optional<int> dim;
396   if (std::optional<Constant<T>> array{
397           ProcessReductionArgs<T>(context, ref.arguments(), dim, identity,
398               /*ARRAY=*/0, /*DIM=*/1, /*MASK=*/2)}) {
399     auto accumulator{[&](Scalar<T> &element, const ConstantSubscripts &at) {
400       element = (element.*operation)(array->At(at));
401     }};
402     return Expr<T>{DoReduction<T>(*array, dim, identity, accumulator)};
403   }
404   return Expr<T>{std::move(ref)};
405 }
406 
407 template <int KIND>
408 Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
409     FoldingContext &context,
410     FunctionRef<Type<TypeCategory::Integer, KIND>> &&funcRef) {
411   using T = Type<TypeCategory::Integer, KIND>;
412   using Int4 = Type<TypeCategory::Integer, 4>;
413   ActualArguments &args{funcRef.arguments()};
414   auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)};
415   CHECK(intrinsic);
416   std::string name{intrinsic->name};
417   if (name == "abs") { // incl. babs, iiabs, jiaabs, & kiabs
418     return FoldElementalIntrinsic<T, T>(context, std::move(funcRef),
419         ScalarFunc<T, T>([&context](const Scalar<T> &i) -> Scalar<T> {
420           typename Scalar<T>::ValueWithOverflow j{i.ABS()};
421           if (j.overflow) {
422             context.messages().Say(
423                 "abs(integer(kind=%d)) folding overflowed"_en_US, KIND);
424           }
425           return j.value;
426         }));
427   } else if (name == "bit_size") {
428     return Expr<T>{Scalar<T>::bits};
429   } else if (name == "ceiling" || name == "floor" || name == "nint") {
430     if (const auto *cx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
431       // NINT rounds ties away from zero, not to even
432       common::RoundingMode mode{name == "ceiling" ? common::RoundingMode::Up
433               : name == "floor"                   ? common::RoundingMode::Down
434                                 : common::RoundingMode::TiesAwayFromZero};
435       return std::visit(
436           [&](const auto &kx) {
437             using TR = ResultType<decltype(kx)>;
438             return FoldElementalIntrinsic<T, TR>(context, std::move(funcRef),
439                 ScalarFunc<T, TR>([&](const Scalar<TR> &x) {
440                   auto y{x.template ToInteger<Scalar<T>>(mode)};
441                   if (y.flags.test(RealFlag::Overflow)) {
442                     context.messages().Say(
443                         "%s intrinsic folding overflow"_en_US, name);
444                   }
445                   return y.value;
446                 }));
447           },
448           cx->u);
449     }
450   } else if (name == "count") {
451     return FoldCount<T>(context, std::move(funcRef));
452   } else if (name == "digits") {
453     if (const auto *cx{UnwrapExpr<Expr<SomeInteger>>(args[0])}) {
454       return Expr<T>{std::visit(
455           [](const auto &kx) {
456             return Scalar<ResultType<decltype(kx)>>::DIGITS;
457           },
458           cx->u)};
459     } else if (const auto *cx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
460       return Expr<T>{std::visit(
461           [](const auto &kx) {
462             return Scalar<ResultType<decltype(kx)>>::DIGITS;
463           },
464           cx->u)};
465     } else if (const auto *cx{UnwrapExpr<Expr<SomeComplex>>(args[0])}) {
466       return Expr<T>{std::visit(
467           [](const auto &kx) {
468             return Scalar<typename ResultType<decltype(kx)>::Part>::DIGITS;
469           },
470           cx->u)};
471     }
472   } else if (name == "dim") {
473     return FoldElementalIntrinsic<T, T, T>(
474         context, std::move(funcRef), &Scalar<T>::DIM);
475   } else if (name == "dshiftl" || name == "dshiftr") {
476     const auto fptr{
477         name == "dshiftl" ? &Scalar<T>::DSHIFTL : &Scalar<T>::DSHIFTR};
478     // Third argument can be of any kind. However, it must be smaller or equal
479     // than BIT_SIZE. It can be converted to Int4 to simplify.
480     return FoldElementalIntrinsic<T, T, T, Int4>(context, std::move(funcRef),
481         ScalarFunc<T, T, T, Int4>(
482             [&fptr](const Scalar<T> &i, const Scalar<T> &j,
483                 const Scalar<Int4> &shift) -> Scalar<T> {
484               return std::invoke(fptr, i, j, static_cast<int>(shift.ToInt64()));
485             }));
486   } else if (name == "exponent") {
487     if (auto *sx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
488       return std::visit(
489           [&funcRef, &context](const auto &x) -> Expr<T> {
490             using TR = typename std::decay_t<decltype(x)>::Result;
491             return FoldElementalIntrinsic<T, TR>(context, std::move(funcRef),
492                 &Scalar<TR>::template EXPONENT<Scalar<T>>);
493           },
494           sx->u);
495     } else {
496       DIE("exponent argument must be real");
497     }
498   } else if (name == "findloc") {
499     return FoldLocation<WhichLocation::Findloc, T>(context, std::move(funcRef));
500   } else if (name == "huge") {
501     return Expr<T>{Scalar<T>::HUGE()};
502   } else if (name == "iachar" || name == "ichar") {
503     auto *someChar{UnwrapExpr<Expr<SomeCharacter>>(args[0])};
504     CHECK(someChar);
505     if (auto len{ToInt64(someChar->LEN())}) {
506       if (len.value() != 1) {
507         // Do not die, this was not checked before
508         context.messages().Say(
509             "Character in intrinsic function %s must have length one"_en_US,
510             name);
511       } else {
512         return std::visit(
513             [&funcRef, &context](const auto &str) -> Expr<T> {
514               using Char = typename std::decay_t<decltype(str)>::Result;
515               return FoldElementalIntrinsic<T, Char>(context,
516                   std::move(funcRef),
517                   ScalarFunc<T, Char>([](const Scalar<Char> &c) {
518                     return Scalar<T>{CharacterUtils<Char::kind>::ICHAR(c)};
519                   }));
520             },
521             someChar->u);
522       }
523     }
524   } else if (name == "iand" || name == "ior" || name == "ieor") {
525     auto fptr{&Scalar<T>::IAND};
526     if (name == "iand") { // done in fptr declaration
527     } else if (name == "ior") {
528       fptr = &Scalar<T>::IOR;
529     } else if (name == "ieor") {
530       fptr = &Scalar<T>::IEOR;
531     } else {
532       common::die("missing case to fold intrinsic function %s", name.c_str());
533     }
534     return FoldElementalIntrinsic<T, T, T>(
535         context, std::move(funcRef), ScalarFunc<T, T, T>(fptr));
536   } else if (name == "iall") {
537     return FoldBitReduction(
538         context, std::move(funcRef), &Scalar<T>::IAND, Scalar<T>{}.NOT());
539   } else if (name == "iany") {
540     return FoldBitReduction(
541         context, std::move(funcRef), &Scalar<T>::IOR, Scalar<T>{});
542   } else if (name == "ibclr" || name == "ibset") {
543     // Second argument can be of any kind. However, it must be smaller
544     // than BIT_SIZE. It can be converted to Int4 to simplify.
545     auto fptr{&Scalar<T>::IBCLR};
546     if (name == "ibclr") { // done in fptr definition
547     } else if (name == "ibset") {
548       fptr = &Scalar<T>::IBSET;
549     } else {
550       common::die("missing case to fold intrinsic function %s", name.c_str());
551     }
552     return FoldElementalIntrinsic<T, T, Int4>(context, std::move(funcRef),
553         ScalarFunc<T, T, Int4>([&](const Scalar<T> &i,
554                                    const Scalar<Int4> &pos) -> Scalar<T> {
555           auto posVal{static_cast<int>(pos.ToInt64())};
556           if (posVal < 0) {
557             context.messages().Say(
558                 "bit position for %s (%d) is negative"_err_en_US, name, posVal);
559           } else if (posVal >= i.bits) {
560             context.messages().Say(
561                 "bit position for %s (%d) is not less than %d"_err_en_US, name,
562                 posVal, i.bits);
563           }
564           return std::invoke(fptr, i, posVal);
565         }));
566   } else if (name == "index" || name == "scan" || name == "verify") {
567     if (auto *charExpr{UnwrapExpr<Expr<SomeCharacter>>(args[0])}) {
568       return std::visit(
569           [&](const auto &kch) -> Expr<T> {
570             using TC = typename std::decay_t<decltype(kch)>::Result;
571             if (UnwrapExpr<Expr<SomeLogical>>(args[2])) { // BACK=
572               return FoldElementalIntrinsic<T, TC, TC, LogicalResult>(context,
573                   std::move(funcRef),
574                   ScalarFunc<T, TC, TC, LogicalResult>{
575                       [&name](const Scalar<TC> &str, const Scalar<TC> &other,
576                           const Scalar<LogicalResult> &back) -> Scalar<T> {
577                         return name == "index"
578                             ? CharacterUtils<TC::kind>::INDEX(
579                                   str, other, back.IsTrue())
580                             : name == "scan" ? CharacterUtils<TC::kind>::SCAN(
581                                                    str, other, back.IsTrue())
582                                              : CharacterUtils<TC::kind>::VERIFY(
583                                                    str, other, back.IsTrue());
584                       }});
585             } else {
586               return FoldElementalIntrinsic<T, TC, TC>(context,
587                   std::move(funcRef),
588                   ScalarFunc<T, TC, TC>{
589                       [&name](const Scalar<TC> &str,
590                           const Scalar<TC> &other) -> Scalar<T> {
591                         return name == "index"
592                             ? CharacterUtils<TC::kind>::INDEX(str, other)
593                             : name == "scan"
594                             ? CharacterUtils<TC::kind>::SCAN(str, other)
595                             : CharacterUtils<TC::kind>::VERIFY(str, other);
596                       }});
597             }
598           },
599           charExpr->u);
600     } else {
601       DIE("first argument must be CHARACTER");
602     }
603   } else if (name == "int") {
604     if (auto *expr{UnwrapExpr<Expr<SomeType>>(args[0])}) {
605       return std::visit(
606           [&](auto &&x) -> Expr<T> {
607             using From = std::decay_t<decltype(x)>;
608             if constexpr (std::is_same_v<From, BOZLiteralConstant> ||
609                 IsNumericCategoryExpr<From>()) {
610               return Fold(context, ConvertToType<T>(std::move(x)));
611             }
612             DIE("int() argument type not valid");
613           },
614           std::move(expr->u));
615     }
616   } else if (name == "int_ptr_kind") {
617     return Expr<T>{8};
618   } else if (name == "kind") {
619     if constexpr (common::HasMember<T, IntegerTypes>) {
620       return Expr<T>{args[0].value().GetType()->kind()};
621     } else {
622       DIE("kind() result not integral");
623     }
624   } else if (name == "iparity") {
625     return FoldBitReduction(
626         context, std::move(funcRef), &Scalar<T>::IEOR, Scalar<T>{});
627   } else if (name == "ishft") {
628     return FoldElementalIntrinsic<T, T, Int4>(context, std::move(funcRef),
629         ScalarFunc<T, T, Int4>([&](const Scalar<T> &i,
630                                    const Scalar<Int4> &pos) -> Scalar<T> {
631           auto posVal{static_cast<int>(pos.ToInt64())};
632           if (posVal < -i.bits) {
633             context.messages().Say(
634                 "SHIFT=%d count for ishft is less than %d"_err_en_US, posVal,
635                 -i.bits);
636           } else if (posVal > i.bits) {
637             context.messages().Say(
638                 "SHIFT=%d count for ishft is greater than %d"_err_en_US, posVal,
639                 i.bits);
640           }
641           return i.ISHFT(posVal);
642         }));
643   } else if (name == "lbound") {
644     return LBOUND(context, std::move(funcRef));
645   } else if (name == "leadz" || name == "trailz" || name == "poppar" ||
646       name == "popcnt") {
647     if (auto *sn{UnwrapExpr<Expr<SomeInteger>>(args[0])}) {
648       return std::visit(
649           [&funcRef, &context, &name](const auto &n) -> Expr<T> {
650             using TI = typename std::decay_t<decltype(n)>::Result;
651             if (name == "poppar") {
652               return FoldElementalIntrinsic<T, TI>(context, std::move(funcRef),
653                   ScalarFunc<T, TI>([](const Scalar<TI> &i) -> Scalar<T> {
654                     return Scalar<T>{i.POPPAR() ? 1 : 0};
655                   }));
656             }
657             auto fptr{&Scalar<TI>::LEADZ};
658             if (name == "leadz") { // done in fptr definition
659             } else if (name == "trailz") {
660               fptr = &Scalar<TI>::TRAILZ;
661             } else if (name == "popcnt") {
662               fptr = &Scalar<TI>::POPCNT;
663             } else {
664               common::die(
665                   "missing case to fold intrinsic function %s", name.c_str());
666             }
667             return FoldElementalIntrinsic<T, TI>(context, std::move(funcRef),
668                 ScalarFunc<T, TI>([&fptr](const Scalar<TI> &i) -> Scalar<T> {
669                   return Scalar<T>{std::invoke(fptr, i)};
670                 }));
671           },
672           sn->u);
673     } else {
674       DIE("leadz argument must be integer");
675     }
676   } else if (name == "len") {
677     if (auto *charExpr{UnwrapExpr<Expr<SomeCharacter>>(args[0])}) {
678       return std::visit(
679           [&](auto &kx) {
680             if (auto len{kx.LEN()}) {
681               if (IsScopeInvariantExpr(*len)) {
682                 return Fold(context, ConvertToType<T>(*std::move(len)));
683               } else {
684                 return Expr<T>{std::move(funcRef)};
685               }
686             } else {
687               return Expr<T>{std::move(funcRef)};
688             }
689           },
690           charExpr->u);
691     } else {
692       DIE("len() argument must be of character type");
693     }
694   } else if (name == "len_trim") {
695     if (auto *charExpr{UnwrapExpr<Expr<SomeCharacter>>(args[0])}) {
696       return std::visit(
697           [&](const auto &kch) -> Expr<T> {
698             using TC = typename std::decay_t<decltype(kch)>::Result;
699             return FoldElementalIntrinsic<T, TC>(context, std::move(funcRef),
700                 ScalarFunc<T, TC>{[](const Scalar<TC> &str) -> Scalar<T> {
701                   return CharacterUtils<TC::kind>::LEN_TRIM(str);
702                 }});
703           },
704           charExpr->u);
705     } else {
706       DIE("len_trim() argument must be of character type");
707     }
708   } else if (name == "maskl" || name == "maskr") {
709     // Argument can be of any kind but value has to be smaller than BIT_SIZE.
710     // It can be safely converted to Int4 to simplify.
711     const auto fptr{name == "maskl" ? &Scalar<T>::MASKL : &Scalar<T>::MASKR};
712     return FoldElementalIntrinsic<T, Int4>(context, std::move(funcRef),
713         ScalarFunc<T, Int4>([&fptr](const Scalar<Int4> &places) -> Scalar<T> {
714           return fptr(static_cast<int>(places.ToInt64()));
715         }));
716   } else if (name == "max") {
717     return FoldMINorMAX(context, std::move(funcRef), Ordering::Greater);
718   } else if (name == "max0" || name == "max1") {
719     return RewriteSpecificMINorMAX(context, std::move(funcRef));
720   } else if (name == "maxexponent") {
721     if (auto *sx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
722       return std::visit(
723           [](const auto &x) {
724             using TR = typename std::decay_t<decltype(x)>::Result;
725             return Expr<T>{Scalar<TR>::MAXEXPONENT};
726           },
727           sx->u);
728     }
729   } else if (name == "maxloc") {
730     return FoldLocation<WhichLocation::Maxloc, T>(context, std::move(funcRef));
731   } else if (name == "maxval") {
732     return FoldMaxvalMinval<T>(context, std::move(funcRef),
733         RelationalOperator::GT, T::Scalar::Least());
734   } else if (name == "merge") {
735     return FoldMerge<T>(context, std::move(funcRef));
736   } else if (name == "merge_bits") {
737     return FoldElementalIntrinsic<T, T, T, T>(
738         context, std::move(funcRef), &Scalar<T>::MERGE_BITS);
739   } else if (name == "min") {
740     return FoldMINorMAX(context, std::move(funcRef), Ordering::Less);
741   } else if (name == "min0" || name == "min1") {
742     return RewriteSpecificMINorMAX(context, std::move(funcRef));
743   } else if (name == "minexponent") {
744     if (auto *sx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
745       return std::visit(
746           [](const auto &x) {
747             using TR = typename std::decay_t<decltype(x)>::Result;
748             return Expr<T>{Scalar<TR>::MINEXPONENT};
749           },
750           sx->u);
751     }
752   } else if (name == "minloc") {
753     return FoldLocation<WhichLocation::Minloc, T>(context, std::move(funcRef));
754   } else if (name == "minval") {
755     return FoldMaxvalMinval<T>(
756         context, std::move(funcRef), RelationalOperator::LT, T::Scalar::HUGE());
757   } else if (name == "mod") {
758     return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
759         ScalarFuncWithContext<T, T, T>(
760             [](FoldingContext &context, const Scalar<T> &x,
761                 const Scalar<T> &y) -> Scalar<T> {
762               auto quotRem{x.DivideSigned(y)};
763               if (quotRem.divisionByZero) {
764                 context.messages().Say("mod() by zero"_en_US);
765               } else if (quotRem.overflow) {
766                 context.messages().Say("mod() folding overflowed"_en_US);
767               }
768               return quotRem.remainder;
769             }));
770   } else if (name == "modulo") {
771     return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
772         ScalarFuncWithContext<T, T, T>(
773             [](FoldingContext &context, const Scalar<T> &x,
774                 const Scalar<T> &y) -> Scalar<T> {
775               auto result{x.MODULO(y)};
776               if (result.overflow) {
777                 context.messages().Say("modulo() folding overflowed"_en_US);
778               }
779               return result.value;
780             }));
781   } else if (name == "not") {
782     return FoldElementalIntrinsic<T, T>(
783         context, std::move(funcRef), &Scalar<T>::NOT);
784   } else if (name == "precision") {
785     if (const auto *cx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
786       return Expr<T>{std::visit(
787           [](const auto &kx) {
788             return Scalar<ResultType<decltype(kx)>>::PRECISION;
789           },
790           cx->u)};
791     } else if (const auto *cx{UnwrapExpr<Expr<SomeComplex>>(args[0])}) {
792       return Expr<T>{std::visit(
793           [](const auto &kx) {
794             return Scalar<typename ResultType<decltype(kx)>::Part>::PRECISION;
795           },
796           cx->u)};
797     }
798   } else if (name == "product") {
799     return FoldProduct<T>(context, std::move(funcRef), Scalar<T>{1});
800   } else if (name == "radix") {
801     return Expr<T>{2};
802   } else if (name == "range") {
803     if (const auto *cx{UnwrapExpr<Expr<SomeInteger>>(args[0])}) {
804       return Expr<T>{std::visit(
805           [](const auto &kx) {
806             return Scalar<ResultType<decltype(kx)>>::RANGE;
807           },
808           cx->u)};
809     } else if (const auto *cx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
810       return Expr<T>{std::visit(
811           [](const auto &kx) {
812             return Scalar<ResultType<decltype(kx)>>::RANGE;
813           },
814           cx->u)};
815     } else if (const auto *cx{UnwrapExpr<Expr<SomeComplex>>(args[0])}) {
816       return Expr<T>{std::visit(
817           [](const auto &kx) {
818             return Scalar<typename ResultType<decltype(kx)>::Part>::RANGE;
819           },
820           cx->u)};
821     }
822   } else if (name == "rank") {
823     if (const auto *array{UnwrapExpr<Expr<SomeType>>(args[0])}) {
824       if (auto named{ExtractNamedEntity(*array)}) {
825         const Symbol &symbol{named->GetLastSymbol()};
826         if (IsAssumedRank(symbol)) {
827           // DescriptorInquiry can only be placed in expression of kind
828           // DescriptorInquiry::Result::kind.
829           return ConvertToType<T>(Expr<
830               Type<TypeCategory::Integer, DescriptorInquiry::Result::kind>>{
831               DescriptorInquiry{*named, DescriptorInquiry::Field::Rank}});
832         }
833       }
834       return Expr<T>{args[0].value().Rank()};
835     }
836     return Expr<T>{args[0].value().Rank()};
837   } else if (name == "selected_char_kind") {
838     if (const auto *chCon{UnwrapExpr<Constant<TypeOf<std::string>>>(args[0])}) {
839       if (std::optional<std::string> value{chCon->GetScalarValue()}) {
840         int defaultKind{
841             context.defaults().GetDefaultKind(TypeCategory::Character)};
842         return Expr<T>{SelectedCharKind(*value, defaultKind)};
843       }
844     }
845   } else if (name == "selected_int_kind") {
846     if (auto p{GetInt64Arg(args[0])}) {
847       return Expr<T>{SelectedIntKind(*p)};
848     }
849   } else if (name == "selected_real_kind" ||
850       name == "__builtin_ieee_selected_real_kind") {
851     if (auto p{GetInt64ArgOr(args[0], 0)}) {
852       if (auto r{GetInt64ArgOr(args[1], 0)}) {
853         if (auto radix{GetInt64ArgOr(args[2], 2)}) {
854           return Expr<T>{SelectedRealKind(*p, *r, *radix)};
855         }
856       }
857     }
858   } else if (name == "shape") {
859     if (auto shape{GetContextFreeShape(context, args[0])}) {
860       if (auto shapeExpr{AsExtentArrayExpr(*shape)}) {
861         return Fold(context, ConvertToType<T>(std::move(*shapeExpr)));
862       }
863     }
864   } else if (name == "shifta" || name == "shiftr" || name == "shiftl") {
865     // Second argument can be of any kind. However, it must be smaller or
866     // equal than BIT_SIZE. It can be converted to Int4 to simplify.
867     auto fptr{&Scalar<T>::SHIFTA};
868     if (name == "shifta") { // done in fptr definition
869     } else if (name == "shiftr") {
870       fptr = &Scalar<T>::SHIFTR;
871     } else if (name == "shiftl") {
872       fptr = &Scalar<T>::SHIFTL;
873     } else {
874       common::die("missing case to fold intrinsic function %s", name.c_str());
875     }
876     return FoldElementalIntrinsic<T, T, Int4>(context, std::move(funcRef),
877         ScalarFunc<T, T, Int4>([&](const Scalar<T> &i,
878                                    const Scalar<Int4> &pos) -> Scalar<T> {
879           auto posVal{static_cast<int>(pos.ToInt64())};
880           if (posVal < 0) {
881             context.messages().Say(
882                 "SHIFT=%d count for %s is negative"_err_en_US, posVal, name);
883           } else if (posVal > i.bits) {
884             context.messages().Say(
885                 "SHIFT=%d count for %s is greater than %d"_err_en_US, posVal,
886                 name, i.bits);
887           }
888           return std::invoke(fptr, i, posVal);
889         }));
890   } else if (name == "sign") {
891     return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
892         ScalarFunc<T, T, T>(
893             [&context](const Scalar<T> &j, const Scalar<T> &k) -> Scalar<T> {
894               typename Scalar<T>::ValueWithOverflow result{j.SIGN(k)};
895               if (result.overflow) {
896                 context.messages().Say(
897                     "sign(integer(kind=%d)) folding overflowed"_en_US, KIND);
898               }
899               return result.value;
900             }));
901   } else if (name == "size") {
902     if (auto shape{GetContextFreeShape(context, args[0])}) {
903       if (auto &dimArg{args[1]}) { // DIM= is present, get one extent
904         if (auto dim{GetInt64Arg(args[1])}) {
905           int rank{GetRank(*shape)};
906           if (*dim >= 1 && *dim <= rank) {
907             const Symbol *symbol{UnwrapWholeSymbolDataRef(args[0])};
908             if (symbol && IsAssumedSizeArray(*symbol) && *dim == rank) {
909               context.messages().Say(
910                   "size(array,dim=%jd) of last dimension is not available for rank-%d assumed-size array dummy argument"_err_en_US,
911                   *dim, rank);
912               return MakeInvalidIntrinsic<T>(std::move(funcRef));
913             } else if (auto &extent{shape->at(*dim - 1)}) {
914               return Fold(context, ConvertToType<T>(std::move(*extent)));
915             }
916           } else {
917             context.messages().Say(
918                 "size(array,dim=%jd) dimension is out of range for rank-%d array"_en_US,
919                 *dim, rank);
920           }
921         }
922       } else if (auto extents{common::AllElementsPresent(std::move(*shape))}) {
923         // DIM= is absent; compute PRODUCT(SHAPE())
924         ExtentExpr product{1};
925         for (auto &&extent : std::move(*extents)) {
926           product = std::move(product) * std::move(extent);
927         }
928         return Expr<T>{ConvertToType<T>(Fold(context, std::move(product)))};
929       }
930     }
931   } else if (name == "sizeof") { // in bytes; extension
932     if (auto info{
933             characteristics::TypeAndShape::Characterize(args[0], context)}) {
934       if (auto bytes{info->MeasureSizeInBytes(context)}) {
935         return Expr<T>{Fold(context, ConvertToType<T>(std::move(*bytes)))};
936       }
937     }
938   } else if (name == "storage_size") { // in bits
939     if (auto info{
940             characteristics::TypeAndShape::Characterize(args[0], context)}) {
941       if (auto bytes{info->MeasureElementSizeInBytes(context, true)}) {
942         return Expr<T>{
943             Fold(context, Expr<T>{8} * ConvertToType<T>(std::move(*bytes)))};
944       }
945     }
946   } else if (name == "sum") {
947     return FoldSum<T>(context, std::move(funcRef));
948   } else if (name == "ubound") {
949     return UBOUND(context, std::move(funcRef));
950   }
951   // TODO: dot_product, ibits, ishftc, matmul, sign, transfer
952   return Expr<T>{std::move(funcRef)};
953 }
954 
955 // Substitutes a bare type parameter reference with its value if it has one now
956 // in an instantiation.  Bare LEN type parameters are substituted only when
957 // the known value is constant.
958 Expr<TypeParamInquiry::Result> FoldOperation(
959     FoldingContext &context, TypeParamInquiry &&inquiry) {
960   std::optional<NamedEntity> base{inquiry.base()};
961   parser::CharBlock parameterName{inquiry.parameter().name()};
962   if (base) {
963     // Handling "designator%typeParam".  Get the value of the type parameter
964     // from the instantiation of the base
965     if (const semantics::DeclTypeSpec *
966         declType{base->GetLastSymbol().GetType()}) {
967       if (const semantics::ParamValue *
968           paramValue{
969               declType->derivedTypeSpec().FindParameter(parameterName)}) {
970         const semantics::MaybeIntExpr &paramExpr{paramValue->GetExplicit()};
971         if (paramExpr && IsConstantExpr(*paramExpr)) {
972           Expr<SomeInteger> intExpr{*paramExpr};
973           return Fold(context,
974               ConvertToType<TypeParamInquiry::Result>(std::move(intExpr)));
975         }
976       }
977     }
978   } else {
979     // A "bare" type parameter: replace with its value, if that's now known
980     // in a current derived type instantiation, for KIND type parameters.
981     if (const auto *pdt{context.pdtInstance()}) {
982       bool isLen{false};
983       if (const semantics::Scope * scope{context.pdtInstance()->scope()}) {
984         auto iter{scope->find(parameterName)};
985         if (iter != scope->end()) {
986           const Symbol &symbol{*iter->second};
987           const auto *details{symbol.detailsIf<semantics::TypeParamDetails>()};
988           if (details) {
989             isLen = details->attr() == common::TypeParamAttr::Len;
990             const semantics::MaybeIntExpr &initExpr{details->init()};
991             if (initExpr && IsConstantExpr(*initExpr) &&
992                 (!isLen || ToInt64(*initExpr))) {
993               Expr<SomeInteger> expr{*initExpr};
994               return Fold(context,
995                   ConvertToType<TypeParamInquiry::Result>(std::move(expr)));
996             }
997           }
998         }
999       }
1000       if (const auto *value{pdt->FindParameter(parameterName)}) {
1001         if (value->isExplicit()) {
1002           auto folded{Fold(context,
1003               AsExpr(ConvertToType<TypeParamInquiry::Result>(
1004                   Expr<SomeInteger>{value->GetExplicit().value()})))};
1005           if (!isLen || ToInt64(folded)) {
1006             return folded;
1007           }
1008         }
1009       }
1010     }
1011   }
1012   return AsExpr(std::move(inquiry));
1013 }
1014 
1015 std::optional<std::int64_t> ToInt64(const Expr<SomeInteger> &expr) {
1016   return std::visit(
1017       [](const auto &kindExpr) { return ToInt64(kindExpr); }, expr.u);
1018 }
1019 
1020 std::optional<std::int64_t> ToInt64(const Expr<SomeType> &expr) {
1021   if (const auto *intExpr{UnwrapExpr<Expr<SomeInteger>>(expr)}) {
1022     return ToInt64(*intExpr);
1023   } else {
1024     return std::nullopt;
1025   }
1026 }
1027 
1028 #ifdef _MSC_VER // disable bogus warning about missing definitions
1029 #pragma warning(disable : 4661)
1030 #endif
1031 FOR_EACH_INTEGER_KIND(template class ExpressionBase, )
1032 template class ExpressionBase<SomeInteger>;
1033 } // namespace Fortran::evaluate
1034