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