FLANG
fold-implementation.h
1//===-- lib/Evaluate/fold-implementation.h --------------------------------===//
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#ifndef FORTRAN_EVALUATE_FOLD_IMPLEMENTATION_H_
10#define FORTRAN_EVALUATE_FOLD_IMPLEMENTATION_H_
11
12#include "character.h"
13#include "host.h"
14#include "int-power.h"
15#include "flang/Common/indirection.h"
16#include "flang/Common/template.h"
17#include "flang/Common/unwrap.h"
18#include "flang/Evaluate/characteristics.h"
19#include "flang/Evaluate/common.h"
20#include "flang/Evaluate/constant.h"
21#include "flang/Evaluate/expression.h"
22#include "flang/Evaluate/fold.h"
23#include "flang/Evaluate/formatting.h"
24#include "flang/Evaluate/intrinsics-library.h"
25#include "flang/Evaluate/intrinsics.h"
26#include "flang/Evaluate/shape.h"
27#include "flang/Evaluate/tools.h"
28#include "flang/Evaluate/traverse.h"
29#include "flang/Evaluate/type.h"
30#include "flang/Parser/message.h"
31#include "flang/Semantics/scope.h"
32#include "flang/Semantics/symbol.h"
33#include "flang/Semantics/tools.h"
34#include <algorithm>
35#include <cmath>
36#include <complex>
37#include <cstdio>
38#include <optional>
39#include <type_traits>
40#include <variant>
41
42// Some environments, viz. glibc 2.17 and *BSD, allow the macro HUGE
43// to leak out of <math.h>.
44#undef HUGE
45
46namespace Fortran::evaluate {
47
48// Don't use Kahan extended precision summation any more when folding
49// transformational intrinsic functions other than SUM, since it is
50// not used in the runtime implementations of those functions and we
51// want results to match.
52static constexpr bool useKahanSummation{false};
53
54// Utilities
55template <typename T> class Folder {
56public:
57 explicit Folder(FoldingContext &c, bool forOptionalArgument = false)
58 : context_{c}, forOptionalArgument_{forOptionalArgument} {}
59 std::optional<Constant<T>> GetNamedConstant(const Symbol &);
60 std::optional<Constant<T>> ApplySubscripts(const Constant<T> &array,
61 const std::vector<Constant<SubscriptInteger>> &subscripts);
62 std::optional<Constant<T>> ApplyComponent(Constant<SomeDerived> &&,
63 const Symbol &component,
64 const std::vector<Constant<SubscriptInteger>> * = nullptr);
65 std::optional<Constant<T>> GetConstantComponent(
66 Component &, const std::vector<Constant<SubscriptInteger>> * = nullptr);
67 std::optional<Constant<T>> Folding(ArrayRef &);
68 std::optional<Constant<T>> Folding(DataRef &);
69 Expr<T> Folding(Designator<T> &&);
70 Constant<T> *Folding(std::optional<ActualArgument> &);
71
72 Expr<T> CSHIFT(FunctionRef<T> &&);
73 Expr<T> EOSHIFT(FunctionRef<T> &&);
74 Expr<T> MERGE(FunctionRef<T> &&);
75 Expr<T> PACK(FunctionRef<T> &&);
76 Expr<T> RESHAPE(FunctionRef<T> &&);
77 Expr<T> SPREAD(FunctionRef<T> &&);
78 Expr<T> TRANSPOSE(FunctionRef<T> &&);
79 Expr<T> UNPACK(FunctionRef<T> &&);
80
81 Expr<T> TRANSFER(FunctionRef<T> &&);
82
83private:
84 FoldingContext &context_;
85 bool forOptionalArgument_{false};
86};
87
88std::optional<Constant<SubscriptInteger>> GetConstantSubscript(
89 FoldingContext &, Subscript &, const NamedEntity &, int dim);
90
91// Helper to use host runtime on scalars for folding.
92template <typename TR, typename... TA>
93std::optional<std::function<Scalar<TR>(FoldingContext &, Scalar<TA>...)>>
94GetHostRuntimeWrapper(const std::string &name) {
95 std::vector<DynamicType> argTypes{TA{}.GetType()...};
96 if (auto hostWrapper{GetHostRuntimeWrapper(name, TR{}.GetType(), argTypes)}) {
97 return [hostWrapper](
98 FoldingContext &context, Scalar<TA>... args) -> Scalar<TR> {
99 std::vector<Expr<SomeType>> genericArgs{
100 AsGenericExpr(Constant<TA>{args})...};
101 return GetScalarConstantValue<TR>(
102 (*hostWrapper)(context, std::move(genericArgs)))
103 .value();
104 };
105 }
106 return std::nullopt;
107}
108
109// FoldOperation() rewrites expression tree nodes.
110// If there is any possibility that the rewritten node will
111// not have the same representation type, the result of
112// FoldOperation() will be packaged in an Expr<> of the same
113// specific type.
114
115// no-op base case
116template <typename A>
117common::IfNoLvalue<Expr<ResultType<A>>, A> FoldOperation(
118 FoldingContext &, A &&x) {
119 static_assert(!std::is_same_v<A, Expr<ResultType<A>>>,
120 "call Fold() instead for Expr<>");
121 return Expr<ResultType<A>>{std::move(x)};
122}
123
124Component FoldOperation(FoldingContext &, Component &&);
125NamedEntity FoldOperation(FoldingContext &, NamedEntity &&);
126Triplet FoldOperation(FoldingContext &, Triplet &&);
127Subscript FoldOperation(FoldingContext &, Subscript &&);
128ArrayRef FoldOperation(FoldingContext &, ArrayRef &&);
129CoarrayRef FoldOperation(FoldingContext &, CoarrayRef &&);
130DataRef FoldOperation(FoldingContext &, DataRef &&);
131Substring FoldOperation(FoldingContext &, Substring &&);
132ComplexPart FoldOperation(FoldingContext &, ComplexPart &&);
133template <typename T>
134Expr<T> FoldOperation(FoldingContext &, FunctionRef<T> &&);
135template <typename T>
136Expr<T> FoldOperation(FoldingContext &context, Designator<T> &&designator) {
137 return Folder<T>{context}.Folding(std::move(designator));
138}
139Expr<TypeParamInquiry::Result> FoldOperation(
140 FoldingContext &, TypeParamInquiry &&);
141Expr<ImpliedDoIndex::Result> FoldOperation(
142 FoldingContext &context, ImpliedDoIndex &&);
143template <typename T>
144Expr<T> FoldOperation(FoldingContext &, ArrayConstructor<T> &&);
145Expr<SomeDerived> FoldOperation(FoldingContext &, StructureConstructor &&);
146
147template <typename T>
148std::optional<Constant<T>> Folder<T>::GetNamedConstant(const Symbol &symbol0) {
149 const Symbol &symbol{ResolveAssociations(symbol0)};
150 if (IsNamedConstant(symbol)) {
151 if (const auto *object{
152 symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
153 if (const auto *constant{UnwrapConstantValue<T>(object->init())}) {
154 return *constant;
155 }
156 }
157 }
158 return std::nullopt;
159}
160
161template <typename T>
162std::optional<Constant<T>> Folder<T>::Folding(ArrayRef &aRef) {
163 std::vector<Constant<SubscriptInteger>> subscripts;
164 int dim{0};
165 for (Subscript &ss : aRef.subscript()) {
166 if (auto constant{GetConstantSubscript(context_, ss, aRef.base(), dim++)}) {
167 subscripts.emplace_back(std::move(*constant));
168 } else {
169 return std::nullopt;
170 }
171 }
172 if (Component * component{aRef.base().UnwrapComponent()}) {
173 return GetConstantComponent(*component, &subscripts);
174 } else if (std::optional<Constant<T>> array{
175 GetNamedConstant(aRef.base().GetLastSymbol())}) {
176 return ApplySubscripts(*array, subscripts);
177 } else {
178 return std::nullopt;
179 }
180}
181
182template <typename T>
183std::optional<Constant<T>> Folder<T>::Folding(DataRef &ref) {
184 return common::visit(
185 common::visitors{
186 [this](SymbolRef &sym) { return GetNamedConstant(*sym); },
187 [this](Component &comp) {
188 comp = FoldOperation(context_, std::move(comp));
189 return GetConstantComponent(comp);
190 },
191 [this](ArrayRef &aRef) {
192 aRef = FoldOperation(context_, std::move(aRef));
193 return Folding(aRef);
194 },
195 [](CoarrayRef &) { return std::optional<Constant<T>>{}; },
196 },
197 ref.u);
198}
199
200// TODO: This would be more natural as a member function of Constant<T>.
201template <typename T>
202std::optional<Constant<T>> Folder<T>::ApplySubscripts(const Constant<T> &array,
203 const std::vector<Constant<SubscriptInteger>> &subscripts) {
204 const auto &shape{array.shape()};
205 const auto &lbounds{array.lbounds()};
206 int rank{GetRank(shape)};
207 CHECK(rank == static_cast<int>(subscripts.size()));
208 std::size_t elements{1};
209 ConstantSubscripts resultShape;
210 ConstantSubscripts ssLB;
211 for (const auto &ss : subscripts) {
212 if (ss.Rank() == 1) {
213 resultShape.push_back(static_cast<ConstantSubscript>(ss.size()));
214 elements *= ss.size();
215 ssLB.push_back(ss.lbounds().front());
216 } else if (ss.Rank() > 1) {
217 return std::nullopt; // error recovery
218 }
219 }
220 ConstantSubscripts ssAt(rank, 0), at(rank, 0), tmp(1, 0);
221 std::vector<Scalar<T>> values;
222 while (elements-- > 0) {
223 bool increment{true};
224 int k{0};
225 for (int j{0}; j < rank; ++j) {
226 if (subscripts[j].Rank() == 0) {
227 at[j] = subscripts[j].GetScalarValue().value().ToInt64();
228 } else {
229 CHECK(k < GetRank(resultShape));
230 tmp[0] = ssLB.at(k) + ssAt.at(k);
231 at[j] = subscripts[j].At(tmp).ToInt64();
232 if (increment) {
233 if (++ssAt[k] == resultShape[k]) {
234 ssAt[k] = 0;
235 } else {
236 increment = false;
237 }
238 }
239 ++k;
240 }
241 if (at[j] < lbounds[j] || at[j] >= lbounds[j] + shape[j]) {
242 context_.messages().Say(
243 "Subscript value (%jd) is out of range on dimension %d in reference to a constant array value"_err_en_US,
244 at[j], j + 1);
245 return std::nullopt;
246 }
247 }
248 values.emplace_back(array.At(at));
249 CHECK(!increment || elements == 0);
250 CHECK(k == GetRank(resultShape));
251 }
252 if constexpr (T::category == TypeCategory::Character) {
253 return Constant<T>{array.LEN(), std::move(values), std::move(resultShape)};
254 } else if constexpr (std::is_same_v<T, SomeDerived>) {
255 return Constant<T>{array.result().derivedTypeSpec(), std::move(values),
256 std::move(resultShape)};
257 } else {
258 return Constant<T>{std::move(values), std::move(resultShape)};
259 }
260}
261
262template <typename T>
263std::optional<Constant<T>> Folder<T>::ApplyComponent(
264 Constant<SomeDerived> &&structures, const Symbol &component,
265 const std::vector<Constant<SubscriptInteger>> *subscripts) {
266 if (auto scalar{structures.GetScalarValue()}) {
267 if (std::optional<Expr<SomeType>> expr{scalar->Find(component)}) {
268 if (const Constant<T> *value{UnwrapConstantValue<T>(*expr)}) {
269 if (subscripts) {
270 return ApplySubscripts(*value, *subscripts);
271 } else {
272 return *value;
273 }
274 }
275 }
276 } else {
277 // A(:)%scalar_component & A(:)%array_component(subscripts)
278 std::unique_ptr<ArrayConstructor<T>> array;
279 if (structures.empty()) {
280 return std::nullopt;
281 }
282 ConstantSubscripts at{structures.lbounds()};
283 do {
284 StructureConstructor scalar{structures.At(at)};
285 if (std::optional<Expr<SomeType>> expr{scalar.Find(component)}) {
286 if (const Constant<T> *value{UnwrapConstantValue<T>(expr.value())}) {
287 if (!array.get()) {
288 // This technique ensures that character length or derived type
289 // information is propagated to the array constructor.
290 auto *typedExpr{UnwrapExpr<Expr<T>>(expr.value())};
291 CHECK(typedExpr);
292 array = std::make_unique<ArrayConstructor<T>>(*typedExpr);
293 if constexpr (T::category == TypeCategory::Character) {
294 array->set_LEN(Expr<SubscriptInteger>{value->LEN()});
295 }
296 }
297 if (subscripts) {
298 if (auto element{ApplySubscripts(*value, *subscripts)}) {
299 CHECK(element->Rank() == 0);
300 array->Push(Expr<T>{std::move(*element)});
301 } else {
302 return std::nullopt;
303 }
304 } else {
305 CHECK(value->Rank() == 0);
306 array->Push(Expr<T>{*value});
307 }
308 } else {
309 return std::nullopt;
310 }
311 }
312 } while (structures.IncrementSubscripts(at));
313 // Fold the ArrayConstructor<> into a Constant<>.
314 CHECK(array);
315 Expr<T> result{Fold(context_, Expr<T>{std::move(*array)})};
316 if (auto *constant{UnwrapConstantValue<T>(result)}) {
317 return constant->Reshape(common::Clone(structures.shape()));
318 }
319 }
320 return std::nullopt;
321}
322
323template <typename T>
324std::optional<Constant<T>> Folder<T>::GetConstantComponent(Component &component,
325 const std::vector<Constant<SubscriptInteger>> *subscripts) {
326 if (std::optional<Constant<SomeDerived>> structures{common::visit(
327 common::visitors{
328 [&](const Symbol &symbol) {
329 return Folder<SomeDerived>{context_}.GetNamedConstant(symbol);
330 },
331 [&](ArrayRef &aRef) {
332 return Folder<SomeDerived>{context_}.Folding(aRef);
333 },
334 [&](Component &base) {
335 return Folder<SomeDerived>{context_}.GetConstantComponent(base);
336 },
337 [&](CoarrayRef &) {
338 return std::optional<Constant<SomeDerived>>{};
339 },
340 },
341 component.base().u)}) {
342 return ApplyComponent(
343 std::move(*structures), component.GetLastSymbol(), subscripts);
344 } else {
345 return std::nullopt;
346 }
347}
348
349template <typename T> Expr<T> Folder<T>::Folding(Designator<T> &&designator) {
350 if constexpr (T::category == TypeCategory::Character) {
351 if (auto *substring{common::Unwrap<Substring>(designator.u)}) {
352 if (std::optional<Expr<SomeCharacter>> folded{
353 substring->Fold(context_)}) {
354 if (const auto *specific{std::get_if<Expr<T>>(&folded->u)}) {
355 return std::move(*specific);
356 }
357 }
358 // We used to fold zero-length substrings into zero-length
359 // constants here, but that led to problems in variable
360 // definition contexts.
361 }
362 } else if constexpr (T::category == TypeCategory::Real) {
363 if (auto *zPart{std::get_if<ComplexPart>(&designator.u)}) {
364 *zPart = FoldOperation(context_, std::move(*zPart));
365 using ComplexT = Type<TypeCategory::Complex, T::kind>;
366 if (auto zConst{Folder<ComplexT>{context_}.Folding(zPart->complex())}) {
367 return Fold(context_,
368 Expr<T>{ComplexComponent<T::kind>{
369 zPart->part() == ComplexPart::Part::IM,
370 Expr<ComplexT>{std::move(*zConst)}}});
371 } else {
372 return Expr<T>{Designator<T>{std::move(*zPart)}};
373 }
374 }
375 }
376 return common::visit(
377 common::visitors{
378 [&](SymbolRef &&symbol) {
379 if (auto constant{GetNamedConstant(*symbol)}) {
380 return Expr<T>{std::move(*constant)};
381 }
382 return Expr<T>{std::move(designator)};
383 },
384 [&](ArrayRef &&aRef) {
385 aRef = FoldOperation(context_, std::move(aRef));
386 if (auto c{Folding(aRef)}) {
387 return Expr<T>{std::move(*c)};
388 } else {
389 return Expr<T>{Designator<T>{std::move(aRef)}};
390 }
391 },
392 [&](Component &&component) {
393 component = FoldOperation(context_, std::move(component));
394 if (auto c{GetConstantComponent(component)}) {
395 return Expr<T>{std::move(*c)};
396 } else {
397 return Expr<T>{Designator<T>{std::move(component)}};
398 }
399 },
400 [&](auto &&x) {
401 return Expr<T>{
402 Designator<T>{FoldOperation(context_, std::move(x))}};
403 },
404 },
405 std::move(designator.u));
406}
407
408// Apply type conversion and re-folding if necessary.
409// This is where BOZ arguments are converted.
410template <typename T>
411Constant<T> *Folder<T>::Folding(std::optional<ActualArgument> &arg) {
412 if (auto *expr{UnwrapExpr<Expr<SomeType>>(arg)}) {
413 *expr = Fold(context_, std::move(*expr));
414 if constexpr (T::category != TypeCategory::Derived) {
415 if (!UnwrapExpr<Expr<T>>(*expr)) {
416 if (const Symbol *
417 var{forOptionalArgument_
418 ? UnwrapWholeSymbolOrComponentDataRef(*expr)
419 : nullptr};
420 var && (IsOptional(*var) || IsAllocatableOrObjectPointer(var))) {
421 // can't safely convert item that may not be present
422 } else if (auto converted{
423 ConvertToType(T::GetType(), std::move(*expr))}) {
424 *expr = Fold(context_, std::move(*converted));
425 }
426 }
427 }
428 return UnwrapConstantValue<T>(*expr);
429 }
430 return nullptr;
431}
432
433template <typename... A, std::size_t... I>
434std::optional<std::tuple<const Constant<A> *...>> GetConstantArgumentsHelper(
435 FoldingContext &context, ActualArguments &arguments,
436 bool hasOptionalArgument, std::index_sequence<I...>) {
437 static_assert(sizeof...(A) > 0);
438 std::tuple<const Constant<A> *...> args{
439 Folder<A>{context, hasOptionalArgument}.Folding(arguments.at(I))...};
440 if ((... && (std::get<I>(args)))) {
441 return args;
442 } else {
443 return std::nullopt;
444 }
445}
446
447template <typename... A>
448std::optional<std::tuple<const Constant<A> *...>> GetConstantArguments(
449 FoldingContext &context, ActualArguments &args, bool hasOptionalArgument) {
450 return GetConstantArgumentsHelper<A...>(
451 context, args, hasOptionalArgument, std::index_sequence_for<A...>{});
452}
453
454template <typename... A, std::size_t... I>
455std::optional<std::tuple<Scalar<A>...>> GetScalarConstantArgumentsHelper(
456 FoldingContext &context, ActualArguments &args, bool hasOptionalArgument,
457 std::index_sequence<I...>) {
458 if (auto constArgs{
459 GetConstantArguments<A...>(context, args, hasOptionalArgument)}) {
460 return std::tuple<Scalar<A>...>{
461 std::get<I>(*constArgs)->GetScalarValue().value()...};
462 } else {
463 return std::nullopt;
464 }
465}
466
467template <typename... A>
468std::optional<std::tuple<Scalar<A>...>> GetScalarConstantArguments(
469 FoldingContext &context, ActualArguments &args, bool hasOptionalArgument) {
470 return GetScalarConstantArgumentsHelper<A...>(
471 context, args, hasOptionalArgument, std::index_sequence_for<A...>{});
472}
473
474// helpers to fold intrinsic function references
475// Define callable types used in a common utility that
476// takes care of array and cast/conversion aspects for elemental intrinsics
477
478template <typename TR, typename... TArgs>
479using ScalarFunc = std::function<Scalar<TR>(const Scalar<TArgs> &...)>;
480template <typename TR, typename... TArgs>
481using ScalarFuncWithContext =
482 std::function<Scalar<TR>(FoldingContext &, const Scalar<TArgs> &...)>;
483
484template <template <typename, typename...> typename WrapperType, typename TR,
485 typename... TA, std::size_t... I>
486Expr<TR> FoldElementalIntrinsicHelper(FoldingContext &context,
487 FunctionRef<TR> &&funcRef, WrapperType<TR, TA...> func,
488 bool hasOptionalArgument, std::index_sequence<I...>) {
489 if (std::optional<std::tuple<const Constant<TA> *...>> args{
490 GetConstantArguments<TA...>(
491 context, funcRef.arguments(), hasOptionalArgument)}) {
492 // Compute the shape of the result based on shapes of arguments
493 ConstantSubscripts shape;
494 int rank{0};
495 const ConstantSubscripts *shapes[]{&std::get<I>(*args)->shape()...};
496 const int ranks[]{std::get<I>(*args)->Rank()...};
497 for (unsigned int i{0}; i < sizeof...(TA); ++i) {
498 if (ranks[i] > 0) {
499 if (rank == 0) {
500 rank = ranks[i];
501 shape = *shapes[i];
502 } else {
503 if (shape != *shapes[i]) {
504 // TODO: Rank compatibility was already checked but it seems to be
505 // the first place where the actual shapes are checked to be the
506 // same. Shouldn't this be checked elsewhere so that this is also
507 // checked for non constexpr call to elemental intrinsics function?
508 context.messages().Say(
509 "Arguments in elemental intrinsic function are not conformable"_err_en_US);
510 return Expr<TR>{std::move(funcRef)};
511 }
512 }
513 }
514 }
515 CHECK(rank == GetRank(shape));
516 // Compute all the scalar values of the results
517 std::vector<Scalar<TR>> results;
518 std::optional<uint64_t> n{TotalElementCount(shape)};
519 if (!n) {
520 context.messages().Say(
521 "Too many elements in elemental intrinsic function result"_err_en_US);
522 return Expr<TR>{std::move(funcRef)};
523 }
524 if (*n > 0) {
525 ConstantBounds bounds{shape};
526 ConstantSubscripts resultIndex(rank, 1);
527 ConstantSubscripts argIndex[]{std::get<I>(*args)->lbounds()...};
528 do {
529 if constexpr (std::is_same_v<WrapperType<TR, TA...>,
530 ScalarFuncWithContext<TR, TA...>>) {
531 results.emplace_back(
532 func(context, std::get<I>(*args)->At(argIndex[I])...));
533 } else if constexpr (std::is_same_v<WrapperType<TR, TA...>,
534 ScalarFunc<TR, TA...>>) {
535 results.emplace_back(func(std::get<I>(*args)->At(argIndex[I])...));
536 }
537 (std::get<I>(*args)->IncrementSubscripts(argIndex[I]), ...);
538 } while (bounds.IncrementSubscripts(resultIndex));
539 }
540 // Build and return constant result
541 if constexpr (TR::category == TypeCategory::Character) {
542 auto len{static_cast<ConstantSubscript>(
543 results.empty() ? 0 : results[0].length())};
544 return Expr<TR>{Constant<TR>{len, std::move(results), std::move(shape)}};
545 } else if constexpr (TR::category == TypeCategory::Derived) {
546 if (!results.empty()) {
547 return Expr<TR>{rank == 0
548 ? Constant<TR>{results.front()}
549 : Constant<TR>{results.front().derivedTypeSpec(),
550 std::move(results), std::move(shape)}};
551 }
552 } else {
553 return Expr<TR>{Constant<TR>{std::move(results), std::move(shape)}};
554 }
555 }
556 return Expr<TR>{std::move(funcRef)};
557}
558
559template <typename TR, typename... TA>
560Expr<TR> FoldElementalIntrinsic(FoldingContext &context,
561 FunctionRef<TR> &&funcRef, ScalarFunc<TR, TA...> func,
562 bool hasOptionalArgument = false) {
563 return FoldElementalIntrinsicHelper<ScalarFunc, TR, TA...>(context,
564 std::move(funcRef), func, hasOptionalArgument,
565 std::index_sequence_for<TA...>{});
566}
567template <typename TR, typename... TA>
568Expr<TR> FoldElementalIntrinsic(FoldingContext &context,
569 FunctionRef<TR> &&funcRef, ScalarFuncWithContext<TR, TA...> func,
570 bool hasOptionalArgument = false) {
571 return FoldElementalIntrinsicHelper<ScalarFuncWithContext, TR, TA...>(context,
572 std::move(funcRef), func, hasOptionalArgument,
573 std::index_sequence_for<TA...>{});
574}
575
576std::optional<std::int64_t> GetInt64ArgOr(
577 const std::optional<ActualArgument> &, std::int64_t defaultValue);
578
579template <typename A, typename B>
580std::optional<std::vector<A>> GetIntegerVector(const B &x) {
581 static_assert(std::is_integral_v<A>);
582 if (const auto *someInteger{UnwrapExpr<Expr<SomeInteger>>(x)}) {
583 return common::visit(
584 [](const auto &typedExpr) -> std::optional<std::vector<A>> {
585 using T = ResultType<decltype(typedExpr)>;
586 if (const auto *constant{UnwrapConstantValue<T>(typedExpr)}) {
587 if (constant->Rank() == 1) {
588 std::vector<A> result;
589 for (const auto &value : constant->values()) {
590 result.push_back(static_cast<A>(value.ToInt64()));
591 }
592 return result;
593 }
594 }
595 return std::nullopt;
596 },
597 someInteger->u);
598 }
599 return std::nullopt;
600}
601
602// Transform an intrinsic function reference that contains user errors
603// into an intrinsic with the same characteristic but the "invalid" name.
604// This to prevent generating warnings over and over if the expression
605// gets re-folded.
606template <typename T> Expr<T> MakeInvalidIntrinsic(FunctionRef<T> &&funcRef) {
607 SpecificIntrinsic invalid{std::get<SpecificIntrinsic>(funcRef.proc().u)};
608 invalid.name = IntrinsicProcTable::InvalidName;
609 return Expr<T>{FunctionRef<T>{ProcedureDesignator{std::move(invalid)},
610 ActualArguments{std::move(funcRef.arguments())}}};
611}
612
613template <typename T> Expr<T> Folder<T>::CSHIFT(FunctionRef<T> &&funcRef) {
614 auto args{funcRef.arguments()};
615 CHECK(args.size() == 3);
616 const auto *array{UnwrapConstantValue<T>(args[0])};
617 const auto *shiftExpr{UnwrapExpr<Expr<SomeInteger>>(args[1])};
618 auto dim{GetInt64ArgOr(args[2], 1)};
619 if (!array || !shiftExpr || !dim) {
620 return Expr<T>{std::move(funcRef)};
621 }
622 auto convertedShift{Fold(context_,
623 ConvertToType<SubscriptInteger>(Expr<SomeInteger>{*shiftExpr}))};
624 const auto *shift{UnwrapConstantValue<SubscriptInteger>(convertedShift)};
625 if (!shift) {
626 return Expr<T>{std::move(funcRef)};
627 }
628 // Arguments are constant
629 if (*dim < 1 || *dim > array->Rank()) {
630 context_.messages().Say("Invalid 'dim=' argument (%jd) in CSHIFT"_err_en_US,
631 static_cast<std::intmax_t>(*dim));
632 } else if (shift->Rank() > 0 && shift->Rank() != array->Rank() - 1) {
633 // message already emitted from intrinsic look-up
634 } else {
635 int rank{array->Rank()};
636 int zbDim{static_cast<int>(*dim) - 1};
637 bool ok{true};
638 if (shift->Rank() > 0) {
639 int k{0};
640 for (int j{0}; j < rank; ++j) {
641 if (j != zbDim) {
642 if (array->shape()[j] != shift->shape()[k]) {
643 context_.messages().Say(
644 "Invalid 'shift=' argument in CSHIFT: extent on dimension %d is %jd but must be %jd"_err_en_US,
645 k + 1, static_cast<std::intmax_t>(shift->shape()[k]),
646 static_cast<std::intmax_t>(array->shape()[j]));
647 ok = false;
648 }
649 ++k;
650 }
651 }
652 }
653 if (ok) {
654 std::vector<Scalar<T>> resultElements;
655 ConstantSubscripts arrayLB{array->lbounds()};
656 ConstantSubscripts arrayAt{arrayLB};
657 ConstantSubscript &dimIndex{arrayAt[zbDim]};
658 ConstantSubscript dimLB{dimIndex}; // initial value
659 ConstantSubscript dimExtent{array->shape()[zbDim]};
660 ConstantSubscripts shiftLB{shift->lbounds()};
661 for (auto n{GetSize(array->shape())}; n > 0; --n) {
662 ConstantSubscript origDimIndex{dimIndex};
663 ConstantSubscripts shiftAt;
664 if (shift->Rank() > 0) {
665 int k{0};
666 for (int j{0}; j < rank; ++j) {
667 if (j != zbDim) {
668 shiftAt.emplace_back(shiftLB[k++] + arrayAt[j] - arrayLB[j]);
669 }
670 }
671 }
672 ConstantSubscript shiftCount{shift->At(shiftAt).ToInt64()};
673 dimIndex = dimLB + ((dimIndex - dimLB + shiftCount) % dimExtent);
674 if (dimIndex < dimLB) {
675 dimIndex += dimExtent;
676 } else if (dimIndex >= dimLB + dimExtent) {
677 dimIndex -= dimExtent;
678 }
679 resultElements.push_back(array->At(arrayAt));
680 dimIndex = origDimIndex;
681 array->IncrementSubscripts(arrayAt);
682 }
683 return Expr<T>{PackageConstant<T>(
684 std::move(resultElements), *array, array->shape())};
685 }
686 }
687 // Invalid, prevent re-folding
688 return MakeInvalidIntrinsic(std::move(funcRef));
689}
690
691template <typename T> Expr<T> Folder<T>::EOSHIFT(FunctionRef<T> &&funcRef) {
692 auto args{funcRef.arguments()};
693 CHECK(args.size() == 4);
694 const auto *array{UnwrapConstantValue<T>(args[0])};
695 const auto *shiftExpr{UnwrapExpr<Expr<SomeInteger>>(args[1])};
696 auto dim{GetInt64ArgOr(args[3], 1)};
697 if (!array || !shiftExpr || !dim) {
698 return Expr<T>{std::move(funcRef)};
699 }
700 // Apply type conversions to the shift= and boundary= arguments.
701 auto convertedShift{Fold(context_,
702 ConvertToType<SubscriptInteger>(Expr<SomeInteger>{*shiftExpr}))};
703 const auto *shift{UnwrapConstantValue<SubscriptInteger>(convertedShift)};
704 if (!shift) {
705 return Expr<T>{std::move(funcRef)};
706 }
707 const Constant<T> *boundary{nullptr};
708 std::optional<Expr<SomeType>> convertedBoundary;
709 if (const auto *boundaryExpr{UnwrapExpr<Expr<SomeType>>(args[2])}) {
710 convertedBoundary = Fold(context_,
711 ConvertToType(array->GetType(), Expr<SomeType>{*boundaryExpr}));
712 boundary = UnwrapExpr<Constant<T>>(convertedBoundary);
713 if (!boundary) {
714 return Expr<T>{std::move(funcRef)};
715 }
716 }
717 // Arguments are constant
718 if (*dim < 1 || *dim > array->Rank()) {
719 context_.messages().Say(
720 "Invalid 'dim=' argument (%jd) in EOSHIFT"_err_en_US,
721 static_cast<std::intmax_t>(*dim));
722 } else if (shift->Rank() > 0 && shift->Rank() != array->Rank() - 1) {
723 // message already emitted from intrinsic look-up
724 } else if (boundary && boundary->Rank() > 0 &&
725 boundary->Rank() != array->Rank() - 1) {
726 // ditto
727 } else {
728 int rank{array->Rank()};
729 int zbDim{static_cast<int>(*dim) - 1};
730 bool ok{true};
731 if (shift->Rank() > 0) {
732 int k{0};
733 for (int j{0}; j < rank; ++j) {
734 if (j != zbDim) {
735 if (array->shape()[j] != shift->shape()[k]) {
736 context_.messages().Say(
737 "Invalid 'shift=' argument in EOSHIFT: extent on dimension %d is %jd but must be %jd"_err_en_US,
738 k + 1, static_cast<std::intmax_t>(shift->shape()[k]),
739 static_cast<std::intmax_t>(array->shape()[j]));
740 ok = false;
741 }
742 ++k;
743 }
744 }
745 }
746 if (boundary && boundary->Rank() > 0) {
747 int k{0};
748 for (int j{0}; j < rank; ++j) {
749 if (j != zbDim) {
750 if (array->shape()[j] != boundary->shape()[k]) {
751 context_.messages().Say(
752 "Invalid 'boundary=' argument in EOSHIFT: extent on dimension %d is %jd but must be %jd"_err_en_US,
753 k + 1, static_cast<std::intmax_t>(boundary->shape()[k]),
754 static_cast<std::intmax_t>(array->shape()[j]));
755 ok = false;
756 }
757 ++k;
758 }
759 }
760 }
761 if (ok) {
762 std::vector<Scalar<T>> resultElements;
763 ConstantSubscripts arrayLB{array->lbounds()};
764 ConstantSubscripts arrayAt{arrayLB};
765 ConstantSubscript &dimIndex{arrayAt[zbDim]};
766 ConstantSubscript dimLB{dimIndex}; // initial value
767 ConstantSubscript dimExtent{array->shape()[zbDim]};
768 ConstantSubscripts shiftLB{shift->lbounds()};
769 ConstantSubscripts boundaryLB;
770 if (boundary) {
771 boundaryLB = boundary->lbounds();
772 }
773 for (auto n{GetSize(array->shape())}; n > 0; --n) {
774 ConstantSubscript origDimIndex{dimIndex};
775 ConstantSubscripts shiftAt;
776 if (shift->Rank() > 0) {
777 int k{0};
778 for (int j{0}; j < rank; ++j) {
779 if (j != zbDim) {
780 shiftAt.emplace_back(shiftLB[k++] + arrayAt[j] - arrayLB[j]);
781 }
782 }
783 }
784 ConstantSubscript shiftCount{shift->At(shiftAt).ToInt64()};
785 dimIndex += shiftCount;
786 if (dimIndex >= dimLB && dimIndex < dimLB + dimExtent) {
787 resultElements.push_back(array->At(arrayAt));
788 } else if (boundary) {
789 ConstantSubscripts boundaryAt;
790 if (boundary->Rank() > 0) {
791 for (int j{0}; j < rank; ++j) {
792 int k{0};
793 if (j != zbDim) {
794 boundaryAt.emplace_back(
795 boundaryLB[k++] + arrayAt[j] - arrayLB[j]);
796 }
797 }
798 }
799 resultElements.push_back(boundary->At(boundaryAt));
800 } else if constexpr (T::category == TypeCategory::Integer ||
801 T::category == TypeCategory::Unsigned ||
802 T::category == TypeCategory::Real ||
803 T::category == TypeCategory::Complex ||
804 T::category == TypeCategory::Logical) {
805 resultElements.emplace_back();
806 } else if constexpr (T::category == TypeCategory::Character) {
807 auto len{static_cast<std::size_t>(array->LEN())};
808 typename Scalar<T>::value_type space{' '};
809 resultElements.emplace_back(len, space);
810 } else {
811 DIE("no derived type boundary");
812 }
813 dimIndex = origDimIndex;
814 array->IncrementSubscripts(arrayAt);
815 }
816 return Expr<T>{PackageConstant<T>(
817 std::move(resultElements), *array, array->shape())};
818 }
819 }
820 // Invalid, prevent re-folding
821 return MakeInvalidIntrinsic(std::move(funcRef));
822}
823
824template <typename T> Expr<T> Folder<T>::MERGE(FunctionRef<T> &&funcRef) {
825 return FoldElementalIntrinsic<T, T, T, LogicalResult>(context_,
826 std::move(funcRef),
827 ScalarFunc<T, T, T, LogicalResult>(
828 [](const Scalar<T> &ifTrue, const Scalar<T> &ifFalse,
829 const Scalar<LogicalResult> &predicate) -> Scalar<T> {
830 return predicate.IsTrue() ? ifTrue : ifFalse;
831 }));
832}
833
834template <typename T> Expr<T> Folder<T>::PACK(FunctionRef<T> &&funcRef) {
835 auto args{funcRef.arguments()};
836 CHECK(args.size() == 3);
837 const auto *array{UnwrapConstantValue<T>(args[0])};
838 const auto *vector{UnwrapConstantValue<T>(args[2])};
839 auto convertedMask{Fold(context_,
840 ConvertToType<LogicalResult>(
841 Expr<SomeLogical>{DEREF(UnwrapExpr<Expr<SomeLogical>>(args[1]))}))};
842 const auto *mask{UnwrapConstantValue<LogicalResult>(convertedMask)};
843 if (!array || !mask || (args[2] && !vector)) {
844 return Expr<T>{std::move(funcRef)};
845 }
846 // Arguments are constant.
847 ConstantSubscript arrayElements{GetSize(array->shape())};
848 ConstantSubscript truths{0};
849 ConstantSubscripts maskAt{mask->lbounds()};
850 if (mask->Rank() == 0) {
851 if (mask->At(maskAt).IsTrue()) {
852 truths = arrayElements;
853 }
854 } else if (array->shape() != mask->shape()) {
855 // Error already emitted from intrinsic processing
856 return MakeInvalidIntrinsic(std::move(funcRef));
857 } else {
858 for (ConstantSubscript j{0}; j < arrayElements;
859 ++j, mask->IncrementSubscripts(maskAt)) {
860 if (mask->At(maskAt).IsTrue()) {
861 ++truths;
862 }
863 }
864 }
865 std::vector<Scalar<T>> resultElements;
866 ConstantSubscripts arrayAt{array->lbounds()};
867 ConstantSubscript resultSize{truths};
868 if (vector) {
869 resultSize = vector->shape().at(0);
870 if (resultSize < truths) {
871 context_.messages().Say(
872 "Invalid 'vector=' argument in PACK: the 'mask=' argument has %jd true elements, but the vector has only %jd elements"_err_en_US,
873 static_cast<std::intmax_t>(truths),
874 static_cast<std::intmax_t>(resultSize));
875 return MakeInvalidIntrinsic(std::move(funcRef));
876 }
877 }
878 for (ConstantSubscript j{0}; j < truths;) {
879 if (mask->At(maskAt).IsTrue()) {
880 resultElements.push_back(array->At(arrayAt));
881 ++j;
882 }
883 array->IncrementSubscripts(arrayAt);
884 mask->IncrementSubscripts(maskAt);
885 }
886 if (vector) {
887 ConstantSubscripts vectorAt{vector->lbounds()};
888 vectorAt.at(0) += truths;
889 for (ConstantSubscript j{truths}; j < resultSize; ++j) {
890 resultElements.push_back(vector->At(vectorAt));
891 ++vectorAt[0];
892 }
893 }
894 return Expr<T>{PackageConstant<T>(std::move(resultElements), *array,
895 ConstantSubscripts{static_cast<ConstantSubscript>(resultSize)})};
896}
897
898template <typename T> Expr<T> Folder<T>::RESHAPE(FunctionRef<T> &&funcRef) {
899 auto args{funcRef.arguments()};
900 CHECK(args.size() == 4);
901 const auto *source{UnwrapConstantValue<T>(args[0])};
902 const auto *pad{UnwrapConstantValue<T>(args[2])};
903 std::optional<std::vector<ConstantSubscript>> shape{
904 GetIntegerVector<ConstantSubscript>(args[1])};
905 std::optional<std::vector<int>> order{GetIntegerVector<int>(args[3])};
906 std::optional<uint64_t> optResultElement;
907 std::optional<std::vector<int>> dimOrder;
908 bool ok{true};
909 if (shape) {
910 if (shape->size() > common::maxRank) {
911 context_.messages().Say(
912 "Size of 'shape=' argument (%zd) must not be greater than %d"_err_en_US,
913 shape->size(), common::maxRank);
914 ok = false;
915 } else if (HasNegativeExtent(*shape)) {
916 context_.messages().Say(
917 "'shape=' argument (%s) must not have a negative extent"_err_en_US,
918 DEREF(args[1]->UnwrapExpr()).AsFortran());
919 ok = false;
920 } else {
921 optResultElement = TotalElementCount(*shape);
922 if (!optResultElement) {
923 context_.messages().Say(
924 "'shape=' argument (%s) specifies an array with too many elements"_err_en_US,
925 DEREF(args[1]->UnwrapExpr()).AsFortran());
926 ok = false;
927 }
928 }
929 if (order) {
930 dimOrder = ValidateDimensionOrder(GetRank(*shape), *order);
931 if (!dimOrder) {
932 context_.messages().Say(
933 "Invalid 'order=' argument (%s) in RESHAPE"_err_en_US,
934 DEREF(args[3]->UnwrapExpr()).AsFortran());
935 ok = false;
936 }
937 }
938 }
939 if (!ok) {
940 // convert into an invalid intrinsic procedure call below
941 } else if (!source || !shape || (args[2] && !pad) || (args[3] && !order)) {
942 return Expr<T>{std::move(funcRef)}; // Non-constant arguments
943 } else {
944 uint64_t resultElements{*optResultElement};
945 std::vector<int> *dimOrderPtr{dimOrder ? &dimOrder.value() : nullptr};
946 if (resultElements > source->size() && (!pad || pad->empty())) {
947 context_.messages().Say(
948 "Too few elements in 'source=' argument and 'pad=' "
949 "argument is not present or has null size"_err_en_US);
950 ok = false;
951 } else {
952 Constant<T> result{!source->empty() || !pad
953 ? source->Reshape(std::move(shape.value()))
954 : pad->Reshape(std::move(shape.value()))};
955 ConstantSubscripts subscripts{result.lbounds()};
956 auto copied{result.CopyFrom(*source,
957 std::min(static_cast<uint64_t>(source->size()), resultElements),
958 subscripts, dimOrderPtr)};
959 if (copied < resultElements) {
960 CHECK(pad);
961 copied += result.CopyFrom(
962 *pad, resultElements - copied, subscripts, dimOrderPtr);
963 }
964 CHECK(copied == resultElements);
965 return Expr<T>{std::move(result)};
966 }
967 }
968 // Invalid, prevent re-folding
969 return MakeInvalidIntrinsic(std::move(funcRef));
970}
971
972template <typename T> Expr<T> Folder<T>::SPREAD(FunctionRef<T> &&funcRef) {
973 auto args{funcRef.arguments()};
974 CHECK(args.size() == 3);
975 const Constant<T> *source{UnwrapConstantValue<T>(args[0])};
976 auto dim{ToInt64(args[1])};
977 auto ncopies{ToInt64(args[2])};
978 if (!source || !dim) {
979 return Expr<T>{std::move(funcRef)};
980 }
981 int sourceRank{source->Rank()};
982 if (sourceRank >= common::maxRank) {
983 context_.messages().Say(
984 "SOURCE= argument to SPREAD has rank %d but must have rank less than %d"_err_en_US,
985 sourceRank, common::maxRank);
986 } else if (*dim < 1 || *dim > sourceRank + 1) {
987 context_.messages().Say(
988 "DIM=%d argument to SPREAD must be between 1 and %d"_err_en_US, *dim,
989 sourceRank + 1);
990 } else if (!ncopies) {
991 return Expr<T>{std::move(funcRef)};
992 } else {
993 if (*ncopies < 0) {
994 ncopies = 0;
995 }
996 // TODO: Consider moving this implementation (after the user error
997 // checks), along with other transformational intrinsics, into
998 // constant.h (or a new header) so that the transformationals
999 // are available for all Constant<>s without needing to be packaged
1000 // as references to intrinsic functions for folding.
1001 ConstantSubscripts shape{source->shape()};
1002 shape.insert(shape.begin() + *dim - 1, *ncopies);
1003 Constant<T> spread{source->Reshape(std::move(shape))};
1004 std::optional<uint64_t> n{TotalElementCount(spread.shape())};
1005 if (!n) {
1006 context_.messages().Say("Too many elements in SPREAD result"_err_en_US);
1007 } else {
1008 std::vector<int> dimOrder;
1009 for (int j{0}; j < sourceRank; ++j) {
1010 dimOrder.push_back(j < *dim - 1 ? j : j + 1);
1011 }
1012 dimOrder.push_back(*dim - 1);
1013 ConstantSubscripts at{spread.lbounds()}; // all 1
1014 spread.CopyFrom(*source, *n, at, &dimOrder);
1015 return Expr<T>{std::move(spread)};
1016 }
1017 }
1018 // Invalid, prevent re-folding
1019 return MakeInvalidIntrinsic(std::move(funcRef));
1020}
1021
1022template <typename T> Expr<T> Folder<T>::TRANSPOSE(FunctionRef<T> &&funcRef) {
1023 auto args{funcRef.arguments()};
1024 CHECK(args.size() == 1);
1025 const auto *matrix{UnwrapConstantValue<T>(args[0])};
1026 if (!matrix) {
1027 return Expr<T>{std::move(funcRef)};
1028 }
1029 // Argument is constant. Traverse its elements in transposed order.
1030 std::vector<Scalar<T>> resultElements;
1031 ConstantSubscripts at(2);
1032 for (ConstantSubscript j{0}; j < matrix->shape()[0]; ++j) {
1033 at[0] = matrix->lbounds()[0] + j;
1034 for (ConstantSubscript k{0}; k < matrix->shape()[1]; ++k) {
1035 at[1] = matrix->lbounds()[1] + k;
1036 resultElements.push_back(matrix->At(at));
1037 }
1038 }
1039 at = matrix->shape();
1040 std::swap(at[0], at[1]);
1041 return Expr<T>{PackageConstant<T>(std::move(resultElements), *matrix, at)};
1042}
1043
1044template <typename T> Expr<T> Folder<T>::UNPACK(FunctionRef<T> &&funcRef) {
1045 auto args{funcRef.arguments()};
1046 CHECK(args.size() == 3);
1047 const auto *vector{UnwrapConstantValue<T>(args[0])};
1048 auto convertedMask{Fold(context_,
1049 ConvertToType<LogicalResult>(
1050 Expr<SomeLogical>{DEREF(UnwrapExpr<Expr<SomeLogical>>(args[1]))}))};
1051 const auto *mask{UnwrapConstantValue<LogicalResult>(convertedMask)};
1052 const auto *field{UnwrapConstantValue<T>(args[2])};
1053 if (!vector || !mask || !field) {
1054 return Expr<T>{std::move(funcRef)};
1055 }
1056 // Arguments are constant.
1057 if (field->Rank() > 0 && field->shape() != mask->shape()) {
1058 // Error already emitted from intrinsic processing
1059 return MakeInvalidIntrinsic(std::move(funcRef));
1060 }
1061 ConstantSubscript maskElements{GetSize(mask->shape())};
1062 ConstantSubscript truths{0};
1063 ConstantSubscripts maskAt{mask->lbounds()};
1064 for (ConstantSubscript j{0}; j < maskElements;
1065 ++j, mask->IncrementSubscripts(maskAt)) {
1066 if (mask->At(maskAt).IsTrue()) {
1067 ++truths;
1068 }
1069 }
1070 if (truths > GetSize(vector->shape())) {
1071 context_.messages().Say(
1072 "Invalid 'vector=' argument in UNPACK: the 'mask=' argument has %jd true elements, but the vector has only %jd elements"_err_en_US,
1073 static_cast<std::intmax_t>(truths),
1074 static_cast<std::intmax_t>(GetSize(vector->shape())));
1075 return MakeInvalidIntrinsic(std::move(funcRef));
1076 }
1077 std::vector<Scalar<T>> resultElements;
1078 ConstantSubscripts vectorAt{vector->lbounds()};
1079 ConstantSubscripts fieldAt{field->lbounds()};
1080 for (ConstantSubscript j{0}; j < maskElements; ++j) {
1081 if (mask->At(maskAt).IsTrue()) {
1082 resultElements.push_back(vector->At(vectorAt));
1083 vector->IncrementSubscripts(vectorAt);
1084 } else {
1085 resultElements.push_back(field->At(fieldAt));
1086 }
1087 mask->IncrementSubscripts(maskAt);
1088 field->IncrementSubscripts(fieldAt);
1089 }
1090 return Expr<T>{
1091 PackageConstant<T>(std::move(resultElements), *vector, mask->shape())};
1092}
1093
1094std::optional<Expr<SomeType>> FoldTransfer(
1095 FoldingContext &, const ActualArguments &);
1096
1097template <typename T> Expr<T> Folder<T>::TRANSFER(FunctionRef<T> &&funcRef) {
1098 if (auto folded{FoldTransfer(context_, funcRef.arguments())}) {
1099 return DEREF(UnwrapExpr<Expr<T>>(*folded));
1100 } else {
1101 return Expr<T>{std::move(funcRef)};
1102 }
1103}
1104
1105// TODO: Once the backend supports character extremums we could support
1106// min/max with non-optional arguments to trees of extremum operations.
1107template <typename T>
1108Expr<T> FoldMINorMAX(
1109 FoldingContext &context, FunctionRef<T> &&funcRef, Ordering order) {
1110 static_assert(T::category == TypeCategory::Integer ||
1111 T::category == TypeCategory::Unsigned ||
1112 T::category == TypeCategory::Real ||
1113 T::category == TypeCategory::Character);
1114
1115 // Lots of constraints:
1116 // - We want Extremum<T> generated by semantics to compare equal to
1117 // Extremum<T> written out to module files as max or min calls.
1118 // - Users can also write min/max calls that must also compare equal
1119 // to min/max calls that wind up being written to module files.
1120 // - Extremeum<T> is binary and can't currently handle processing
1121 // optional arguments that may show up in 3rd + argument.
1122 // - The code below only accepts more than 2 arguments if all the
1123 // arguments are constant (and hence known to be present).
1124 // - ConvertExprToHLFIR can't currently handle Extremum<Character>
1125 // - Semantics doesn't currently generate Extremum<Character>
1126 // The original code did the folding of arguments and the overall extremum
1127 // operation in a single pass. This was shorter code-wise, but took me
1128 // a while to tease out all the logic and was doing redundant work.
1129 // So I split it into two passes:
1130 // 1) fold the arguments and check if they are constant,
1131 // 2) Decide if we:
1132 // - can constant-fold the min/max operation, or
1133 // - need to generate an extremum anyway,
1134 // and do it if so.
1135 // Otherwise, return the original call.
1136 auto &args{funcRef.arguments()};
1137 std::size_t nargs{args.size()};
1138 bool allArgsConstant{true};
1139 bool extremumAnyway{nargs == 2 && T::category != TypeCategory::Character};
1140 // 1a)Fold the first two arguments.
1141 {
1142 Folder<T> folder{context, /*forOptionalArgument=*/false};
1143 if (!folder.Folding(args[0])) {
1144 allArgsConstant = false;
1145 }
1146 if (!folder.Folding(args[1])) {
1147 allArgsConstant = false;
1148 }
1149 }
1150 // 1b) Fold any optional arguments.
1151 if (nargs > 2) {
1152 Folder<T> folder{context, /*forOptionalArgument=*/true};
1153 for (std::size_t i{2}; i < nargs; ++i) {
1154 if (args[i]) {
1155 if (!folder.Folding(args[i])) {
1156 allArgsConstant = false;
1157 }
1158 }
1159 }
1160 }
1161 // 2) If we can fold the result or the call to min/max may compare equal to
1162 // an extremum generated by semantics go ahead and convert to an extremum,
1163 // and try to fold the result.
1164 if (allArgsConstant || extremumAnyway) {
1165 // Folding updates the argument expressions in place, no need to call
1166 // Fold() on each argument again.
1167 if (const auto *resultp{UnwrapExpr<Expr<T>>(args[0])}) {
1168 Expr<T> result{*resultp};
1169 for (std::size_t i{1}; i < nargs; ++i) {
1170 if (const auto *tExpr{UnwrapExpr<Expr<T>>(args[i])}) {
1171 result = FoldOperation(
1172 context, Extremum<T>{order, std::move(result), *tExpr});
1173 } else {
1174 // This should never happen, but here is a value to return.
1175 return Expr<T>{std::move(funcRef)};
1176 }
1177 }
1178 return result;
1179 }
1180 }
1181 // If we decided to not generate an extremum just return the original call,
1182 // with the arguments folded.
1183 return Expr<T>{std::move(funcRef)};
1184}
1185
1186// For AMAX0, AMIN0, AMAX1, AMIN1, DMAX1, DMIN1, MAX0, MIN0, MAX1, and MIN1
1187// a special care has to be taken to insert the conversion on the result
1188// of the MIN/MAX. This is made slightly more complex by the extension
1189// supported by f18 that arguments may have different kinds. This implies
1190// that the created MIN/MAX result type cannot be deduced from the standard but
1191// has to be deduced from the arguments.
1192// e.g. AMAX0(int8, int4) is rewritten to REAL(MAX(int8, INT(int4, 8)))).
1193template <typename T>
1194Expr<T> RewriteSpecificMINorMAX(
1195 FoldingContext &context, FunctionRef<T> &&funcRef) {
1196 ActualArguments &args{funcRef.arguments()};
1197 auto &intrinsic{DEREF(std::get_if<SpecificIntrinsic>(&funcRef.proc().u))};
1198 // Rewrite MAX1(args) to INT(MAX(args)) and fold. Same logic for MIN1.
1199 // Find result type for max/min based on the arguments.
1200 std::optional<DynamicType> resultType;
1201 ActualArgument *resultTypeArg{nullptr};
1202 for (auto j{args.size()}; j-- > 0;) {
1203 if (args[j]) {
1204 DynamicType type{args[j]->GetType().value()};
1205 // Handle mixed real/integer arguments: all the previous arguments were
1206 // integers and this one is real. The type of the MAX/MIN result will
1207 // be the one of the real argument.
1208 if (!resultType ||
1209 (type.category() == resultType->category() &&
1210 type.kind() > resultType->kind()) ||
1211 resultType->category() == TypeCategory::Integer) {
1212 resultType = type;
1213 resultTypeArg = &*args[j];
1214 }
1215 }
1216 }
1217 if (!resultType) { // error recovery
1218 return Expr<T>{std::move(funcRef)};
1219 }
1220 intrinsic.name =
1221 intrinsic.name.find("max") != std::string::npos ? "max"s : "min"s;
1222 intrinsic.characteristics.value().functionResult.value().SetType(*resultType);
1223 auto insertConversion{[&](const auto &x) -> Expr<T> {
1224 using TR = ResultType<decltype(x)>;
1225 FunctionRef<TR> maxRef{
1226 ProcedureDesignator{funcRef.proc()}, ActualArguments{args}};
1227 return Fold(context, ConvertToType<T>(AsCategoryExpr(std::move(maxRef))));
1228 }};
1229 if (auto *sx{UnwrapExpr<Expr<SomeReal>>(*resultTypeArg)}) {
1230 return common::visit(insertConversion, sx->u);
1231 } else if (auto *sx{UnwrapExpr<Expr<SomeInteger>>(*resultTypeArg)}) {
1232 return common::visit(insertConversion, sx->u);
1233 } else {
1234 return Expr<T>{std::move(funcRef)}; // error recovery
1235 }
1236}
1237
1238// FoldIntrinsicFunction()
1239template <int KIND>
1240Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
1241 FoldingContext &context, FunctionRef<Type<TypeCategory::Integer, KIND>> &&);
1242template <int KIND>
1243Expr<Type<TypeCategory::Unsigned, KIND>> FoldIntrinsicFunction(
1244 FoldingContext &context,
1245 FunctionRef<Type<TypeCategory::Unsigned, KIND>> &&);
1246template <int KIND>
1247Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
1248 FoldingContext &context, FunctionRef<Type<TypeCategory::Real, KIND>> &&);
1249template <int KIND>
1250Expr<Type<TypeCategory::Complex, KIND>> FoldIntrinsicFunction(
1251 FoldingContext &context, FunctionRef<Type<TypeCategory::Complex, KIND>> &&);
1252template <int KIND>
1253Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
1254 FoldingContext &context, FunctionRef<Type<TypeCategory::Logical, KIND>> &&);
1255
1256template <typename T>
1257Expr<T> FoldOperation(FoldingContext &context, FunctionRef<T> &&funcRef) {
1258 ActualArguments &args{funcRef.arguments()};
1259 const auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)};
1260 if (!intrinsic || intrinsic->name != "kind") {
1261 // Don't fold the argument to KIND(); it might be a TypeParamInquiry
1262 // with a forced result type that doesn't match the parameter.
1263 for (std::optional<ActualArgument> &arg : args) {
1264 if (auto *expr{UnwrapExpr<Expr<SomeType>>(arg)}) {
1265 *expr = Fold(context, std::move(*expr));
1266 }
1267 }
1268 }
1269 if (intrinsic) {
1270 const std::string name{intrinsic->name};
1271 if (name == "cshift") {
1272 return Folder<T>{context}.CSHIFT(std::move(funcRef));
1273 } else if (name == "eoshift") {
1274 return Folder<T>{context}.EOSHIFT(std::move(funcRef));
1275 } else if (name == "merge") {
1276 return Folder<T>{context}.MERGE(std::move(funcRef));
1277 } else if (name == "pack") {
1278 return Folder<T>{context}.PACK(std::move(funcRef));
1279 } else if (name == "reshape") {
1280 return Folder<T>{context}.RESHAPE(std::move(funcRef));
1281 } else if (name == "spread") {
1282 return Folder<T>{context}.SPREAD(std::move(funcRef));
1283 } else if (name == "transfer") {
1284 return Folder<T>{context}.TRANSFER(std::move(funcRef));
1285 } else if (name == "transpose") {
1286 return Folder<T>{context}.TRANSPOSE(std::move(funcRef));
1287 } else if (name == "unpack") {
1288 return Folder<T>{context}.UNPACK(std::move(funcRef));
1289 }
1290 // TODO: extends_type_of, same_type_as
1291 if constexpr (!std::is_same_v<T, SomeDerived>) {
1292 return FoldIntrinsicFunction(context, std::move(funcRef));
1293 }
1294 }
1295 return Expr<T>{std::move(funcRef)};
1296}
1297
1298Expr<ImpliedDoIndex::Result> FoldOperation(FoldingContext &, ImpliedDoIndex &&);
1299
1300// Array constructor folding
1301template <typename T> class ArrayConstructorFolder {
1302public:
1303 explicit ArrayConstructorFolder(FoldingContext &c) : context_{c} {}
1304
1305 Expr<T> FoldArray(ArrayConstructor<T> &&array) {
1306 if constexpr (T::category == TypeCategory::Character) {
1307 if (const auto *len{array.LEN()}) {
1308 charLength_ = ToInt64(Fold(context_, common::Clone(*len)));
1309 knownCharLength_ = charLength_.has_value();
1310 }
1311 }
1312 // Calls FoldArray(const ArrayConstructorValues<T> &) below
1313 if (FoldArray(array)) {
1314 auto n{static_cast<ConstantSubscript>(elements_.size())};
1315 if constexpr (std::is_same_v<T, SomeDerived>) {
1316 return Expr<T>{Constant<T>{array.GetType().GetDerivedTypeSpec(),
1317 std::move(elements_), ConstantSubscripts{n}}};
1318 } else if constexpr (T::category == TypeCategory::Character) {
1319 if (charLength_) {
1320 return Expr<T>{Constant<T>{
1321 *charLength_, std::move(elements_), ConstantSubscripts{n}}};
1322 }
1323 } else {
1324 return Expr<T>{Constant<T>{
1325 std::move(elements_), ConstantSubscripts{n}, resultInfo_}};
1326 }
1327 }
1328 return Expr<T>{std::move(array)};
1329 }
1330
1331private:
1332 bool FoldArray(const Expr<T> &expr) {
1333 Expr<T> folded{Fold(context_, common::Clone(expr))};
1334 if (const auto *c{UnwrapConstantValue<T>(folded)}) {
1335 // Copy elements in Fortran array element order
1336 if (!c->empty()) {
1337 ConstantSubscripts index{c->lbounds()};
1338 do {
1339 elements_.emplace_back(c->At(index));
1340 } while (c->IncrementSubscripts(index));
1341 }
1342 if constexpr (T::category == TypeCategory::Character) {
1343 if (!knownCharLength_) {
1344 charLength_ = std::max(c->LEN(), charLength_.value_or(-1));
1345 }
1346 } else if constexpr (T::category == TypeCategory::Real ||
1347 T::category == TypeCategory::Complex) {
1348 if (c->result().isFromInexactLiteralConversion()) {
1349 resultInfo_.set_isFromInexactLiteralConversion();
1350 }
1351 }
1352 return true;
1353 } else {
1354 return false;
1355 }
1356 }
1357 bool FoldArray(const common::CopyableIndirection<Expr<T>> &expr) {
1358 return FoldArray(expr.value());
1359 }
1360 bool FoldArray(const ImpliedDo<T> &iDo) {
1362 Fold(context_, Expr<SubscriptInteger>{iDo.lower()})};
1364 Fold(context_, Expr<SubscriptInteger>{iDo.upper()})};
1366 Fold(context_, Expr<SubscriptInteger>{iDo.stride()})};
1367 std::optional<ConstantSubscript> start{ToInt64(lower)}, end{ToInt64(upper)},
1368 step{ToInt64(stride)};
1369 if (start && end && step && *step != 0) {
1370 bool result{true};
1371 ConstantSubscript &j{context_.StartImpliedDo(iDo.name(), *start)};
1372 if (*step > 0) {
1373 for (; j <= *end; j += *step) {
1374 result &= FoldArray(iDo.values());
1375 }
1376 } else {
1377 for (; j >= *end; j += *step) {
1378 result &= FoldArray(iDo.values());
1379 }
1380 }
1381 context_.EndImpliedDo(iDo.name());
1382 return result;
1383 } else {
1384 return false;
1385 }
1386 }
1387 bool FoldArray(const ArrayConstructorValue<T> &x) {
1388 return common::visit([&](const auto &y) { return FoldArray(y); }, x.u);
1389 }
1390 bool FoldArray(const ArrayConstructorValues<T> &xs) {
1391 for (const auto &x : xs) {
1392 if (!FoldArray(x)) {
1393 return false;
1394 }
1395 }
1396 return true;
1397 }
1398
1399 FoldingContext &context_;
1400 std::vector<Scalar<T>> elements_;
1401 std::optional<ConstantSubscript> charLength_;
1402 bool knownCharLength_{false};
1403 typename Constant<T>::Result resultInfo_;
1404};
1405
1406template <typename T>
1407Expr<T> FoldOperation(FoldingContext &context, ArrayConstructor<T> &&array) {
1408 return ArrayConstructorFolder<T>{context}.FoldArray(std::move(array));
1409}
1410
1411// Array operation elemental application: When all operands to an operation
1412// are constant arrays, array constructors without any implied DO loops,
1413// &/or expanded scalars, pull the operation "into" the array result by
1414// applying it in an elementwise fashion. For example, [A,1]+[B,2]
1415// is rewritten into [A+B,1+2] and then partially folded to [A+B,3].
1416
1417// If possible, restructures an array expression into an array constructor
1418// that comprises a "flat" ArrayConstructorValues with no implied DO loops.
1419template <typename T>
1420bool ArrayConstructorIsFlat(const ArrayConstructorValues<T> &values) {
1421 for (const ArrayConstructorValue<T> &x : values) {
1422 if (!std::holds_alternative<Expr<T>>(x.u)) {
1423 return false;
1424 }
1425 }
1426 return true;
1427}
1428
1429template <typename T>
1430std::optional<Expr<T>> AsFlatArrayConstructor(const Expr<T> &expr) {
1431 if (const auto *c{UnwrapConstantValue<T>(expr)}) {
1432 ArrayConstructor<T> result{expr};
1433 if (!c->empty()) {
1434 ConstantSubscripts at{c->lbounds()};
1435 do {
1436 result.Push(Expr<T>{Constant<T>{c->At(at)}});
1437 } while (c->IncrementSubscripts(at));
1438 }
1439 return std::make_optional<Expr<T>>(std::move(result));
1440 } else if (const auto *a{UnwrapExpr<ArrayConstructor<T>>(expr)}) {
1441 if (ArrayConstructorIsFlat(*a)) {
1442 return std::make_optional<Expr<T>>(expr);
1443 }
1444 } else if (const auto *p{UnwrapExpr<Parentheses<T>>(expr)}) {
1445 return AsFlatArrayConstructor(Expr<T>{p->left()});
1446 }
1447 return std::nullopt;
1448}
1449
1450template <TypeCategory CAT>
1451std::enable_if_t<CAT != TypeCategory::Derived,
1452 std::optional<Expr<SomeKind<CAT>>>>
1453AsFlatArrayConstructor(const Expr<SomeKind<CAT>> &expr) {
1454 return common::visit(
1455 [&](const auto &kindExpr) -> std::optional<Expr<SomeKind<CAT>>> {
1456 if (auto flattened{AsFlatArrayConstructor(kindExpr)}) {
1457 return Expr<SomeKind<CAT>>{std::move(*flattened)};
1458 } else {
1459 return std::nullopt;
1460 }
1461 },
1462 expr.u);
1463}
1464
1465// FromArrayConstructor is a subroutine for MapOperation() below.
1466// Given a flat ArrayConstructor<T> and a shape, it wraps the array
1467// into an Expr<T>, folds it, and returns the resulting wrapped
1468// array constructor or constant array value.
1469template <typename T>
1470std::optional<Expr<T>> FromArrayConstructor(
1471 FoldingContext &context, ArrayConstructor<T> &&values, const Shape &shape) {
1472 if (auto constShape{AsConstantExtents(context, shape)};
1473 constShape && !HasNegativeExtent(*constShape)) {
1474 Expr<T> result{Fold(context, Expr<T>{std::move(values)})};
1475 if (auto *constant{UnwrapConstantValue<T>(result)}) {
1476 // Elements and shape are both constant.
1477 return Expr<T>{constant->Reshape(std::move(*constShape))};
1478 }
1479 if (constShape->size() == 1) {
1480 if (auto elements{GetShape(context, result)}) {
1481 if (auto constElements{AsConstantExtents(context, *elements)}) {
1482 if (constElements->size() == 1 &&
1483 constElements->at(0) == constShape->at(0)) {
1484 // Elements are not constant, but array constructor has
1485 // the right known shape and can be simply returned as is.
1486 return std::move(result);
1487 }
1488 }
1489 }
1490 }
1491 }
1492 return std::nullopt;
1493}
1494
1495// MapOperation is a utility for various specializations of ApplyElementwise()
1496// that follow. Given one or two flat ArrayConstructor<OPERAND> (wrapped in an
1497// Expr<OPERAND>) for some specific operand type(s), apply a given function f
1498// to each of their corresponding elements to produce a flat
1499// ArrayConstructor<RESULT> (wrapped in an Expr<RESULT>).
1500// Preserves shape.
1501
1502// Unary case
1503template <typename RESULT, typename OPERAND>
1504std::optional<Expr<RESULT>> MapOperation(FoldingContext &context,
1505 std::function<Expr<RESULT>(Expr<OPERAND> &&)> &&f, const Shape &shape,
1506 [[maybe_unused]] std::optional<Expr<SubscriptInteger>> &&length,
1507 Expr<OPERAND> &&values) {
1508 ArrayConstructor<RESULT> result{values};
1509 if constexpr (common::HasMember<OPERAND, AllIntrinsicCategoryTypes>) {
1510 common::visit(
1511 [&](auto &&kindExpr) {
1512 using kindType = ResultType<decltype(kindExpr)>;
1513 auto &aConst{std::get<ArrayConstructor<kindType>>(kindExpr.u)};
1514 for (auto &acValue : aConst) {
1515 auto &scalar{std::get<Expr<kindType>>(acValue.u)};
1516 result.Push(Fold(context, f(Expr<OPERAND>{std::move(scalar)})));
1517 }
1518 },
1519 std::move(values.u));
1520 } else {
1521 auto &aConst{std::get<ArrayConstructor<OPERAND>>(values.u)};
1522 for (auto &acValue : aConst) {
1523 auto &scalar{std::get<Expr<OPERAND>>(acValue.u)};
1524 result.Push(Fold(context, f(std::move(scalar))));
1525 }
1526 }
1527 if constexpr (RESULT::category == TypeCategory::Character) {
1528 if (length) {
1529 result.set_LEN(std::move(*length));
1530 }
1531 }
1532 return FromArrayConstructor(context, std::move(result), shape);
1533}
1534
1535template <typename RESULT, typename A>
1536ArrayConstructor<RESULT> ArrayConstructorFromMold(
1537 const A &prototype, std::optional<Expr<SubscriptInteger>> &&length) {
1538 ArrayConstructor<RESULT> result{prototype};
1539 if constexpr (RESULT::category == TypeCategory::Character) {
1540 if (length) {
1541 result.set_LEN(std::move(*length));
1542 }
1543 }
1544 return result;
1545}
1546
1547template <typename LEFT, typename RIGHT>
1548bool ShapesMatch(FoldingContext &context,
1549 const ArrayConstructor<LEFT> &leftArrConst,
1550 const ArrayConstructor<RIGHT> &rightArrConst) {
1551 auto rightIter{rightArrConst.begin()};
1552 for (auto &leftValue : leftArrConst) {
1553 CHECK(rightIter != rightArrConst.end());
1554 auto &leftExpr{std::get<Expr<LEFT>>(leftValue.u)};
1555 auto &rightExpr{std::get<Expr<RIGHT>>(rightIter->u)};
1556 if (leftExpr.Rank() != rightExpr.Rank()) {
1557 return false;
1558 }
1559 std::optional<Shape> leftShape{GetShape(context, leftExpr)};
1560 std::optional<Shape> rightShape{GetShape(context, rightExpr)};
1561 if (!leftShape || !rightShape || *leftShape != *rightShape) {
1562 return false;
1563 }
1564 ++rightIter;
1565 }
1566 return true;
1567}
1568
1569// array * array case
1570template <typename RESULT, typename LEFT, typename RIGHT>
1571auto MapOperation(FoldingContext &context,
1572 std::function<Expr<RESULT>(Expr<LEFT> &&, Expr<RIGHT> &&)> &&f,
1573 const Shape &shape, std::optional<Expr<SubscriptInteger>> &&length,
1574 Expr<LEFT> &&leftValues, Expr<RIGHT> &&rightValues)
1575 -> std::optional<Expr<RESULT>> {
1576 auto result{ArrayConstructorFromMold<RESULT>(leftValues, std::move(length))};
1577 auto &leftArrConst{std::get<ArrayConstructor<LEFT>>(leftValues.u)};
1578 if constexpr (common::HasMember<RIGHT, AllIntrinsicCategoryTypes>) {
1579 bool mapped{common::visit(
1580 [&](auto &&kindExpr) -> bool {
1581 using kindType = ResultType<decltype(kindExpr)>;
1582
1583 auto &rightArrConst{std::get<ArrayConstructor<kindType>>(kindExpr.u)};
1584 if (!ShapesMatch(context, leftArrConst, rightArrConst)) {
1585 return false;
1586 }
1587 auto rightIter{rightArrConst.begin()};
1588 for (auto &leftValue : leftArrConst) {
1589 CHECK(rightIter != rightArrConst.end());
1590 auto &leftScalar{std::get<Expr<LEFT>>(leftValue.u)};
1591 auto &rightScalar{std::get<Expr<kindType>>(rightIter->u)};
1592 result.Push(Fold(context,
1593 f(std::move(leftScalar), Expr<RIGHT>{std::move(rightScalar)})));
1594 ++rightIter;
1595 }
1596 return true;
1597 },
1598 std::move(rightValues.u))};
1599 if (!mapped) {
1600 return std::nullopt;
1601 }
1602 } else {
1603 auto &rightArrConst{std::get<ArrayConstructor<RIGHT>>(rightValues.u)};
1604 if (!ShapesMatch(context, leftArrConst, rightArrConst)) {
1605 return std::nullopt;
1606 }
1607 auto rightIter{rightArrConst.begin()};
1608 for (auto &leftValue : leftArrConst) {
1609 CHECK(rightIter != rightArrConst.end());
1610 auto &leftScalar{std::get<Expr<LEFT>>(leftValue.u)};
1611 auto &rightScalar{std::get<Expr<RIGHT>>(rightIter->u)};
1612 result.Push(
1613 Fold(context, f(std::move(leftScalar), std::move(rightScalar))));
1614 ++rightIter;
1615 }
1616 }
1617 return FromArrayConstructor(context, std::move(result), shape);
1618}
1619
1620// array * scalar case
1621template <typename RESULT, typename LEFT, typename RIGHT>
1622auto MapOperation(FoldingContext &context,
1623 std::function<Expr<RESULT>(Expr<LEFT> &&, Expr<RIGHT> &&)> &&f,
1624 const Shape &shape, std::optional<Expr<SubscriptInteger>> &&length,
1625 Expr<LEFT> &&leftValues, const Expr<RIGHT> &rightScalar)
1626 -> std::optional<Expr<RESULT>> {
1627 auto result{ArrayConstructorFromMold<RESULT>(leftValues, std::move(length))};
1628 auto &leftArrConst{std::get<ArrayConstructor<LEFT>>(leftValues.u)};
1629 for (auto &leftValue : leftArrConst) {
1630 auto &leftScalar{std::get<Expr<LEFT>>(leftValue.u)};
1631 result.Push(
1632 Fold(context, f(std::move(leftScalar), Expr<RIGHT>{rightScalar})));
1633 }
1634 return FromArrayConstructor(context, std::move(result), shape);
1635}
1636
1637// scalar * array case
1638template <typename RESULT, typename LEFT, typename RIGHT>
1639auto MapOperation(FoldingContext &context,
1640 std::function<Expr<RESULT>(Expr<LEFT> &&, Expr<RIGHT> &&)> &&f,
1641 const Shape &shape, std::optional<Expr<SubscriptInteger>> &&length,
1642 const Expr<LEFT> &leftScalar, Expr<RIGHT> &&rightValues)
1643 -> std::optional<Expr<RESULT>> {
1644 auto result{ArrayConstructorFromMold<RESULT>(leftScalar, std::move(length))};
1645 if constexpr (common::HasMember<RIGHT, AllIntrinsicCategoryTypes>) {
1646 common::visit(
1647 [&](auto &&kindExpr) {
1648 using kindType = ResultType<decltype(kindExpr)>;
1649 auto &rightArrConst{std::get<ArrayConstructor<kindType>>(kindExpr.u)};
1650 for (auto &rightValue : rightArrConst) {
1651 auto &rightScalar{std::get<Expr<kindType>>(rightValue.u)};
1652 result.Push(Fold(context,
1653 f(Expr<LEFT>{leftScalar},
1654 Expr<RIGHT>{std::move(rightScalar)})));
1655 }
1656 },
1657 std::move(rightValues.u));
1658 } else {
1659 auto &rightArrConst{std::get<ArrayConstructor<RIGHT>>(rightValues.u)};
1660 for (auto &rightValue : rightArrConst) {
1661 auto &rightScalar{std::get<Expr<RIGHT>>(rightValue.u)};
1662 result.Push(
1663 Fold(context, f(Expr<LEFT>{leftScalar}, std::move(rightScalar))));
1664 }
1665 }
1666 return FromArrayConstructor(context, std::move(result), shape);
1667}
1668
1669template <typename DERIVED, typename RESULT, typename... OPD>
1670std::optional<Expr<SubscriptInteger>> ComputeResultLength(
1671 Operation<DERIVED, RESULT, OPD...> &operation) {
1672 if constexpr (RESULT::category == TypeCategory::Character) {
1673 return Expr<RESULT>{operation.derived()}.LEN();
1674 }
1675 return std::nullopt;
1676}
1677
1678// ApplyElementwise() recursively folds the operand expression(s) of an
1679// operation, then attempts to apply the operation to the (corresponding)
1680// scalar element(s) of those operands. Returns std::nullopt for scalars
1681// or unlinearizable operands.
1682template <typename DERIVED, typename RESULT, typename OPERAND>
1683auto ApplyElementwise(FoldingContext &context,
1684 Operation<DERIVED, RESULT, OPERAND> &operation,
1685 std::function<Expr<RESULT>(Expr<OPERAND> &&)> &&f)
1686 -> std::optional<Expr<RESULT>> {
1687 auto &expr{operation.left()};
1688 expr = Fold(context, std::move(expr));
1689 if (expr.Rank() > 0) {
1690 if (std::optional<Shape> shape{GetShape(context, expr)}) {
1691 if (auto values{AsFlatArrayConstructor(expr)}) {
1692 return MapOperation(context, std::move(f), *shape,
1693 ComputeResultLength(operation), std::move(*values));
1694 }
1695 }
1696 }
1697 return std::nullopt;
1698}
1699
1700template <typename DERIVED, typename RESULT, typename OPERAND>
1701auto ApplyElementwise(
1702 FoldingContext &context, Operation<DERIVED, RESULT, OPERAND> &operation)
1703 -> std::optional<Expr<RESULT>> {
1704 return ApplyElementwise(context, operation,
1705 std::function<Expr<RESULT>(Expr<OPERAND> &&)>{
1706 [](Expr<OPERAND> &&operand) {
1707 return Expr<RESULT>{DERIVED{std::move(operand)}};
1708 }});
1709}
1710
1711template <typename DERIVED, typename RESULT, typename LEFT, typename RIGHT>
1712auto ApplyElementwise(FoldingContext &context,
1713 Operation<DERIVED, RESULT, LEFT, RIGHT> &operation,
1714 std::function<Expr<RESULT>(Expr<LEFT> &&, Expr<RIGHT> &&)> &&f)
1715 -> std::optional<Expr<RESULT>> {
1716 auto resultLength{ComputeResultLength(operation)};
1717 auto &leftExpr{operation.left()};
1718 auto &rightExpr{operation.right()};
1719 if (leftExpr.Rank() != rightExpr.Rank() && leftExpr.Rank() != 0 &&
1720 rightExpr.Rank() != 0) {
1721 return std::nullopt; // error recovery
1722 }
1723 leftExpr = Fold(context, std::move(leftExpr));
1724 rightExpr = Fold(context, std::move(rightExpr));
1725 if (leftExpr.Rank() > 0) {
1726 if (std::optional<Shape> leftShape{GetShape(context, leftExpr)}) {
1727 if (auto left{AsFlatArrayConstructor(leftExpr)}) {
1728 if (rightExpr.Rank() > 0) {
1729 if (std::optional<Shape> rightShape{GetShape(context, rightExpr)}) {
1730 if (auto right{AsFlatArrayConstructor(rightExpr)}) {
1731 if (CheckConformance(context.messages(), *leftShape, *rightShape,
1732 CheckConformanceFlags::EitherScalarExpandable)
1733 .value_or(false /*fail if not known now to conform*/)) {
1734 return MapOperation(context, std::move(f), *leftShape,
1735 std::move(resultLength), std::move(*left),
1736 std::move(*right));
1737 } else {
1738 return std::nullopt;
1739 }
1740 return MapOperation(context, std::move(f), *leftShape,
1741 std::move(resultLength), std::move(*left), std::move(*right));
1742 }
1743 }
1744 } else if (IsExpandableScalar(rightExpr, context, *leftShape)) {
1745 return MapOperation(context, std::move(f), *leftShape,
1746 std::move(resultLength), std::move(*left), rightExpr);
1747 }
1748 }
1749 }
1750 } else if (rightExpr.Rank() > 0) {
1751 if (std::optional<Shape> rightShape{GetShape(context, rightExpr)}) {
1752 if (IsExpandableScalar(leftExpr, context, *rightShape)) {
1753 if (auto right{AsFlatArrayConstructor(rightExpr)}) {
1754 return MapOperation(context, std::move(f), *rightShape,
1755 std::move(resultLength), leftExpr, std::move(*right));
1756 }
1757 }
1758 }
1759 }
1760 return std::nullopt;
1761}
1762
1763template <typename DERIVED, typename RESULT, typename LEFT, typename RIGHT>
1764auto ApplyElementwise(
1765 FoldingContext &context, Operation<DERIVED, RESULT, LEFT, RIGHT> &operation)
1766 -> std::optional<Expr<RESULT>> {
1767 return ApplyElementwise(context, operation,
1768 std::function<Expr<RESULT>(Expr<LEFT> &&, Expr<RIGHT> &&)>{
1769 [](Expr<LEFT> &&left, Expr<RIGHT> &&right) {
1770 return Expr<RESULT>{DERIVED{std::move(left), std::move(right)}};
1771 }});
1772}
1773
1774// Unary operations
1775
1776template <typename TO, typename FROM>
1777common::IfNoLvalue<std::optional<TO>, FROM> ConvertString(FROM &&s) {
1778 if constexpr (std::is_same_v<TO, FROM>) {
1779 return std::make_optional<TO>(std::move(s));
1780 } else {
1781 // Fortran character conversion is well defined between distinct kinds
1782 // only when the actual characters are valid 7-bit ASCII.
1783 TO str;
1784 for (auto iter{s.cbegin()}; iter != s.cend(); ++iter) {
1785 if (static_cast<std::uint64_t>(*iter) > 127) {
1786 return std::nullopt;
1787 }
1788 str.push_back(static_cast<typename TO::value_type>(*iter));
1789 }
1790 return std::make_optional<TO>(std::move(str));
1791 }
1792}
1793
1794template <typename TO, TypeCategory FROMCAT>
1795Expr<TO> FoldOperation(
1796 FoldingContext &context, Convert<TO, FROMCAT> &&convert) {
1797 if (auto array{ApplyElementwise(context, convert)}) {
1798 return *array;
1799 }
1800 struct {
1801 FoldingContext &context;
1802 Convert<TO, FROMCAT> &convert;
1803 } msvcWorkaround{context, convert};
1804 return common::visit(
1805 [&msvcWorkaround](auto &kindExpr) -> Expr<TO> {
1806 using Operand = ResultType<decltype(kindExpr)>;
1807 // This variable is a workaround for msvc which emits an error when
1808 // using the FROMCAT template parameter below.
1809 TypeCategory constexpr FromCat{FROMCAT};
1810 static_assert(FromCat == Operand::category);
1811 auto &convert{msvcWorkaround.convert};
1812 if (auto value{GetScalarConstantValue<Operand>(kindExpr)}) {
1813 FoldingContext &ctx{msvcWorkaround.context};
1814 if constexpr (TO::category == TypeCategory::Integer) {
1815 if constexpr (FromCat == TypeCategory::Integer) {
1816 auto converted{Scalar<TO>::ConvertSigned(*value)};
1817 if (converted.overflow) {
1818 ctx.Warn(common::UsageWarning::FoldingException,
1819 "conversion of %s_%d to INTEGER(%d) overflowed; result is %s"_warn_en_US,
1820 value->SignedDecimal(), Operand::kind, TO::kind,
1821 converted.value.SignedDecimal());
1822 }
1823 return ScalarConstantToExpr(std::move(converted.value));
1824 } else if constexpr (FromCat == TypeCategory::Unsigned) {
1825 auto converted{Scalar<TO>::ConvertUnsigned(*value)};
1826 if ((converted.overflow || converted.value.IsNegative())) {
1827 ctx.Warn(common::UsageWarning::FoldingException,
1828 "conversion of %s_U%d to INTEGER(%d) overflowed; result is %s"_warn_en_US,
1829 value->UnsignedDecimal(), Operand::kind, TO::kind,
1830 converted.value.SignedDecimal());
1831 }
1832 return ScalarConstantToExpr(std::move(converted.value));
1833 } else if constexpr (FromCat == TypeCategory::Real) {
1834 auto converted{value->template ToInteger<Scalar<TO>>()};
1835 if (converted.flags.test(RealFlag::InvalidArgument)) {
1836 ctx.Warn(common::UsageWarning::FoldingException,
1837 "REAL(%d) to INTEGER(%d) conversion: invalid argument"_warn_en_US,
1838 Operand::kind, TO::kind);
1839 } else if (converted.flags.test(RealFlag::Overflow)) {
1840 ctx.Warn(common::UsageWarning::FoldingException,
1841 "REAL(%d) to INTEGER(%d) conversion overflowed"_warn_en_US,
1842 Operand::kind, TO::kind);
1843 }
1844 return ScalarConstantToExpr(std::move(converted.value));
1845 }
1846 } else if constexpr (TO::category == TypeCategory::Unsigned) {
1847 if constexpr (FromCat == TypeCategory::Integer ||
1848 FromCat == TypeCategory::Unsigned) {
1849 return Expr<TO>{
1850 Constant<TO>{Scalar<TO>::ConvertUnsigned(*value).value}};
1851 } else if constexpr (FromCat == TypeCategory::Real) {
1852 return Expr<TO>{
1853 Constant<TO>{value->template ToInteger<Scalar<TO>>().value}};
1854 }
1855 } else if constexpr (TO::category == TypeCategory::Real) {
1856 if constexpr (FromCat == TypeCategory::Integer ||
1857 FromCat == TypeCategory::Unsigned) {
1858 auto converted{Scalar<TO>::FromInteger(
1859 *value, FromCat == TypeCategory::Unsigned)};
1860 if (!converted.flags.empty()) {
1861 char buffer[64];
1862 std::snprintf(buffer, sizeof buffer,
1863 "INTEGER(%d) to REAL(%d) conversion", Operand::kind,
1864 TO::kind);
1865 RealFlagWarnings(ctx, converted.flags, buffer);
1866 }
1867 return ScalarConstantToExpr(std::move(converted.value));
1868 } else if constexpr (FromCat == TypeCategory::Real) {
1869 auto converted{Scalar<TO>::Convert(*value)};
1870 char buffer[64];
1871 if (!converted.flags.empty()) {
1872 std::snprintf(buffer, sizeof buffer,
1873 "REAL(%d) to REAL(%d) conversion", Operand::kind, TO::kind);
1874 RealFlagWarnings(ctx, converted.flags, buffer);
1875 }
1876 if (ctx.targetCharacteristics().areSubnormalsFlushedToZero()) {
1877 converted.value = converted.value.FlushSubnormalToZero();
1878 }
1879 return ScalarConstantToExpr(std::move(converted.value));
1880 }
1881 } else if constexpr (TO::category == TypeCategory::Complex) {
1882 if constexpr (FromCat == TypeCategory::Complex) {
1883 return FoldOperation(ctx,
1884 ComplexConstructor<TO::kind>{
1885 AsExpr(Convert<typename TO::Part>{AsCategoryExpr(
1886 Constant<typename Operand::Part>{value->REAL()})}),
1887 AsExpr(Convert<typename TO::Part>{AsCategoryExpr(
1888 Constant<typename Operand::Part>{value->AIMAG()})})});
1889 }
1890 } else if constexpr (TO::category == TypeCategory::Character &&
1891 FromCat == TypeCategory::Character) {
1892 if (auto converted{ConvertString<Scalar<TO>>(std::move(*value))}) {
1893 return ScalarConstantToExpr(std::move(*converted));
1894 }
1895 } else if constexpr (TO::category == TypeCategory::Logical &&
1896 FromCat == TypeCategory::Logical) {
1897 return Expr<TO>{value->IsTrue()};
1898 }
1899 } else if constexpr (TO::category == FromCat &&
1900 FromCat != TypeCategory::Character) {
1901 // Conversion of non-constant in same type category
1902 if constexpr (std::is_same_v<Operand, TO>) {
1903 return std::move(kindExpr); // remove needless conversion
1904 } else if constexpr (TO::category == TypeCategory::Logical ||
1905 TO::category == TypeCategory::Integer) {
1906 if (auto *innerConv{
1907 std::get_if<Convert<Operand, TO::category>>(&kindExpr.u)}) {
1908 // Conversion of conversion of same category & kind
1909 if (auto *x{std::get_if<Expr<TO>>(&innerConv->left().u)}) {
1910 if constexpr (TO::category == TypeCategory::Logical ||
1911 TO::kind <= Operand::kind) {
1912 return std::move(*x); // no-op Logical or Integer
1913 // widening/narrowing conversion pair
1914 } else if constexpr (std::is_same_v<TO,
1915 DescriptorInquiry::Result>) {
1916 if (std::holds_alternative<DescriptorInquiry>(x->u) ||
1917 std::holds_alternative<TypeParamInquiry>(x->u)) {
1918 // int(int(size(...),kind=k),kind=8) -> size(...)
1919 return std::move(*x);
1920 }
1921 }
1922 }
1923 }
1924 }
1925 }
1926 return Expr<TO>{std::move(convert)};
1927 },
1928 convert.left().u);
1929}
1930
1931template <typename T>
1932Expr<T> FoldOperation(FoldingContext &context, Parentheses<T> &&x) {
1933 auto &operand{x.left()};
1934 operand = Fold(context, std::move(operand));
1935 if (auto value{GetScalarConstantValue<T>(operand)}) {
1936 // Preserve parentheses, even around constants.
1937 return Expr<T>{Parentheses<T>{Expr<T>{Constant<T>{*value}}}};
1938 } else if (std::holds_alternative<Parentheses<T>>(operand.u)) {
1939 // ((x)) -> (x)
1940 return std::move(operand);
1941 } else {
1942 return Expr<T>{Parentheses<T>{std::move(operand)}};
1943 }
1944}
1945
1946template <typename T>
1947Expr<T> FoldOperation(FoldingContext &context, Negate<T> &&x) {
1948 if (auto array{ApplyElementwise(context, x)}) {
1949 return *array;
1950 }
1951 auto &operand{x.left()};
1952 if (auto *nn{std::get_if<Negate<T>>(&x.left().u)}) {
1953 // -(-x) -> (x)
1954 if (IsVariable(nn->left())) {
1955 return FoldOperation(context, Parentheses<T>{std::move(nn->left())});
1956 } else {
1957 return std::move(nn->left());
1958 }
1959 } else if (auto value{GetScalarConstantValue<T>(operand)}) {
1960 if constexpr (T::category == TypeCategory::Integer) {
1961 auto negated{value->Negate()};
1962 if (negated.overflow) {
1963 context.Warn(common::UsageWarning::FoldingException,
1964 "INTEGER(%d) negation overflowed"_warn_en_US, T::kind);
1965 }
1966 return Expr<T>{Constant<T>{std::move(negated.value)}};
1967 } else if constexpr (T::category == TypeCategory::Unsigned) {
1968 return Expr<T>{Constant<T>{std::move(value->Negate().value)}};
1969 } else {
1970 // REAL & COMPLEX negation: no exceptions possible
1971 return Expr<T>{Constant<T>{value->Negate()}};
1972 }
1973 }
1974 return Expr<T>{std::move(x)};
1975}
1976
1977// Binary (dyadic) operations
1978
1979template <typename LEFT, typename RIGHT>
1980std::optional<std::pair<Scalar<LEFT>, Scalar<RIGHT>>> OperandsAreConstants(
1981 const Expr<LEFT> &x, const Expr<RIGHT> &y) {
1982 if (auto xvalue{GetScalarConstantValue<LEFT>(x)}) {
1983 if (auto yvalue{GetScalarConstantValue<RIGHT>(y)}) {
1984 return {std::make_pair(*xvalue, *yvalue)};
1985 }
1986 }
1987 return std::nullopt;
1988}
1989
1990template <typename DERIVED, typename RESULT, typename LEFT, typename RIGHT>
1991std::optional<std::pair<Scalar<LEFT>, Scalar<RIGHT>>> OperandsAreConstants(
1992 const Operation<DERIVED, RESULT, LEFT, RIGHT> &operation) {
1993 return OperandsAreConstants(operation.left(), operation.right());
1994}
1995
1996template <typename T>
1997Expr<T> FoldOperation(FoldingContext &context, Add<T> &&x) {
1998 if (auto array{ApplyElementwise(context, x)}) {
1999 return *array;
2000 }
2001 if (auto folded{OperandsAreConstants(x)}) {
2002 if constexpr (T::category == TypeCategory::Integer) {
2003 auto sum{folded->first.AddSigned(folded->second)};
2004 if (sum.overflow) {
2005 context.Warn(common::UsageWarning::FoldingException,
2006 "INTEGER(%d) addition overflowed"_warn_en_US, T::kind);
2007 }
2008 return Expr<T>{Constant<T>{sum.value}};
2009 } else if constexpr (T::category == TypeCategory::Unsigned) {
2010 return Expr<T>{
2011 Constant<T>{folded->first.AddUnsigned(folded->second).value}};
2012 } else {
2013 auto sum{folded->first.Add(
2014 folded->second, context.targetCharacteristics().roundingMode())};
2015 RealFlagWarnings(context, sum.flags, "addition");
2016 if (context.targetCharacteristics().areSubnormalsFlushedToZero()) {
2017 sum.value = sum.value.FlushSubnormalToZero();
2018 }
2019 return Expr<T>{Constant<T>{sum.value}};
2020 }
2021 }
2022 return Expr<T>{std::move(x)};
2023}
2024
2025template <typename T>
2026Expr<T> FoldOperation(FoldingContext &context, Subtract<T> &&x) {
2027 if (auto array{ApplyElementwise(context, x)}) {
2028 return *array;
2029 }
2030 if (auto folded{OperandsAreConstants(x)}) {
2031 if constexpr (T::category == TypeCategory::Integer) {
2032 auto difference{folded->first.SubtractSigned(folded->second)};
2033 if (difference.overflow) {
2034 context.Warn(common::UsageWarning::FoldingException,
2035 "INTEGER(%d) subtraction overflowed"_warn_en_US, T::kind);
2036 }
2037 return Expr<T>{Constant<T>{difference.value}};
2038 } else if constexpr (T::category == TypeCategory::Unsigned) {
2039 return Expr<T>{
2040 Constant<T>{folded->first.SubtractSigned(folded->second).value}};
2041 } else {
2042 auto difference{folded->first.Subtract(
2043 folded->second, context.targetCharacteristics().roundingMode())};
2044 RealFlagWarnings(context, difference.flags, "subtraction");
2045 if (context.targetCharacteristics().areSubnormalsFlushedToZero()) {
2046 difference.value = difference.value.FlushSubnormalToZero();
2047 }
2048 return Expr<T>{Constant<T>{difference.value}};
2049 }
2050 }
2051 return Expr<T>{std::move(x)};
2052}
2053
2054template <typename T>
2055Expr<T> FoldOperation(FoldingContext &context, Multiply<T> &&x) {
2056 if (auto array{ApplyElementwise(context, x)}) {
2057 return *array;
2058 }
2059 if (auto folded{OperandsAreConstants(x)}) {
2060 if constexpr (T::category == TypeCategory::Integer) {
2061 auto product{folded->first.MultiplySigned(folded->second)};
2062 if (product.SignedMultiplicationOverflowed()) {
2063 context.Warn(common::UsageWarning::FoldingException,
2064 "INTEGER(%d) multiplication overflowed"_warn_en_US, T::kind);
2065 }
2066 return Expr<T>{Constant<T>{product.lower}};
2067 } else if constexpr (T::category == TypeCategory::Unsigned) {
2068 return Expr<T>{
2069 Constant<T>{folded->first.MultiplyUnsigned(folded->second).lower}};
2070 } else {
2071 auto product{folded->first.Multiply(
2072 folded->second, context.targetCharacteristics().roundingMode())};
2073 RealFlagWarnings(context, product.flags, "multiplication");
2074 if (context.targetCharacteristics().areSubnormalsFlushedToZero()) {
2075 product.value = product.value.FlushSubnormalToZero();
2076 }
2077 return Expr<T>{Constant<T>{product.value}};
2078 }
2079 } else if constexpr (T::category == TypeCategory::Integer) {
2080 if (auto c{GetScalarConstantValue<T>(x.right())}) {
2081 x.right() = std::move(x.left());
2082 x.left() = Expr<T>{std::move(*c)};
2083 }
2084 if (auto c{GetScalarConstantValue<T>(x.left())}) {
2085 if (c->IsZero() && x.right().Rank() == 0) {
2086 return std::move(x.left());
2087 } else if (c->CompareSigned(Scalar<T>{1}) == Ordering::Equal) {
2088 if (IsVariable(x.right())) {
2089 return FoldOperation(context, Parentheses<T>{std::move(x.right())});
2090 } else {
2091 return std::move(x.right());
2092 }
2093 } else if (c->CompareSigned(Scalar<T>{-1}) == Ordering::Equal) {
2094 return FoldOperation(context, Negate<T>{std::move(x.right())});
2095 }
2096 }
2097 }
2098 return Expr<T>{std::move(x)};
2099}
2100
2101template <typename T>
2102Expr<T> FoldOperation(FoldingContext &context, Divide<T> &&x) {
2103 if (auto array{ApplyElementwise(context, x)}) {
2104 return *array;
2105 }
2106 if (auto folded{OperandsAreConstants(x)}) {
2107 if constexpr (T::category == TypeCategory::Integer) {
2108 auto quotAndRem{folded->first.DivideSigned(folded->second)};
2109 if (quotAndRem.divisionByZero) {
2110 context.Warn(common::UsageWarning::FoldingException,
2111 "INTEGER(%d) division by zero"_warn_en_US, T::kind);
2112 return Expr<T>{std::move(x)};
2113 }
2114 if (quotAndRem.overflow) {
2115 context.Warn(common::UsageWarning::FoldingException,
2116 "INTEGER(%d) division overflowed"_warn_en_US, T::kind);
2117 }
2118 return Expr<T>{Constant<T>{quotAndRem.quotient}};
2119 } else if constexpr (T::category == TypeCategory::Unsigned) {
2120 auto quotAndRem{folded->first.DivideUnsigned(folded->second)};
2121 if (quotAndRem.divisionByZero) {
2122 context.Warn(common::UsageWarning::FoldingException,
2123 "UNSIGNED(%d) division by zero"_warn_en_US, T::kind);
2124 return Expr<T>{std::move(x)};
2125 }
2126 return Expr<T>{Constant<T>{quotAndRem.quotient}};
2127 } else {
2128 auto quotient{folded->first.Divide(
2129 folded->second, context.targetCharacteristics().roundingMode())};
2130 // Don't warn about -1./0., 0./0., or 1./0. from a module file
2131 // they are interpreted as canonical Fortran representations of -Inf,
2132 // NaN, and Inf respectively.
2133 bool isCanonicalNaNOrInf{false};
2134 if constexpr (T::category == TypeCategory::Real) {
2135 if (folded->second.IsZero() && context.moduleFileName().has_value()) {
2136 using IntType = typename T::Scalar::Word;
2137 auto intNumerator{folded->first.template ToInteger<IntType>()};
2138 isCanonicalNaNOrInf = intNumerator.flags == RealFlags{} &&
2139 intNumerator.value >= IntType{-1} &&
2140 intNumerator.value <= IntType{1};
2141 }
2142 }
2143 if (!isCanonicalNaNOrInf) {
2144 RealFlagWarnings(context, quotient.flags, "division");
2145 }
2146 if (context.targetCharacteristics().areSubnormalsFlushedToZero()) {
2147 quotient.value = quotient.value.FlushSubnormalToZero();
2148 }
2149 return Expr<T>{Constant<T>{quotient.value}};
2150 }
2151 }
2152 return Expr<T>{std::move(x)};
2153}
2154
2155template <typename T>
2156Expr<T> FoldOperation(FoldingContext &context, Power<T> &&x) {
2157 if (auto array{ApplyElementwise(context, x)}) {
2158 return *array;
2159 }
2160 if (auto folded{OperandsAreConstants(x)}) {
2161 if constexpr (T::category == TypeCategory::Integer) {
2162 auto power{folded->first.Power(folded->second)};
2163 if (power.divisionByZero) {
2164 context.Warn(common::UsageWarning::FoldingException,
2165 "INTEGER(%d) zero to negative power"_warn_en_US, T::kind);
2166 } else if (power.overflow) {
2167 context.Warn(common::UsageWarning::FoldingException,
2168 "INTEGER(%d) power overflowed"_warn_en_US, T::kind);
2169 } else if (power.zeroToZero) {
2170 context.Warn(common::UsageWarning::FoldingException,
2171 "INTEGER(%d) 0**0 is not defined"_warn_en_US, T::kind);
2172 }
2173 return Expr<T>{Constant<T>{power.power}};
2174 } else {
2175 if (folded->first.IsZero()) {
2176 if (folded->second.IsZero()) {
2177 context.Warn(common::UsageWarning::FoldingException,
2178 "REAL/COMPLEX 0**0 is not defined"_warn_en_US);
2179 } else {
2180 return Expr<T>(Constant<T>{folded->first}); // 0. ** nonzero -> 0.
2181 }
2182 } else if (auto callable{GetHostRuntimeWrapper<T, T, T>("pow")}) {
2183 return Expr<T>{
2184 Constant<T>{(*callable)(context, folded->first, folded->second)}};
2185 } else {
2186 context.Warn(common::UsageWarning::FoldingFailure,
2187 "Power for %s cannot be folded on host"_warn_en_US,
2188 T{}.AsFortran());
2189 }
2190 }
2191 }
2192 return Expr<T>{std::move(x)};
2193}
2194
2195template <typename T>
2196Expr<T> FoldOperation(FoldingContext &context, RealToIntPower<T> &&x) {
2197 if (auto array{ApplyElementwise(context, x)}) {
2198 return *array;
2199 }
2200 return common::visit(
2201 [&](auto &y) -> Expr<T> {
2202 if (auto folded{OperandsAreConstants(x.left(), y)}) {
2203 auto power{evaluate::IntPower(folded->first, folded->second)};
2204 RealFlagWarnings(context, power.flags, "power with INTEGER exponent");
2205 if (context.targetCharacteristics().areSubnormalsFlushedToZero()) {
2206 power.value = power.value.FlushSubnormalToZero();
2207 }
2208 return Expr<T>{Constant<T>{power.value}};
2209 } else {
2210 return Expr<T>{std::move(x)};
2211 }
2212 },
2213 x.right().u);
2214}
2215
2216template <typename T>
2217Expr<T> FoldOperation(FoldingContext &context, Extremum<T> &&x) {
2218 if (auto array{ApplyElementwise(context, x,
2219 std::function<Expr<T>(Expr<T> &&, Expr<T> &&)>{[=](Expr<T> &&l,
2220 Expr<T> &&r) {
2221 return Expr<T>{Extremum<T>{x.ordering, std::move(l), std::move(r)}};
2222 }})}) {
2223 return *array;
2224 }
2225 if (auto folded{OperandsAreConstants(x)}) {
2226 if constexpr (T::category == TypeCategory::Integer) {
2227 if (folded->first.CompareSigned(folded->second) == x.ordering) {
2228 return Expr<T>{Constant<T>{folded->first}};
2229 }
2230 } else if constexpr (T::category == TypeCategory::Unsigned) {
2231 if (folded->first.CompareUnsigned(folded->second) == x.ordering) {
2232 return Expr<T>{Constant<T>{folded->first}};
2233 }
2234 } else if constexpr (T::category == TypeCategory::Real) {
2235 if (folded->first.IsNotANumber() ||
2236 (folded->first.Compare(folded->second) == Relation::Less) ==
2237 (x.ordering == Ordering::Less)) {
2238 return Expr<T>{Constant<T>{folded->first}};
2239 }
2240 } else {
2241 static_assert(T::category == TypeCategory::Character);
2242 // Result of MIN and MAX on character has the length of
2243 // the longest argument.
2244 auto maxLen{std::max(folded->first.length(), folded->second.length())};
2245 bool isFirst{x.ordering == Compare(folded->first, folded->second)};
2246 auto res{isFirst ? std::move(folded->first) : std::move(folded->second)};
2247 res = res.length() == maxLen
2248 ? std::move(res)
2249 : CharacterUtils<T::kind>::Resize(res, maxLen);
2250 return Expr<T>{Constant<T>{std::move(res)}};
2251 }
2252 return Expr<T>{Constant<T>{folded->second}};
2253 }
2254 return Expr<T>{std::move(x)};
2255}
2256
2257template <int KIND>
2258Expr<Type<TypeCategory::Real, KIND>> ToReal(
2259 FoldingContext &context, Expr<SomeType> &&expr) {
2260 using Result = Type<TypeCategory::Real, KIND>;
2261 std::optional<Expr<Result>> result;
2262 common::visit(
2263 [&](auto &&x) {
2264 using From = std::decay_t<decltype(x)>;
2265 if constexpr (std::is_same_v<From, BOZLiteralConstant>) {
2266 // Move the bits without any integer->real conversion
2267 From original{x};
2268 result = ConvertToType<Result>(std::move(x));
2269 const auto *constant{UnwrapExpr<Constant<Result>>(*result)};
2270 CHECK(constant);
2271 Scalar<Result> real{constant->GetScalarValue().value()};
2272 From converted{From::ConvertUnsigned(real.RawBits()).value};
2273 if (original != converted) { // C1601
2274 context.Warn(common::UsageWarning::FoldingValueChecks,
2275 "Nonzero bits truncated from BOZ literal constant in REAL intrinsic"_warn_en_US);
2276 }
2277 } else if constexpr (IsNumericCategoryExpr<From>()) {
2278 result = Fold(context, ConvertToType<Result>(std::move(x)));
2279 } else {
2280 common::die("ToReal: bad argument expression");
2281 }
2282 },
2283 std::move(expr.u));
2284 return result.value();
2285}
2286
2287// REAL(z) and AIMAG(z)
2288template <int KIND>
2289Expr<Type<TypeCategory::Real, KIND>> FoldOperation(
2290 FoldingContext &context, ComplexComponent<KIND> &&x) {
2291 using Operand = Type<TypeCategory::Complex, KIND>;
2292 using Result = Type<TypeCategory::Real, KIND>;
2293 if (auto array{ApplyElementwise(context, x,
2294 std::function<Expr<Result>(Expr<Operand> &&)>{
2295 [=](Expr<Operand> &&operand) {
2296 return Expr<Result>{ComplexComponent<KIND>{
2297 x.isImaginaryPart, std::move(operand)}};
2298 }})}) {
2299 return *array;
2300 }
2301 auto &operand{x.left()};
2302 if (auto value{GetScalarConstantValue<Operand>(operand)}) {
2303 if (x.isImaginaryPart) {
2304 return Expr<Result>{Constant<Result>{value->AIMAG()}};
2305 } else {
2306 return Expr<Result>{Constant<Result>{value->REAL()}};
2307 }
2308 }
2309 return Expr<Result>{std::move(x)};
2310}
2311
2312template <typename T>
2313Expr<T> ExpressionBase<T>::Rewrite(FoldingContext &context, Expr<T> &&expr) {
2314 return common::visit(
2315 [&](auto &&x) -> Expr<T> {
2316 if constexpr (IsSpecificIntrinsicType<T>) {
2317 return FoldOperation(context, std::move(x));
2318 } else if constexpr (std::is_same_v<T, SomeDerived>) {
2319 return FoldOperation(context, std::move(x));
2320 } else if constexpr (common::HasMember<decltype(x),
2321 TypelessExpression>) {
2322 return std::move(expr);
2323 } else {
2324 return Expr<T>{Fold(context, std::move(x))};
2325 }
2326 },
2327 std::move(expr.u));
2328}
2329
2330FOR_EACH_TYPE_AND_KIND(extern template class ExpressionBase, )
2331} // namespace Fortran::evaluate
2332#endif // FORTRAN_EVALUATE_FOLD_IMPLEMENTATION_H_
Definition: indirection.h:72
Definition: fold-implementation.h:1301
Definition: expression.h:438
Definition: expression.h:466
Definition: variable.h:205
Definition: variable.h:73
Definition: constant.h:147
Definition: variable.h:377
Definition: common.h:214
Definition: fold-implementation.h:55
Definition: common.h:216
Definition: call.h:282
Definition: expression.h:404
Definition: variable.h:101
Definition: symbol.h:778
Definition: call.h:34
Definition: expression.h:432
Definition: variable.h:284
Definition: variable.h:191