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
11 namespace Fortran::evaluate {
12
13 template <int KIND>
LBOUND(FoldingContext & context,FunctionRef<Type<TypeCategory::Integer,KIND>> && funcRef)14 Expr<Type<TypeCategory::Integer, KIND>> LBOUND(FoldingContext &context,
15 FunctionRef<Type<TypeCategory::Integer, KIND>> &&funcRef) {
16 using T = Type<TypeCategory::Integer, KIND>;
17 ActualArguments &args{funcRef.arguments()};
18 if (const auto *array{UnwrapExpr<Expr<SomeType>>(args[0])}) {
19 if (int rank{array->Rank()}; rank > 0) {
20 std::optional<int> dim;
21 if (funcRef.Rank() == 0) {
22 // Optional DIM= argument is present: result is scalar.
23 if (auto dim64{GetInt64Arg(args[1])}) {
24 if (*dim64 < 1 || *dim64 > rank) {
25 context.messages().Say("DIM=%jd dimension is out of range for "
26 "rank-%d array"_en_US,
27 *dim64, rank);
28 return MakeInvalidIntrinsic<T>(std::move(funcRef));
29 } else {
30 dim = *dim64 - 1; // 1-based to 0-based
31 }
32 } else {
33 // DIM= is present but not constant
34 return Expr<T>{std::move(funcRef)};
35 }
36 }
37 bool lowerBoundsAreOne{true};
38 if (auto named{ExtractNamedEntity(*array)}) {
39 const Symbol &symbol{named->GetLastSymbol()};
40 if (symbol.Rank() == rank) {
41 lowerBoundsAreOne = false;
42 if (dim) {
43 return Fold(context,
44 ConvertToType<T>(GetLowerBound(context, *named, *dim)));
45 } else if (auto extents{
46 AsExtentArrayExpr(GetLowerBounds(context, *named))}) {
47 return Fold(context,
48 ConvertToType<T>(Expr<ExtentType>{std::move(*extents)}));
49 }
50 } else {
51 lowerBoundsAreOne = symbol.Rank() == 0; // LBOUND(array%component)
52 }
53 }
54 if (lowerBoundsAreOne) {
55 if (dim) {
56 return Expr<T>{1};
57 } else {
58 std::vector<Scalar<T>> ones(rank, Scalar<T>{1});
59 return Expr<T>{
60 Constant<T>{std::move(ones), ConstantSubscripts{rank}}};
61 }
62 }
63 }
64 }
65 return Expr<T>{std::move(funcRef)};
66 }
67
68 template <int KIND>
UBOUND(FoldingContext & context,FunctionRef<Type<TypeCategory::Integer,KIND>> && funcRef)69 Expr<Type<TypeCategory::Integer, KIND>> UBOUND(FoldingContext &context,
70 FunctionRef<Type<TypeCategory::Integer, KIND>> &&funcRef) {
71 using T = Type<TypeCategory::Integer, KIND>;
72 ActualArguments &args{funcRef.arguments()};
73 if (auto *array{UnwrapExpr<Expr<SomeType>>(args[0])}) {
74 if (int rank{array->Rank()}; rank > 0) {
75 std::optional<int> dim;
76 if (funcRef.Rank() == 0) {
77 // Optional DIM= argument is present: result is scalar.
78 if (auto dim64{GetInt64Arg(args[1])}) {
79 if (*dim64 < 1 || *dim64 > rank) {
80 context.messages().Say("DIM=%jd dimension is out of range for "
81 "rank-%d array"_en_US,
82 *dim64, rank);
83 return MakeInvalidIntrinsic<T>(std::move(funcRef));
84 } else {
85 dim = *dim64 - 1; // 1-based to 0-based
86 }
87 } else {
88 // DIM= is present but not constant
89 return Expr<T>{std::move(funcRef)};
90 }
91 }
92 bool takeBoundsFromShape{true};
93 if (auto named{ExtractNamedEntity(*array)}) {
94 const Symbol &symbol{named->GetLastSymbol()};
95 if (symbol.Rank() == rank) {
96 takeBoundsFromShape = false;
97 if (dim) {
98 if (semantics::IsAssumedSizeArray(symbol) && *dim == rank) {
99 return Expr<T>{-1};
100 } else if (auto ub{GetUpperBound(context, *named, *dim)}) {
101 return Fold(context, ConvertToType<T>(std::move(*ub)));
102 }
103 } else {
104 Shape ubounds{GetUpperBounds(context, *named)};
105 if (semantics::IsAssumedSizeArray(symbol)) {
106 CHECK(!ubounds.back());
107 ubounds.back() = ExtentExpr{-1};
108 }
109 if (auto extents{AsExtentArrayExpr(ubounds)}) {
110 return Fold(context,
111 ConvertToType<T>(Expr<ExtentType>{std::move(*extents)}));
112 }
113 }
114 } else {
115 takeBoundsFromShape = symbol.Rank() == 0; // UBOUND(array%component)
116 }
117 }
118 if (takeBoundsFromShape) {
119 if (auto shape{GetShape(context, *array)}) {
120 if (dim) {
121 if (auto &dimSize{shape->at(*dim)}) {
122 return Fold(context,
123 ConvertToType<T>(Expr<ExtentType>{std::move(*dimSize)}));
124 }
125 } else if (auto shapeExpr{AsExtentArrayExpr(*shape)}) {
126 return Fold(context, ConvertToType<T>(std::move(*shapeExpr)));
127 }
128 }
129 }
130 }
131 }
132 return Expr<T>{std::move(funcRef)};
133 }
134
135 template <int KIND>
FoldIntrinsicFunction(FoldingContext & context,FunctionRef<Type<TypeCategory::Integer,KIND>> && funcRef)136 Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
137 FoldingContext &context,
138 FunctionRef<Type<TypeCategory::Integer, KIND>> &&funcRef) {
139 using T = Type<TypeCategory::Integer, KIND>;
140 using Int4 = Type<TypeCategory::Integer, 4>;
141 ActualArguments &args{funcRef.arguments()};
142 auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)};
143 CHECK(intrinsic);
144 std::string name{intrinsic->name};
145 if (name == "abs") {
146 return FoldElementalIntrinsic<T, T>(context, std::move(funcRef),
147 ScalarFunc<T, T>([&context](const Scalar<T> &i) -> Scalar<T> {
148 typename Scalar<T>::ValueWithOverflow j{i.ABS()};
149 if (j.overflow) {
150 context.messages().Say(
151 "abs(integer(kind=%d)) folding overflowed"_en_US, KIND);
152 }
153 return j.value;
154 }));
155 } else if (name == "bit_size") {
156 return Expr<T>{Scalar<T>::bits};
157 } else if (name == "ceiling" || name == "floor" || name == "nint") {
158 if (const auto *cx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
159 // NINT rounds ties away from zero, not to even
160 common::RoundingMode mode{name == "ceiling" ? common::RoundingMode::Up
161 : name == "floor" ? common::RoundingMode::Down
162 : common::RoundingMode::TiesAwayFromZero};
163 return std::visit(
164 [&](const auto &kx) {
165 using TR = ResultType<decltype(kx)>;
166 return FoldElementalIntrinsic<T, TR>(context, std::move(funcRef),
167 ScalarFunc<T, TR>([&](const Scalar<TR> &x) {
168 auto y{x.template ToInteger<Scalar<T>>(mode)};
169 if (y.flags.test(RealFlag::Overflow)) {
170 context.messages().Say(
171 "%s intrinsic folding overflow"_en_US, name);
172 }
173 return y.value;
174 }));
175 },
176 cx->u);
177 }
178 } else if (name == "count") {
179 if (!args[1]) { // TODO: COUNT(x,DIM=d)
180 if (const auto *constant{UnwrapConstantValue<LogicalResult>(args[0])}) {
181 std::int64_t result{0};
182 for (const auto &element : constant->values()) {
183 if (element.IsTrue()) {
184 ++result;
185 }
186 }
187 return Expr<T>{result};
188 }
189 }
190 } else if (name == "digits") {
191 if (const auto *cx{UnwrapExpr<Expr<SomeInteger>>(args[0])}) {
192 return Expr<T>{std::visit(
193 [](const auto &kx) {
194 return Scalar<ResultType<decltype(kx)>>::DIGITS;
195 },
196 cx->u)};
197 } else if (const auto *cx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
198 return Expr<T>{std::visit(
199 [](const auto &kx) {
200 return Scalar<ResultType<decltype(kx)>>::DIGITS;
201 },
202 cx->u)};
203 } else if (const auto *cx{UnwrapExpr<Expr<SomeComplex>>(args[0])}) {
204 return Expr<T>{std::visit(
205 [](const auto &kx) {
206 return Scalar<typename ResultType<decltype(kx)>::Part>::DIGITS;
207 },
208 cx->u)};
209 }
210 } else if (name == "dim") {
211 return FoldElementalIntrinsic<T, T, T>(
212 context, std::move(funcRef), &Scalar<T>::DIM);
213 } else if (name == "dshiftl" || name == "dshiftr") {
214 const auto fptr{
215 name == "dshiftl" ? &Scalar<T>::DSHIFTL : &Scalar<T>::DSHIFTR};
216 // Third argument can be of any kind. However, it must be smaller or equal
217 // than BIT_SIZE. It can be converted to Int4 to simplify.
218 return FoldElementalIntrinsic<T, T, T, Int4>(context, std::move(funcRef),
219 ScalarFunc<T, T, T, Int4>(
220 [&fptr](const Scalar<T> &i, const Scalar<T> &j,
221 const Scalar<Int4> &shift) -> Scalar<T> {
222 return std::invoke(fptr, i, j, static_cast<int>(shift.ToInt64()));
223 }));
224 } else if (name == "exponent") {
225 if (auto *sx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
226 return std::visit(
227 [&funcRef, &context](const auto &x) -> Expr<T> {
228 using TR = typename std::decay_t<decltype(x)>::Result;
229 return FoldElementalIntrinsic<T, TR>(context, std::move(funcRef),
230 &Scalar<TR>::template EXPONENT<Scalar<T>>);
231 },
232 sx->u);
233 } else {
234 DIE("exponent argument must be real");
235 }
236 } else if (name == "huge") {
237 return Expr<T>{Scalar<T>::HUGE()};
238 } else if (name == "iachar" || name == "ichar") {
239 auto *someChar{UnwrapExpr<Expr<SomeCharacter>>(args[0])};
240 CHECK(someChar);
241 if (auto len{ToInt64(someChar->LEN())}) {
242 if (len.value() != 1) {
243 // Do not die, this was not checked before
244 context.messages().Say(
245 "Character in intrinsic function %s must have length one"_en_US,
246 name);
247 } else {
248 return std::visit(
249 [&funcRef, &context](const auto &str) -> Expr<T> {
250 using Char = typename std::decay_t<decltype(str)>::Result;
251 return FoldElementalIntrinsic<T, Char>(context,
252 std::move(funcRef),
253 ScalarFunc<T, Char>([](const Scalar<Char> &c) {
254 return Scalar<T>{CharacterUtils<Char::kind>::ICHAR(c)};
255 }));
256 },
257 someChar->u);
258 }
259 }
260 } else if (name == "iand" || name == "ior" || name == "ieor") {
261 auto fptr{&Scalar<T>::IAND};
262 if (name == "iand") { // done in fptr declaration
263 } else if (name == "ior") {
264 fptr = &Scalar<T>::IOR;
265 } else if (name == "ieor") {
266 fptr = &Scalar<T>::IEOR;
267 } else {
268 common::die("missing case to fold intrinsic function %s", name.c_str());
269 }
270 return FoldElementalIntrinsic<T, T, T>(
271 context, std::move(funcRef), ScalarFunc<T, T, T>(fptr));
272 } else if (name == "ibclr" || name == "ibset" || name == "ishft" ||
273 name == "shifta" || name == "shiftr" || name == "shiftl") {
274 // Second argument can be of any kind. However, it must be smaller or
275 // equal than BIT_SIZE. It can be converted to Int4 to simplify.
276 auto fptr{&Scalar<T>::IBCLR};
277 if (name == "ibclr") { // done in fprt definition
278 } else if (name == "ibset") {
279 fptr = &Scalar<T>::IBSET;
280 } else if (name == "ishft") {
281 fptr = &Scalar<T>::ISHFT;
282 } else if (name == "shifta") {
283 fptr = &Scalar<T>::SHIFTA;
284 } else if (name == "shiftr") {
285 fptr = &Scalar<T>::SHIFTR;
286 } else if (name == "shiftl") {
287 fptr = &Scalar<T>::SHIFTL;
288 } else {
289 common::die("missing case to fold intrinsic function %s", name.c_str());
290 }
291 return FoldElementalIntrinsic<T, T, Int4>(context, std::move(funcRef),
292 ScalarFunc<T, T, Int4>(
293 [&fptr](const Scalar<T> &i, const Scalar<Int4> &pos) -> Scalar<T> {
294 return std::invoke(fptr, i, static_cast<int>(pos.ToInt64()));
295 }));
296 } else if (name == "index" || name == "scan" || name == "verify") {
297 if (auto *charExpr{UnwrapExpr<Expr<SomeCharacter>>(args[0])}) {
298 return std::visit(
299 [&](const auto &kch) -> Expr<T> {
300 using TC = typename std::decay_t<decltype(kch)>::Result;
301 if (UnwrapExpr<Expr<SomeLogical>>(args[2])) { // BACK=
302 return FoldElementalIntrinsic<T, TC, TC, LogicalResult>(context,
303 std::move(funcRef),
304 ScalarFunc<T, TC, TC, LogicalResult>{
305 [&name](const Scalar<TC> &str, const Scalar<TC> &other,
306 const Scalar<LogicalResult> &back) -> Scalar<T> {
307 return name == "index"
308 ? CharacterUtils<TC::kind>::INDEX(
309 str, other, back.IsTrue())
310 : name == "scan" ? CharacterUtils<TC::kind>::SCAN(
311 str, other, back.IsTrue())
312 : CharacterUtils<TC::kind>::VERIFY(
313 str, other, back.IsTrue());
314 }});
315 } else {
316 return FoldElementalIntrinsic<T, TC, TC>(context,
317 std::move(funcRef),
318 ScalarFunc<T, TC, TC>{
319 [&name](const Scalar<TC> &str,
320 const Scalar<TC> &other) -> Scalar<T> {
321 return name == "index"
322 ? CharacterUtils<TC::kind>::INDEX(str, other)
323 : name == "scan"
324 ? CharacterUtils<TC::kind>::SCAN(str, other)
325 : CharacterUtils<TC::kind>::VERIFY(str, other);
326 }});
327 }
328 },
329 charExpr->u);
330 } else {
331 DIE("first argument must be CHARACTER");
332 }
333 } else if (name == "int") {
334 if (auto *expr{UnwrapExpr<Expr<SomeType>>(args[0])}) {
335 return std::visit(
336 [&](auto &&x) -> Expr<T> {
337 using From = std::decay_t<decltype(x)>;
338 if constexpr (std::is_same_v<From, BOZLiteralConstant> ||
339 IsNumericCategoryExpr<From>()) {
340 return Fold(context, ConvertToType<T>(std::move(x)));
341 }
342 DIE("int() argument type not valid");
343 },
344 std::move(expr->u));
345 }
346 } else if (name == "int_ptr_kind") {
347 return Expr<T>{8};
348 } else if (name == "kind") {
349 if constexpr (common::HasMember<T, IntegerTypes>) {
350 return Expr<T>{args[0].value().GetType()->kind()};
351 } else {
352 DIE("kind() result not integral");
353 }
354 } else if (name == "lbound") {
355 return LBOUND(context, std::move(funcRef));
356 } else if (name == "leadz" || name == "trailz" || name == "poppar" ||
357 name == "popcnt") {
358 if (auto *sn{UnwrapExpr<Expr<SomeInteger>>(args[0])}) {
359 return std::visit(
360 [&funcRef, &context, &name](const auto &n) -> Expr<T> {
361 using TI = typename std::decay_t<decltype(n)>::Result;
362 if (name == "poppar") {
363 return FoldElementalIntrinsic<T, TI>(context, std::move(funcRef),
364 ScalarFunc<T, TI>([](const Scalar<TI> &i) -> Scalar<T> {
365 return Scalar<T>{i.POPPAR() ? 1 : 0};
366 }));
367 }
368 auto fptr{&Scalar<TI>::LEADZ};
369 if (name == "leadz") { // done in fptr definition
370 } else if (name == "trailz") {
371 fptr = &Scalar<TI>::TRAILZ;
372 } else if (name == "popcnt") {
373 fptr = &Scalar<TI>::POPCNT;
374 } else {
375 common::die(
376 "missing case to fold intrinsic function %s", name.c_str());
377 }
378 return FoldElementalIntrinsic<T, TI>(context, std::move(funcRef),
379 ScalarFunc<T, TI>([&fptr](const Scalar<TI> &i) -> Scalar<T> {
380 return Scalar<T>{std::invoke(fptr, i)};
381 }));
382 },
383 sn->u);
384 } else {
385 DIE("leadz argument must be integer");
386 }
387 } else if (name == "len") {
388 if (auto *charExpr{UnwrapExpr<Expr<SomeCharacter>>(args[0])}) {
389 return std::visit(
390 [&](auto &kx) {
391 if (auto len{kx.LEN()}) {
392 return Fold(context, ConvertToType<T>(*std::move(len)));
393 } else {
394 return Expr<T>{std::move(funcRef)};
395 }
396 },
397 charExpr->u);
398 } else {
399 DIE("len() argument must be of character type");
400 }
401 } else if (name == "len_trim") {
402 if (auto *charExpr{UnwrapExpr<Expr<SomeCharacter>>(args[0])}) {
403 return std::visit(
404 [&](const auto &kch) -> Expr<T> {
405 using TC = typename std::decay_t<decltype(kch)>::Result;
406 return FoldElementalIntrinsic<T, TC>(context, std::move(funcRef),
407 ScalarFunc<T, TC>{[](const Scalar<TC> &str) -> Scalar<T> {
408 return CharacterUtils<TC::kind>::LEN_TRIM(str);
409 }});
410 },
411 charExpr->u);
412 } else {
413 DIE("len_trim() argument must be of character type");
414 }
415 } else if (name == "maskl" || name == "maskr") {
416 // Argument can be of any kind but value has to be smaller than BIT_SIZE.
417 // It can be safely converted to Int4 to simplify.
418 const auto fptr{name == "maskl" ? &Scalar<T>::MASKL : &Scalar<T>::MASKR};
419 return FoldElementalIntrinsic<T, Int4>(context, std::move(funcRef),
420 ScalarFunc<T, Int4>([&fptr](const Scalar<Int4> &places) -> Scalar<T> {
421 return fptr(static_cast<int>(places.ToInt64()));
422 }));
423 } else if (name == "max") {
424 return FoldMINorMAX(context, std::move(funcRef), Ordering::Greater);
425 } else if (name == "max0" || name == "max1") {
426 return RewriteSpecificMINorMAX(context, std::move(funcRef));
427 } else if (name == "maxexponent") {
428 if (auto *sx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
429 return std::visit(
430 [](const auto &x) {
431 using TR = typename std::decay_t<decltype(x)>::Result;
432 return Expr<T>{Scalar<TR>::MAXEXPONENT};
433 },
434 sx->u);
435 }
436 } else if (name == "merge") {
437 return FoldMerge<T>(context, std::move(funcRef));
438 } else if (name == "merge_bits") {
439 return FoldElementalIntrinsic<T, T, T, T>(
440 context, std::move(funcRef), &Scalar<T>::MERGE_BITS);
441 } else if (name == "minexponent") {
442 if (auto *sx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
443 return std::visit(
444 [](const auto &x) {
445 using TR = typename std::decay_t<decltype(x)>::Result;
446 return Expr<T>{Scalar<TR>::MINEXPONENT};
447 },
448 sx->u);
449 }
450 } else if (name == "min") {
451 return FoldMINorMAX(context, std::move(funcRef), Ordering::Less);
452 } else if (name == "min0" || name == "min1") {
453 return RewriteSpecificMINorMAX(context, std::move(funcRef));
454 } else if (name == "mod") {
455 return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
456 ScalarFuncWithContext<T, T, T>(
457 [](FoldingContext &context, const Scalar<T> &x,
458 const Scalar<T> &y) -> Scalar<T> {
459 auto quotRem{x.DivideSigned(y)};
460 if (quotRem.divisionByZero) {
461 context.messages().Say("mod() by zero"_en_US);
462 } else if (quotRem.overflow) {
463 context.messages().Say("mod() folding overflowed"_en_US);
464 }
465 return quotRem.remainder;
466 }));
467 } else if (name == "modulo") {
468 return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
469 ScalarFuncWithContext<T, T, T>(
470 [](FoldingContext &context, const Scalar<T> &x,
471 const Scalar<T> &y) -> Scalar<T> {
472 auto result{x.MODULO(y)};
473 if (result.overflow) {
474 context.messages().Say("modulo() folding overflowed"_en_US);
475 }
476 return result.value;
477 }));
478 } else if (name == "precision") {
479 if (const auto *cx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
480 return Expr<T>{std::visit(
481 [](const auto &kx) {
482 return Scalar<ResultType<decltype(kx)>>::PRECISION;
483 },
484 cx->u)};
485 } else if (const auto *cx{UnwrapExpr<Expr<SomeComplex>>(args[0])}) {
486 return Expr<T>{std::visit(
487 [](const auto &kx) {
488 return Scalar<typename ResultType<decltype(kx)>::Part>::PRECISION;
489 },
490 cx->u)};
491 }
492 } else if (name == "radix") {
493 return Expr<T>{2};
494 } else if (name == "range") {
495 if (const auto *cx{UnwrapExpr<Expr<SomeInteger>>(args[0])}) {
496 return Expr<T>{std::visit(
497 [](const auto &kx) {
498 return Scalar<ResultType<decltype(kx)>>::RANGE;
499 },
500 cx->u)};
501 } else if (const auto *cx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
502 return Expr<T>{std::visit(
503 [](const auto &kx) {
504 return Scalar<ResultType<decltype(kx)>>::RANGE;
505 },
506 cx->u)};
507 } else if (const auto *cx{UnwrapExpr<Expr<SomeComplex>>(args[0])}) {
508 return Expr<T>{std::visit(
509 [](const auto &kx) {
510 return Scalar<typename ResultType<decltype(kx)>::Part>::RANGE;
511 },
512 cx->u)};
513 }
514 } else if (name == "rank") {
515 if (const auto *array{UnwrapExpr<Expr<SomeType>>(args[0])}) {
516 if (auto named{ExtractNamedEntity(*array)}) {
517 const Symbol &symbol{named->GetLastSymbol()};
518 if (semantics::IsAssumedRankArray(symbol)) {
519 // DescriptorInquiry can only be placed in expression of kind
520 // DescriptorInquiry::Result::kind.
521 return ConvertToType<T>(Expr<
522 Type<TypeCategory::Integer, DescriptorInquiry::Result::kind>>{
523 DescriptorInquiry{*named, DescriptorInquiry::Field::Rank}});
524 }
525 }
526 return Expr<T>{args[0].value().Rank()};
527 }
528 return Expr<T>{args[0].value().Rank()};
529 } else if (name == "selected_char_kind") {
530 if (const auto *chCon{UnwrapExpr<Constant<TypeOf<std::string>>>(args[0])}) {
531 if (std::optional<std::string> value{chCon->GetScalarValue()}) {
532 int defaultKind{
533 context.defaults().GetDefaultKind(TypeCategory::Character)};
534 return Expr<T>{SelectedCharKind(*value, defaultKind)};
535 }
536 }
537 } else if (name == "selected_int_kind") {
538 if (auto p{GetInt64Arg(args[0])}) {
539 return Expr<T>{SelectedIntKind(*p)};
540 }
541 } else if (name == "selected_real_kind") {
542 if (auto p{GetInt64ArgOr(args[0], 0)}) {
543 if (auto r{GetInt64ArgOr(args[1], 0)}) {
544 if (auto radix{GetInt64ArgOr(args[2], 2)}) {
545 return Expr<T>{SelectedRealKind(*p, *r, *radix)};
546 }
547 }
548 }
549 } else if (name == "shape") {
550 if (auto shape{GetShape(context, args[0])}) {
551 if (auto shapeExpr{AsExtentArrayExpr(*shape)}) {
552 return Fold(context, ConvertToType<T>(std::move(*shapeExpr)));
553 }
554 }
555 } else if (name == "sign") {
556 return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
557 ScalarFunc<T, T, T>(
558 [&context](const Scalar<T> &j, const Scalar<T> &k) -> Scalar<T> {
559 typename Scalar<T>::ValueWithOverflow result{j.SIGN(k)};
560 if (result.overflow) {
561 context.messages().Say(
562 "sign(integer(kind=%d)) folding overflowed"_en_US, KIND);
563 }
564 return result.value;
565 }));
566 } else if (name == "size") {
567 if (auto shape{GetShape(context, args[0])}) {
568 if (auto &dimArg{args[1]}) { // DIM= is present, get one extent
569 if (auto dim{GetInt64Arg(args[1])}) {
570 int rank{GetRank(*shape)};
571 if (*dim >= 1 && *dim <= rank) {
572 if (auto &extent{shape->at(*dim - 1)}) {
573 return Fold(context, ConvertToType<T>(std::move(*extent)));
574 }
575 } else {
576 context.messages().Say(
577 "size(array,dim=%jd) dimension is out of range for rank-%d array"_en_US,
578 *dim, rank);
579 }
580 }
581 } else if (auto extents{common::AllElementsPresent(std::move(*shape))}) {
582 // DIM= is absent; compute PRODUCT(SHAPE())
583 ExtentExpr product{1};
584 for (auto &&extent : std::move(*extents)) {
585 product = std::move(product) * std::move(extent);
586 }
587 return Expr<T>{ConvertToType<T>(Fold(context, std::move(product)))};
588 }
589 }
590 } else if (name == "ubound") {
591 return UBOUND(context, std::move(funcRef));
592 }
593 // TODO:
594 // cshift, dot_product, eoshift,
595 // findloc, iall, iany, iparity, ibits, image_status, ishftc,
596 // matmul, maxloc, maxval,
597 // minloc, minval, not, pack, product, reduce,
598 // sign, spread, sum, transfer, transpose, unpack
599 return Expr<T>{std::move(funcRef)};
600 }
601
602 // Substitute a bare type parameter reference with its value if it has one now
FoldOperation(FoldingContext & context,TypeParamInquiry && inquiry)603 Expr<TypeParamInquiry::Result> FoldOperation(
604 FoldingContext &context, TypeParamInquiry &&inquiry) {
605 if (!inquiry.base()) {
606 // A "bare" type parameter: replace with its value, if that's now known.
607 if (const auto *pdt{context.pdtInstance()}) {
608 if (const semantics::Scope * scope{context.pdtInstance()->scope()}) {
609 auto iter{scope->find(inquiry.parameter().name())};
610 if (iter != scope->end()) {
611 const Symbol &symbol{*iter->second};
612 const auto *details{symbol.detailsIf<semantics::TypeParamDetails>()};
613 if (details && details->init() &&
614 (details->attr() == common::TypeParamAttr::Kind ||
615 IsConstantExpr(*details->init()))) {
616 Expr<SomeInteger> expr{*details->init()};
617 return Fold(context,
618 ConvertToType<TypeParamInquiry::Result>(std::move(expr)));
619 }
620 }
621 }
622 if (const auto *value{pdt->FindParameter(inquiry.parameter().name())}) {
623 if (value->isExplicit()) {
624 return Fold(context,
625 AsExpr(ConvertToType<TypeParamInquiry::Result>(
626 Expr<SomeInteger>{value->GetExplicit().value()})));
627 }
628 }
629 }
630 }
631 return AsExpr(std::move(inquiry));
632 }
633
ToInt64(const Expr<SomeInteger> & expr)634 std::optional<std::int64_t> ToInt64(const Expr<SomeInteger> &expr) {
635 return std::visit(
636 [](const auto &kindExpr) { return ToInt64(kindExpr); }, expr.u);
637 }
638
ToInt64(const Expr<SomeType> & expr)639 std::optional<std::int64_t> ToInt64(const Expr<SomeType> &expr) {
640 if (const auto *intExpr{UnwrapExpr<Expr<SomeInteger>>(expr)}) {
641 return ToInt64(*intExpr);
642 } else {
643 return std::nullopt;
644 }
645 }
646
647 FOR_EACH_INTEGER_KIND(template class ExpressionBase, )
648 template class ExpressionBase<SomeInteger>;
649 } // namespace Fortran::evaluate
650