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 "intrinsics-library-templates.h"
16 #include "flang/Common/indirection.h"
17 #include "flang/Common/template.h"
18 #include "flang/Common/unwrap.h"
19 #include "flang/Evaluate/characteristics.h"
20 #include "flang/Evaluate/common.h"
21 #include "flang/Evaluate/constant.h"
22 #include "flang/Evaluate/expression.h"
23 #include "flang/Evaluate/fold.h"
24 #include "flang/Evaluate/formatting.h"
25 #include "flang/Evaluate/shape.h"
26 #include "flang/Evaluate/tools.h"
27 #include "flang/Evaluate/traverse.h"
28 #include "flang/Evaluate/type.h"
29 #include "flang/Parser/message.h"
30 #include "flang/Semantics/scope.h"
31 #include "flang/Semantics/symbol.h"
32 #include "flang/Semantics/tools.h"
33 #include <algorithm>
34 #include <cmath>
35 #include <complex>
36 #include <cstdio>
37 #include <optional>
38 #include <type_traits>
39 #include <variant>
40
41 // Some environments, viz. clang on Darwin, allow the macro HUGE
42 // to leak out of <math.h> even when it is never directly included.
43 #undef HUGE
44
45 namespace Fortran::evaluate {
46
47 // Utilities
48 template <typename T> class Folder {
49 public:
50 explicit Folder(FoldingContext &c) : context_{c} {}
51 std::optional<Expr<T>> GetNamedConstantValue(const Symbol &);
52 std::optional<Constant<T>> GetFoldedNamedConstantValue(const Symbol &);
53 std::optional<Constant<T>> ApplySubscripts(const Constant<T> &array,
54 const std::vector<Constant<SubscriptInteger>> &subscripts);
55 std::optional<Constant<T>> ApplyComponent(Constant<SomeDerived> &&,
56 const Symbol &component,
57 const std::vector<Constant<SubscriptInteger>> * = nullptr);
58 std::optional<Constant<T>> GetConstantComponent(
59 Component &, const std::vector<Constant<SubscriptInteger>> * = nullptr);
60 std::optional<Constant<T>> Folding(ArrayRef &);
61 Expr<T> Folding(Designator<T> &&);
62 Constant<T> *Folding(std::optional<ActualArgument> &);
63 Expr<T> Reshape(FunctionRef<T> &&);
64
65 private:
66 FoldingContext &context_;
67 };
68
69 std::optional<Constant<SubscriptInteger>> GetConstantSubscript(
70 FoldingContext &, Subscript &, const NamedEntity &, int dim);
71
72 // FoldOperation() rewrites expression tree nodes.
73 // If there is any possibility that the rewritten node will
74 // not have the same representation type, the result of
75 // FoldOperation() will be packaged in an Expr<> of the same
76 // specific type.
77
78 // no-op base case
79 template <typename A>
80 common::IfNoLvalue<Expr<ResultType<A>>, A> FoldOperation(
81 FoldingContext &, A &&x) {
82 static_assert(!std::is_same_v<A, Expr<ResultType<A>>>,
83 "call Fold() instead for Expr<>");
84 return Expr<ResultType<A>>{std::move(x)};
85 }
86
87 Component FoldOperation(FoldingContext &, Component &&);
88 NamedEntity FoldOperation(FoldingContext &, NamedEntity &&);
89 Triplet FoldOperation(FoldingContext &, Triplet &&);
90 Subscript FoldOperation(FoldingContext &, Subscript &&);
91 ArrayRef FoldOperation(FoldingContext &, ArrayRef &&);
92 CoarrayRef FoldOperation(FoldingContext &, CoarrayRef &&);
93 DataRef FoldOperation(FoldingContext &, DataRef &&);
94 Substring FoldOperation(FoldingContext &, Substring &&);
95 ComplexPart FoldOperation(FoldingContext &, ComplexPart &&);
96
97 template <typename T>
98 Expr<T> FoldOperation(FoldingContext &context, FunctionRef<T> &&);
99 template <int KIND>
100 Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
101 FoldingContext &context, FunctionRef<Type<TypeCategory::Integer, KIND>> &&);
102 template <int KIND>
103 Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
104 FoldingContext &context, FunctionRef<Type<TypeCategory::Real, KIND>> &&);
105 template <int KIND>
106 Expr<Type<TypeCategory::Complex, KIND>> FoldIntrinsicFunction(
107 FoldingContext &context, FunctionRef<Type<TypeCategory::Complex, KIND>> &&);
108 template <int KIND>
109 Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
110 FoldingContext &context, FunctionRef<Type<TypeCategory::Logical, KIND>> &&);
111
112 template <typename T>
113 Expr<T> FoldOperation(FoldingContext &context, Designator<T> &&designator) {
114 return Folder<T>{context}.Folding(std::move(designator));
115 }
116
117 template <int KIND>
118 Expr<Type<TypeCategory::Integer, KIND>> FoldOperation(
119 FoldingContext &, TypeParamInquiry<KIND> &&);
120 Expr<ImpliedDoIndex::Result> FoldOperation(
121 FoldingContext &context, ImpliedDoIndex &&);
122 template <typename T>
123 Expr<T> FoldOperation(FoldingContext &, ArrayConstructor<T> &&);
124 Expr<SomeDerived> FoldOperation(FoldingContext &, StructureConstructor &&);
125
126 template <typename T>
127 std::optional<Expr<T>> Folder<T>::GetNamedConstantValue(const Symbol &symbol0) {
128 const Symbol &symbol{ResolveAssociations(symbol0)};
129 if (IsNamedConstant(symbol)) {
130 if (const auto *object{
131 symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
132 if (object->initWasValidated()) {
133 const auto *constant{UnwrapConstantValue<T>(object->init())};
134 return Expr<T>{DEREF(constant)};
135 }
136 if (const auto &init{object->init()}) {
137 if (auto dyType{DynamicType::From(symbol)}) {
138 semantics::ObjectEntityDetails *mutableObject{
139 const_cast<semantics::ObjectEntityDetails *>(object)};
140 auto converted{
141 ConvertToType(*dyType, std::move(mutableObject->init().value()))};
142 // Reset expression now to prevent infinite loops if the init
143 // expression depends on symbol itself.
144 mutableObject->set_init(std::nullopt);
145 if (converted) {
146 *converted = Fold(context_, std::move(*converted));
147 auto *unwrapped{UnwrapExpr<Expr<T>>(*converted)};
148 CHECK(unwrapped);
149 if (auto *constant{UnwrapConstantValue<T>(*unwrapped)}) {
150 if (symbol.Rank() > 0) {
151 if (constant->Rank() == 0) {
152 // scalar expansion
153 if (auto extents{GetConstantExtents(context_, symbol)}) {
154 *constant = constant->Reshape(std::move(*extents));
155 CHECK(constant->Rank() == symbol.Rank());
156 }
157 }
158 if (constant->Rank() == symbol.Rank()) {
159 NamedEntity base{symbol};
160 if (auto lbounds{AsConstantExtents(
161 context_, GetLowerBounds(context_, base))}) {
162 constant->set_lbounds(*std::move(lbounds));
163 }
164 }
165 }
166 mutableObject->set_init(AsGenericExpr(Expr<T>{*constant}));
167 if (auto constShape{GetShape(context_, *constant)}) {
168 if (auto symShape{GetShape(context_, symbol)}) {
169 if (CheckConformance(context_.messages(), *constShape,
170 *symShape, "initialization expression",
171 "PARAMETER")) {
172 mutableObject->set_initWasValidated();
173 return std::move(*unwrapped);
174 }
175 } else {
176 context_.messages().Say(symbol.name(),
177 "Could not determine the shape of the PARAMETER"_err_en_US);
178 }
179 } else {
180 context_.messages().Say(symbol.name(),
181 "Could not determine the shape of the initialization expression"_err_en_US);
182 }
183 mutableObject->set_init(std::nullopt);
184 } else {
185 context_.messages().Say(symbol.name(),
186 "Initialization expression for PARAMETER '%s' (%s) cannot be computed as a constant value"_err_en_US,
187 symbol.name(), unwrapped->AsFortran());
188 }
189 } else {
190 context_.messages().Say(symbol.name(),
191 "Initialization expression for PARAMETER '%s' (%s) cannot be converted to its type (%s)"_err_en_US,
192 symbol.name(), init->AsFortran(), dyType->AsFortran());
193 }
194 }
195 }
196 }
197 }
198 return std::nullopt;
199 }
200
201 template <typename T>
202 std::optional<Constant<T>> Folder<T>::GetFoldedNamedConstantValue(
203 const Symbol &symbol) {
204 if (auto value{GetNamedConstantValue(symbol)}) {
205 Expr<T> folded{Fold(context_, std::move(*value))};
206 if (const Constant<T> *value{UnwrapConstantValue<T>(folded)}) {
207 return *value;
208 }
209 }
210 return std::nullopt;
211 }
212
213 template <typename T>
214 std::optional<Constant<T>> Folder<T>::Folding(ArrayRef &aRef) {
215 std::vector<Constant<SubscriptInteger>> subscripts;
216 int dim{0};
217 for (Subscript &ss : aRef.subscript()) {
218 if (auto constant{GetConstantSubscript(context_, ss, aRef.base(), dim++)}) {
219 subscripts.emplace_back(std::move(*constant));
220 } else {
221 return std::nullopt;
222 }
223 }
224 if (Component * component{aRef.base().UnwrapComponent()}) {
225 return GetConstantComponent(*component, &subscripts);
226 } else if (std::optional<Constant<T>> array{
227 GetFoldedNamedConstantValue(aRef.base().GetLastSymbol())}) {
228 return ApplySubscripts(*array, subscripts);
229 } else {
230 return std::nullopt;
231 }
232 }
233
234 template <typename T>
235 std::optional<Constant<T>> Folder<T>::ApplySubscripts(const Constant<T> &array,
236 const std::vector<Constant<SubscriptInteger>> &subscripts) {
237 const auto &shape{array.shape()};
238 const auto &lbounds{array.lbounds()};
239 int rank{GetRank(shape)};
240 CHECK(rank == static_cast<int>(subscripts.size()));
241 std::size_t elements{1};
242 ConstantSubscripts resultShape;
243 ConstantSubscripts ssLB;
244 for (const auto &ss : subscripts) {
245 CHECK(ss.Rank() <= 1);
246 if (ss.Rank() == 1) {
247 resultShape.push_back(static_cast<ConstantSubscript>(ss.size()));
248 elements *= ss.size();
249 ssLB.push_back(ss.lbounds().front());
250 }
251 }
252 ConstantSubscripts ssAt(rank, 0), at(rank, 0), tmp(1, 0);
253 std::vector<Scalar<T>> values;
254 while (elements-- > 0) {
255 bool increment{true};
256 int k{0};
257 for (int j{0}; j < rank; ++j) {
258 if (subscripts[j].Rank() == 0) {
259 at[j] = subscripts[j].GetScalarValue().value().ToInt64();
260 } else {
261 CHECK(k < GetRank(resultShape));
262 tmp[0] = ssLB.at(k) + ssAt.at(k);
263 at[j] = subscripts[j].At(tmp).ToInt64();
264 if (increment) {
265 if (++ssAt[k] == resultShape[k]) {
266 ssAt[k] = 0;
267 } else {
268 increment = false;
269 }
270 }
271 ++k;
272 }
273 if (at[j] < lbounds[j] || at[j] >= lbounds[j] + shape[j]) {
274 context_.messages().Say(
275 "Subscript value (%jd) is out of range on dimension %d in reference to a constant array value"_err_en_US,
276 at[j], j + 1);
277 return std::nullopt;
278 }
279 }
280 values.emplace_back(array.At(at));
281 CHECK(!increment || elements == 0);
282 CHECK(k == GetRank(resultShape));
283 }
284 if constexpr (T::category == TypeCategory::Character) {
285 return Constant<T>{array.LEN(), std::move(values), std::move(resultShape)};
286 } else if constexpr (std::is_same_v<T, SomeDerived>) {
287 return Constant<T>{array.result().derivedTypeSpec(), std::move(values),
288 std::move(resultShape)};
289 } else {
290 return Constant<T>{std::move(values), std::move(resultShape)};
291 }
292 }
293
294 template <typename T>
295 std::optional<Constant<T>> Folder<T>::ApplyComponent(
296 Constant<SomeDerived> &&structures, const Symbol &component,
297 const std::vector<Constant<SubscriptInteger>> *subscripts) {
298 if (auto scalar{structures.GetScalarValue()}) {
299 if (auto *expr{scalar->Find(component)}) {
300 if (const Constant<T> *value{UnwrapConstantValue<T>(*expr)}) {
301 if (!subscripts) {
302 return std::move(*value);
303 } else {
304 return ApplySubscripts(*value, *subscripts);
305 }
306 }
307 }
308 } else {
309 // A(:)%scalar_component & A(:)%array_component(subscripts)
310 std::unique_ptr<ArrayConstructor<T>> array;
311 if (structures.empty()) {
312 return std::nullopt;
313 }
314 ConstantSubscripts at{structures.lbounds()};
315 do {
316 StructureConstructor scalar{structures.At(at)};
317 if (auto *expr{scalar.Find(component)}) {
318 if (const Constant<T> *value{UnwrapConstantValue<T>(*expr)}) {
319 if (!array.get()) {
320 // This technique ensures that character length or derived type
321 // information is propagated to the array constructor.
322 auto *typedExpr{UnwrapExpr<Expr<T>>(*expr)};
323 CHECK(typedExpr);
324 array = std::make_unique<ArrayConstructor<T>>(*typedExpr);
325 }
326 if (subscripts) {
327 if (auto element{ApplySubscripts(*value, *subscripts)}) {
328 CHECK(element->Rank() == 0);
329 array->Push(Expr<T>{std::move(*element)});
330 } else {
331 return std::nullopt;
332 }
333 } else {
334 CHECK(value->Rank() == 0);
335 array->Push(Expr<T>{*value});
336 }
337 } else {
338 return std::nullopt;
339 }
340 }
341 } while (structures.IncrementSubscripts(at));
342 // Fold the ArrayConstructor<> into a Constant<>.
343 CHECK(array);
344 Expr<T> result{Fold(context_, Expr<T>{std::move(*array)})};
345 if (auto *constant{UnwrapConstantValue<T>(result)}) {
346 return constant->Reshape(common::Clone(structures.shape()));
347 }
348 }
349 return std::nullopt;
350 }
351
352 template <typename T>
353 std::optional<Constant<T>> Folder<T>::GetConstantComponent(Component &component,
354 const std::vector<Constant<SubscriptInteger>> *subscripts) {
355 if (std::optional<Constant<SomeDerived>> structures{std::visit(
356 common::visitors{
357 [&](const Symbol &symbol) {
358 return Folder<SomeDerived>{context_}
359 .GetFoldedNamedConstantValue(symbol);
360 },
361 [&](ArrayRef &aRef) {
362 return Folder<SomeDerived>{context_}.Folding(aRef);
363 },
364 [&](Component &base) {
365 return Folder<SomeDerived>{context_}.GetConstantComponent(base);
366 },
367 [&](CoarrayRef &) {
368 return std::optional<Constant<SomeDerived>>{};
369 },
370 },
371 component.base().u)}) {
372 return ApplyComponent(
373 std::move(*structures), component.GetLastSymbol(), subscripts);
374 } else {
375 return std::nullopt;
376 }
377 }
378
379 template <typename T> Expr<T> Folder<T>::Folding(Designator<T> &&designator) {
380 if constexpr (T::category == TypeCategory::Character) {
381 if (auto *substring{common::Unwrap<Substring>(designator.u)}) {
382 if (std::optional<Expr<SomeCharacter>> folded{
383 substring->Fold(context_)}) {
384 if (auto value{GetScalarConstantValue<T>(*folded)}) {
385 return Expr<T>{*value};
386 }
387 }
388 if (auto length{ToInt64(Fold(context_, substring->LEN()))}) {
389 if (*length == 0) {
390 return Expr<T>{Constant<T>{Scalar<T>{}}};
391 }
392 }
393 }
394 }
395 return std::visit(
396 common::visitors{
397 [&](SymbolRef &&symbol) {
398 if (auto constant{GetFoldedNamedConstantValue(*symbol)}) {
399 return Expr<T>{std::move(*constant)};
400 }
401 return Expr<T>{std::move(designator)};
402 },
403 [&](ArrayRef &&aRef) {
404 aRef = FoldOperation(context_, std::move(aRef));
405 if (auto c{Folding(aRef)}) {
406 return Expr<T>{std::move(*c)};
407 } else {
408 return Expr<T>{Designator<T>{std::move(aRef)}};
409 }
410 },
411 [&](Component &&component) {
412 component = FoldOperation(context_, std::move(component));
413 if (auto c{GetConstantComponent(component)}) {
414 return Expr<T>{std::move(*c)};
415 } else {
416 return Expr<T>{Designator<T>{std::move(component)}};
417 }
418 },
419 [&](auto &&x) {
420 return Expr<T>{
421 Designator<T>{FoldOperation(context_, std::move(x))}};
422 },
423 },
424 std::move(designator.u));
425 }
426
427 // Apply type conversion and re-folding if necessary.
428 // This is where BOZ arguments are converted.
429 template <typename T>
430 Constant<T> *Folder<T>::Folding(std::optional<ActualArgument> &arg) {
431 if (auto *expr{UnwrapExpr<Expr<SomeType>>(arg)}) {
432 if (!UnwrapExpr<Expr<T>>(*expr)) {
433 if (auto converted{ConvertToType(T::GetType(), std::move(*expr))}) {
434 *expr = Fold(context_, std::move(*converted));
435 }
436 }
437 return UnwrapConstantValue<T>(*expr);
438 }
439 return nullptr;
440 }
441
442 template <typename... A, std::size_t... I>
443 std::optional<std::tuple<const Constant<A> *...>> GetConstantArgumentsHelper(
444 FoldingContext &context, ActualArguments &arguments,
445 std::index_sequence<I...>) {
446 static_assert(
447 (... && IsSpecificIntrinsicType<A>)); // TODO derived types for MERGE?
448 static_assert(sizeof...(A) > 0);
449 std::tuple<const Constant<A> *...> args{
450 Folder<A>{context}.Folding(arguments.at(I))...};
451 if ((... && (std::get<I>(args)))) {
452 return args;
453 } else {
454 return std::nullopt;
455 }
456 }
457
458 template <typename... A>
459 std::optional<std::tuple<const Constant<A> *...>> GetConstantArguments(
460 FoldingContext &context, ActualArguments &args) {
461 return GetConstantArgumentsHelper<A...>(
462 context, args, std::index_sequence_for<A...>{});
463 }
464
465 template <typename... A, std::size_t... I>
466 std::optional<std::tuple<Scalar<A>...>> GetScalarConstantArgumentsHelper(
467 FoldingContext &context, ActualArguments &args, std::index_sequence<I...>) {
468 if (auto constArgs{GetConstantArguments<A...>(context, args)}) {
469 return std::tuple<Scalar<A>...>{
470 std::get<I>(*constArgs)->GetScalarValue().value()...};
471 } else {
472 return std::nullopt;
473 }
474 }
475
476 template <typename... A>
477 std::optional<std::tuple<Scalar<A>...>> GetScalarConstantArguments(
478 FoldingContext &context, ActualArguments &args) {
479 return GetScalarConstantArgumentsHelper<A...>(
480 context, args, std::index_sequence_for<A...>{});
481 }
482
483 // helpers to fold intrinsic function references
484 // Define callable types used in a common utility that
485 // takes care of array and cast/conversion aspects for elemental intrinsics
486
487 template <typename TR, typename... TArgs>
488 using ScalarFunc = std::function<Scalar<TR>(const Scalar<TArgs> &...)>;
489 template <typename TR, typename... TArgs>
490 using ScalarFuncWithContext =
491 std::function<Scalar<TR>(FoldingContext &, const Scalar<TArgs> &...)>;
492
493 template <template <typename, typename...> typename WrapperType, typename TR,
494 typename... TA, std::size_t... I>
495 Expr<TR> FoldElementalIntrinsicHelper(FoldingContext &context,
496 FunctionRef<TR> &&funcRef, WrapperType<TR, TA...> func,
497 std::index_sequence<I...>) {
498 if (std::optional<std::tuple<const Constant<TA> *...>> args{
499 GetConstantArguments<TA...>(context, funcRef.arguments())}) {
500 // Compute the shape of the result based on shapes of arguments
501 ConstantSubscripts shape;
502 int rank{0};
503 const ConstantSubscripts *shapes[sizeof...(TA)]{
504 &std::get<I>(*args)->shape()...};
505 const int ranks[sizeof...(TA)]{std::get<I>(*args)->Rank()...};
506 for (unsigned int i{0}; i < sizeof...(TA); ++i) {
507 if (ranks[i] > 0) {
508 if (rank == 0) {
509 rank = ranks[i];
510 shape = *shapes[i];
511 } else {
512 if (shape != *shapes[i]) {
513 // TODO: Rank compatibility was already checked but it seems to be
514 // the first place where the actual shapes are checked to be the
515 // same. Shouldn't this be checked elsewhere so that this is also
516 // checked for non constexpr call to elemental intrinsics function?
517 context.messages().Say(
518 "Arguments in elemental intrinsic function are not conformable"_err_en_US);
519 return Expr<TR>{std::move(funcRef)};
520 }
521 }
522 }
523 }
524 CHECK(rank == GetRank(shape));
525
526 // Compute all the scalar values of the results
527 std::vector<Scalar<TR>> results;
528 if (TotalElementCount(shape) > 0) {
529 ConstantBounds bounds{shape};
530 ConstantSubscripts index(rank, 1);
531 do {
532 if constexpr (std::is_same_v<WrapperType<TR, TA...>,
533 ScalarFuncWithContext<TR, TA...>>) {
534 results.emplace_back(func(context,
535 (ranks[I] ? std::get<I>(*args)->At(index)
536 : std::get<I>(*args)->GetScalarValue().value())...));
537 } else if constexpr (std::is_same_v<WrapperType<TR, TA...>,
538 ScalarFunc<TR, TA...>>) {
539 results.emplace_back(func(
540 (ranks[I] ? std::get<I>(*args)->At(index)
541 : std::get<I>(*args)->GetScalarValue().value())...));
542 }
543 } while (bounds.IncrementSubscripts(index));
544 }
545 // Build and return constant result
546 if constexpr (TR::category == TypeCategory::Character) {
547 auto len{static_cast<ConstantSubscript>(
548 results.size() ? results[0].length() : 0)};
549 return Expr<TR>{Constant<TR>{len, std::move(results), std::move(shape)}};
550 } else {
551 return Expr<TR>{Constant<TR>{std::move(results), std::move(shape)}};
552 }
553 }
554 return Expr<TR>{std::move(funcRef)};
555 }
556
557 template <typename TR, typename... TA>
558 Expr<TR> FoldElementalIntrinsic(FoldingContext &context,
559 FunctionRef<TR> &&funcRef, ScalarFunc<TR, TA...> func) {
560 return FoldElementalIntrinsicHelper<ScalarFunc, TR, TA...>(
561 context, std::move(funcRef), func, std::index_sequence_for<TA...>{});
562 }
563 template <typename TR, typename... TA>
564 Expr<TR> FoldElementalIntrinsic(FoldingContext &context,
565 FunctionRef<TR> &&funcRef, ScalarFuncWithContext<TR, TA...> func) {
566 return FoldElementalIntrinsicHelper<ScalarFuncWithContext, TR, TA...>(
567 context, std::move(funcRef), func, std::index_sequence_for<TA...>{});
568 }
569
570 std::optional<std::int64_t> GetInt64Arg(const std::optional<ActualArgument> &);
571 std::optional<std::int64_t> GetInt64ArgOr(
572 const std::optional<ActualArgument> &, std::int64_t defaultValue);
573
574 template <typename A, typename B>
575 std::optional<std::vector<A>> GetIntegerVector(const B &x) {
576 static_assert(std::is_integral_v<A>);
577 if (const auto *someInteger{UnwrapExpr<Expr<SomeInteger>>(x)}) {
578 return std::visit(
579 [](const auto &typedExpr) -> std::optional<std::vector<A>> {
580 using T = ResultType<decltype(typedExpr)>;
581 if (const auto *constant{UnwrapConstantValue<T>(typedExpr)}) {
582 if (constant->Rank() == 1) {
583 std::vector<A> result;
584 for (const auto &value : constant->values()) {
585 result.push_back(static_cast<A>(value.ToInt64()));
586 }
587 return result;
588 }
589 }
590 return std::nullopt;
591 },
592 someInteger->u);
593 }
594 return std::nullopt;
595 }
596
597 // Transform an intrinsic function reference that contains user errors
598 // into an intrinsic with the same characteristic but the "invalid" name.
599 // This to prevent generating warnings over and over if the expression
600 // gets re-folded.
601 template <typename T> Expr<T> MakeInvalidIntrinsic(FunctionRef<T> &&funcRef) {
602 SpecificIntrinsic invalid{std::get<SpecificIntrinsic>(funcRef.proc().u)};
603 invalid.name = "(invalid intrinsic function call)";
604 return Expr<T>{FunctionRef<T>{ProcedureDesignator{std::move(invalid)},
605 ActualArguments{ActualArgument{AsGenericExpr(std::move(funcRef))}}}};
606 }
607
608 template <typename T> Expr<T> Folder<T>::Reshape(FunctionRef<T> &&funcRef) {
609 auto args{funcRef.arguments()};
610 CHECK(args.size() == 4);
611 const auto *source{UnwrapConstantValue<T>(args[0])};
612 const auto *pad{UnwrapConstantValue<T>(args[2])};
613 std::optional<std::vector<ConstantSubscript>> shape{
614 GetIntegerVector<ConstantSubscript>(args[1])};
615 std::optional<std::vector<int>> order{GetIntegerVector<int>(args[3])};
616 if (!source || !shape || (args[2] && !pad) || (args[3] && !order)) {
617 return Expr<T>{std::move(funcRef)}; // Non-constant arguments
618 } else if (!IsValidShape(shape.value())) {
619 context_.messages().Say("Invalid SHAPE in RESHAPE"_en_US);
620 } else {
621 int rank{GetRank(shape.value())};
622 std::size_t resultElements{TotalElementCount(shape.value())};
623 std::optional<std::vector<int>> dimOrder;
624 if (order) {
625 dimOrder = ValidateDimensionOrder(rank, *order);
626 }
627 std::vector<int> *dimOrderPtr{dimOrder ? &dimOrder.value() : nullptr};
628 if (order && !dimOrder) {
629 context_.messages().Say("Invalid ORDER in RESHAPE"_en_US);
630 } else if (resultElements > source->size() && (!pad || pad->empty())) {
631 context_.messages().Say("Too few SOURCE elements in RESHAPE and PAD"
632 "is not present or has null size"_en_US);
633 } else {
634 Constant<T> result{!source->empty()
635 ? source->Reshape(std::move(shape.value()))
636 : pad->Reshape(std::move(shape.value()))};
637 ConstantSubscripts subscripts{result.lbounds()};
638 auto copied{result.CopyFrom(*source,
639 std::min(source->size(), resultElements), subscripts, dimOrderPtr)};
640 if (copied < resultElements) {
641 CHECK(pad);
642 copied += result.CopyFrom(
643 *pad, resultElements - copied, subscripts, dimOrderPtr);
644 }
645 CHECK(copied == resultElements);
646 return Expr<T>{std::move(result)};
647 }
648 }
649 // Invalid, prevent re-folding
650 return MakeInvalidIntrinsic(std::move(funcRef));
651 }
652
653 template <typename T>
654 Expr<T> FoldMINorMAX(
655 FoldingContext &context, FunctionRef<T> &&funcRef, Ordering order) {
656 std::vector<Constant<T> *> constantArgs;
657 // Call Folding on all arguments, even if some are not constant,
658 // to make operand promotion explicit.
659 for (auto &arg : funcRef.arguments()) {
660 if (auto *cst{Folder<T>{context}.Folding(arg)}) {
661 constantArgs.push_back(cst);
662 }
663 }
664 if (constantArgs.size() != funcRef.arguments().size())
665 return Expr<T>(std::move(funcRef));
666 CHECK(constantArgs.size() > 0);
667 Expr<T> result{std::move(*constantArgs[0])};
668 for (std::size_t i{1}; i < constantArgs.size(); ++i) {
669 Extremum<T> extremum{order, result, Expr<T>{std::move(*constantArgs[i])}};
670 result = FoldOperation(context, std::move(extremum));
671 }
672 return result;
673 }
674
675 // For AMAX0, AMIN0, AMAX1, AMIN1, DMAX1, DMIN1, MAX0, MIN0, MAX1, and MIN1
676 // a special care has to be taken to insert the conversion on the result
677 // of the MIN/MAX. This is made slightly more complex by the extension
678 // supported by f18 that arguments may have different kinds. This implies
679 // that the created MIN/MAX result type cannot be deduced from the standard but
680 // has to be deduced from the arguments.
681 // e.g. AMAX0(int8, int4) is rewritten to REAL(MAX(int8, INT(int4, 8)))).
682 template <typename T>
683 Expr<T> RewriteSpecificMINorMAX(
684 FoldingContext &context, FunctionRef<T> &&funcRef) {
685 ActualArguments &args{funcRef.arguments()};
686 auto &intrinsic{DEREF(std::get_if<SpecificIntrinsic>(&funcRef.proc().u))};
687 // Rewrite MAX1(args) to INT(MAX(args)) and fold. Same logic for MIN1.
688 // Find result type for max/min based on the arguments.
689 DynamicType resultType{args[0].value().GetType().value()};
690 auto *resultTypeArg{&args[0]};
691 for (auto j{args.size() - 1}; j > 0; --j) {
692 DynamicType type{args[j].value().GetType().value()};
693 if (type.category() == resultType.category()) {
694 if (type.kind() > resultType.kind()) {
695 resultTypeArg = &args[j];
696 resultType = type;
697 }
698 } else if (resultType.category() == TypeCategory::Integer) {
699 // Handle mixed real/integer arguments: all the previous arguments were
700 // integers and this one is real. The type of the MAX/MIN result will
701 // be the one of the real argument.
702 resultTypeArg = &args[j];
703 resultType = type;
704 }
705 }
706 intrinsic.name =
707 intrinsic.name.find("max") != std::string::npos ? "max"s : "min"s;
708 intrinsic.characteristics.value().functionResult.value().SetType(resultType);
709 auto insertConversion{[&](const auto &x) -> Expr<T> {
710 using TR = ResultType<decltype(x)>;
711 FunctionRef<TR> maxRef{std::move(funcRef.proc()), std::move(args)};
712 return Fold(context, ConvertToType<T>(AsCategoryExpr(std::move(maxRef))));
713 }};
714 if (auto *sx{UnwrapExpr<Expr<SomeReal>>(*resultTypeArg)}) {
715 return std::visit(insertConversion, sx->u);
716 }
717 auto &sx{DEREF(UnwrapExpr<Expr<SomeInteger>>(*resultTypeArg))};
718 return std::visit(insertConversion, sx.u);
719 }
720
721 template <typename T>
722 Expr<T> FoldOperation(FoldingContext &context, FunctionRef<T> &&funcRef) {
723 ActualArguments &args{funcRef.arguments()};
724 for (std::optional<ActualArgument> &arg : args) {
725 if (auto *expr{UnwrapExpr<Expr<SomeType>>(arg)}) {
726 *expr = Fold(context, std::move(*expr));
727 }
728 }
729 if (auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)}) {
730 const std::string name{intrinsic->name};
731 if (name == "reshape") {
732 return Folder<T>{context}.Reshape(std::move(funcRef));
733 }
734 // TODO: other type independent transformationals
735 if constexpr (!std::is_same_v<T, SomeDerived>) {
736 return FoldIntrinsicFunction(context, std::move(funcRef));
737 }
738 }
739 return Expr<T>{std::move(funcRef)};
740 }
741
742 template <typename T>
743 Expr<T> FoldMerge(FoldingContext &context, FunctionRef<T> &&funcRef) {
744 return FoldElementalIntrinsic<T, T, T, LogicalResult>(context,
745 std::move(funcRef),
746 ScalarFunc<T, T, T, LogicalResult>(
747 [](const Scalar<T> &ifTrue, const Scalar<T> &ifFalse,
748 const Scalar<LogicalResult> &predicate) -> Scalar<T> {
749 return predicate.IsTrue() ? ifTrue : ifFalse;
750 }));
751 }
752
753 Expr<ImpliedDoIndex::Result> FoldOperation(FoldingContext &, ImpliedDoIndex &&);
754
755 // Array constructor folding
756 template <typename T> class ArrayConstructorFolder {
757 public:
758 explicit ArrayConstructorFolder(const FoldingContext &c) : context_{c} {}
759
760 Expr<T> FoldArray(ArrayConstructor<T> &&array) {
761 // Calls FoldArray(const ArrayConstructorValues<T> &) below
762 if (FoldArray(array)) {
763 auto n{static_cast<ConstantSubscript>(elements_.size())};
764 if constexpr (std::is_same_v<T, SomeDerived>) {
765 return Expr<T>{Constant<T>{array.GetType().GetDerivedTypeSpec(),
766 std::move(elements_), ConstantSubscripts{n}}};
767 } else if constexpr (T::category == TypeCategory::Character) {
768 auto length{Fold(context_, common::Clone(array.LEN()))};
769 if (std::optional<ConstantSubscript> lengthValue{ToInt64(length)}) {
770 return Expr<T>{Constant<T>{
771 *lengthValue, std::move(elements_), ConstantSubscripts{n}}};
772 }
773 } else {
774 return Expr<T>{
775 Constant<T>{std::move(elements_), ConstantSubscripts{n}}};
776 }
777 }
778 return Expr<T>{std::move(array)};
779 }
780
781 private:
782 bool FoldArray(const common::CopyableIndirection<Expr<T>> &expr) {
783 Expr<T> folded{Fold(context_, common::Clone(expr.value()))};
784 if (const auto *c{UnwrapConstantValue<T>(folded)}) {
785 // Copy elements in Fortran array element order
786 ConstantSubscripts shape{c->shape()};
787 int rank{c->Rank()};
788 ConstantSubscripts index(GetRank(shape), 1);
789 for (std::size_t n{c->size()}; n-- > 0;) {
790 elements_.emplace_back(c->At(index));
791 for (int d{0}; d < rank; ++d) {
792 if (++index[d] <= shape[d]) {
793 break;
794 }
795 index[d] = 1;
796 }
797 }
798 return true;
799 } else {
800 return false;
801 }
802 }
803 bool FoldArray(const ImpliedDo<T> &iDo) {
804 Expr<SubscriptInteger> lower{
805 Fold(context_, Expr<SubscriptInteger>{iDo.lower()})};
806 Expr<SubscriptInteger> upper{
807 Fold(context_, Expr<SubscriptInteger>{iDo.upper()})};
808 Expr<SubscriptInteger> stride{
809 Fold(context_, Expr<SubscriptInteger>{iDo.stride()})};
810 std::optional<ConstantSubscript> start{ToInt64(lower)}, end{ToInt64(upper)},
811 step{ToInt64(stride)};
812 if (start && end && step && *step != 0) {
813 bool result{true};
814 ConstantSubscript &j{context_.StartImpliedDo(iDo.name(), *start)};
815 if (*step > 0) {
816 for (; j <= *end; j += *step) {
817 result &= FoldArray(iDo.values());
818 }
819 } else {
820 for (; j >= *end; j += *step) {
821 result &= FoldArray(iDo.values());
822 }
823 }
824 context_.EndImpliedDo(iDo.name());
825 return result;
826 } else {
827 return false;
828 }
829 }
830 bool FoldArray(const ArrayConstructorValue<T> &x) {
831 return std::visit([&](const auto &y) { return FoldArray(y); }, x.u);
832 }
833 bool FoldArray(const ArrayConstructorValues<T> &xs) {
834 for (const auto &x : xs) {
835 if (!FoldArray(x)) {
836 return false;
837 }
838 }
839 return true;
840 }
841
842 FoldingContext context_;
843 std::vector<Scalar<T>> elements_;
844 };
845
846 template <typename T>
847 Expr<T> FoldOperation(FoldingContext &context, ArrayConstructor<T> &&array) {
848 return ArrayConstructorFolder<T>{context}.FoldArray(std::move(array));
849 }
850
851 // Array operation elemental application: When all operands to an operation
852 // are constant arrays, array constructors without any implied DO loops,
853 // &/or expanded scalars, pull the operation "into" the array result by
854 // applying it in an elementwise fashion. For example, [A,1]+[B,2]
855 // is rewritten into [A+B,1+2] and then partially folded to [A+B,3].
856
857 // If possible, restructures an array expression into an array constructor
858 // that comprises a "flat" ArrayConstructorValues with no implied DO loops.
859 template <typename T>
860 bool ArrayConstructorIsFlat(const ArrayConstructorValues<T> &values) {
861 for (const ArrayConstructorValue<T> &x : values) {
862 if (!std::holds_alternative<Expr<T>>(x.u)) {
863 return false;
864 }
865 }
866 return true;
867 }
868
869 template <typename T>
870 std::optional<Expr<T>> AsFlatArrayConstructor(const Expr<T> &expr) {
871 if (const auto *c{UnwrapConstantValue<T>(expr)}) {
872 ArrayConstructor<T> result{expr};
873 if (c->size() > 0) {
874 ConstantSubscripts at{c->lbounds()};
875 do {
876 result.Push(Expr<T>{Constant<T>{c->At(at)}});
877 } while (c->IncrementSubscripts(at));
878 }
879 return std::make_optional<Expr<T>>(std::move(result));
880 } else if (const auto *a{UnwrapExpr<ArrayConstructor<T>>(expr)}) {
881 if (ArrayConstructorIsFlat(*a)) {
882 return std::make_optional<Expr<T>>(expr);
883 }
884 } else if (const auto *p{UnwrapExpr<Parentheses<T>>(expr)}) {
885 return AsFlatArrayConstructor(Expr<T>{p->left()});
886 }
887 return std::nullopt;
888 }
889
890 template <TypeCategory CAT>
891 std::enable_if_t<CAT != TypeCategory::Derived,
892 std::optional<Expr<SomeKind<CAT>>>>
893 AsFlatArrayConstructor(const Expr<SomeKind<CAT>> &expr) {
894 return std::visit(
895 [&](const auto &kindExpr) -> std::optional<Expr<SomeKind<CAT>>> {
896 if (auto flattened{AsFlatArrayConstructor(kindExpr)}) {
897 return Expr<SomeKind<CAT>>{std::move(*flattened)};
898 } else {
899 return std::nullopt;
900 }
901 },
902 expr.u);
903 }
904
905 // FromArrayConstructor is a subroutine for MapOperation() below.
906 // Given a flat ArrayConstructor<T> and a shape, it wraps the array
907 // into an Expr<T>, folds it, and returns the resulting wrapped
908 // array constructor or constant array value.
909 template <typename T>
910 Expr<T> FromArrayConstructor(FoldingContext &context,
911 ArrayConstructor<T> &&values, std::optional<ConstantSubscripts> &&shape) {
912 Expr<T> result{Fold(context, Expr<T>{std::move(values)})};
913 if (shape) {
914 if (auto *constant{UnwrapConstantValue<T>(result)}) {
915 return Expr<T>{constant->Reshape(std::move(*shape))};
916 }
917 }
918 return result;
919 }
920
921 // MapOperation is a utility for various specializations of ApplyElementwise()
922 // that follow. Given one or two flat ArrayConstructor<OPERAND> (wrapped in an
923 // Expr<OPERAND>) for some specific operand type(s), apply a given function f
924 // to each of their corresponding elements to produce a flat
925 // ArrayConstructor<RESULT> (wrapped in an Expr<RESULT>).
926 // Preserves shape.
927
928 // Unary case
929 template <typename RESULT, typename OPERAND>
930 Expr<RESULT> MapOperation(FoldingContext &context,
931 std::function<Expr<RESULT>(Expr<OPERAND> &&)> &&f, const Shape &shape,
932 Expr<OPERAND> &&values) {
933 ArrayConstructor<RESULT> result{values};
934 if constexpr (common::HasMember<OPERAND, AllIntrinsicCategoryTypes>) {
935 std::visit(
936 [&](auto &&kindExpr) {
937 using kindType = ResultType<decltype(kindExpr)>;
938 auto &aConst{std::get<ArrayConstructor<kindType>>(kindExpr.u)};
939 for (auto &acValue : aConst) {
940 auto &scalar{std::get<Expr<kindType>>(acValue.u)};
941 result.Push(Fold(context, f(Expr<OPERAND>{std::move(scalar)})));
942 }
943 },
944 std::move(values.u));
945 } else {
946 auto &aConst{std::get<ArrayConstructor<OPERAND>>(values.u)};
947 for (auto &acValue : aConst) {
948 auto &scalar{std::get<Expr<OPERAND>>(acValue.u)};
949 result.Push(Fold(context, f(std::move(scalar))));
950 }
951 }
952 return FromArrayConstructor(
953 context, std::move(result), AsConstantExtents(context, shape));
954 }
955
956 // array * array case
957 template <typename RESULT, typename LEFT, typename RIGHT>
958 Expr<RESULT> MapOperation(FoldingContext &context,
959 std::function<Expr<RESULT>(Expr<LEFT> &&, Expr<RIGHT> &&)> &&f,
960 const Shape &shape, Expr<LEFT> &&leftValues, Expr<RIGHT> &&rightValues) {
961 ArrayConstructor<RESULT> result{leftValues};
962 auto &leftArrConst{std::get<ArrayConstructor<LEFT>>(leftValues.u)};
963 if constexpr (common::HasMember<RIGHT, AllIntrinsicCategoryTypes>) {
964 std::visit(
965 [&](auto &&kindExpr) {
966 using kindType = ResultType<decltype(kindExpr)>;
967
968 auto &rightArrConst{std::get<ArrayConstructor<kindType>>(kindExpr.u)};
969 auto rightIter{rightArrConst.begin()};
970 for (auto &leftValue : leftArrConst) {
971 CHECK(rightIter != rightArrConst.end());
972 auto &leftScalar{std::get<Expr<LEFT>>(leftValue.u)};
973 auto &rightScalar{std::get<Expr<kindType>>(rightIter->u)};
974 result.Push(Fold(context,
975 f(std::move(leftScalar), Expr<RIGHT>{std::move(rightScalar)})));
976 ++rightIter;
977 }
978 },
979 std::move(rightValues.u));
980 } else {
981 auto &rightArrConst{std::get<ArrayConstructor<RIGHT>>(rightValues.u)};
982 auto rightIter{rightArrConst.begin()};
983 for (auto &leftValue : leftArrConst) {
984 CHECK(rightIter != rightArrConst.end());
985 auto &leftScalar{std::get<Expr<LEFT>>(leftValue.u)};
986 auto &rightScalar{std::get<Expr<RIGHT>>(rightIter->u)};
987 result.Push(
988 Fold(context, f(std::move(leftScalar), std::move(rightScalar))));
989 ++rightIter;
990 }
991 }
992 return FromArrayConstructor(
993 context, std::move(result), AsConstantExtents(context, shape));
994 }
995
996 // array * scalar case
997 template <typename RESULT, typename LEFT, typename RIGHT>
998 Expr<RESULT> MapOperation(FoldingContext &context,
999 std::function<Expr<RESULT>(Expr<LEFT> &&, Expr<RIGHT> &&)> &&f,
1000 const Shape &shape, Expr<LEFT> &&leftValues,
1001 const Expr<RIGHT> &rightScalar) {
1002 ArrayConstructor<RESULT> result{leftValues};
1003 auto &leftArrConst{std::get<ArrayConstructor<LEFT>>(leftValues.u)};
1004 for (auto &leftValue : leftArrConst) {
1005 auto &leftScalar{std::get<Expr<LEFT>>(leftValue.u)};
1006 result.Push(
1007 Fold(context, f(std::move(leftScalar), Expr<RIGHT>{rightScalar})));
1008 }
1009 return FromArrayConstructor(
1010 context, std::move(result), AsConstantExtents(context, shape));
1011 }
1012
1013 // scalar * array case
1014 template <typename RESULT, typename LEFT, typename RIGHT>
1015 Expr<RESULT> MapOperation(FoldingContext &context,
1016 std::function<Expr<RESULT>(Expr<LEFT> &&, Expr<RIGHT> &&)> &&f,
1017 const Shape &shape, const Expr<LEFT> &leftScalar,
1018 Expr<RIGHT> &&rightValues) {
1019 ArrayConstructor<RESULT> result{leftScalar};
1020 if constexpr (common::HasMember<RIGHT, AllIntrinsicCategoryTypes>) {
1021 std::visit(
1022 [&](auto &&kindExpr) {
1023 using kindType = ResultType<decltype(kindExpr)>;
1024 auto &rightArrConst{std::get<ArrayConstructor<kindType>>(kindExpr.u)};
1025 for (auto &rightValue : rightArrConst) {
1026 auto &rightScalar{std::get<Expr<kindType>>(rightValue.u)};
1027 result.Push(Fold(context,
1028 f(Expr<LEFT>{leftScalar},
1029 Expr<RIGHT>{std::move(rightScalar)})));
1030 }
1031 },
1032 std::move(rightValues.u));
1033 } else {
1034 auto &rightArrConst{std::get<ArrayConstructor<RIGHT>>(rightValues.u)};
1035 for (auto &rightValue : rightArrConst) {
1036 auto &rightScalar{std::get<Expr<RIGHT>>(rightValue.u)};
1037 result.Push(
1038 Fold(context, f(Expr<LEFT>{leftScalar}, std::move(rightScalar))));
1039 }
1040 }
1041 return FromArrayConstructor(
1042 context, std::move(result), AsConstantExtents(context, shape));
1043 }
1044
1045 // ApplyElementwise() recursively folds the operand expression(s) of an
1046 // operation, then attempts to apply the operation to the (corresponding)
1047 // scalar element(s) of those operands. Returns std::nullopt for scalars
1048 // or unlinearizable operands.
1049 template <typename DERIVED, typename RESULT, typename OPERAND>
1050 auto ApplyElementwise(FoldingContext &context,
1051 Operation<DERIVED, RESULT, OPERAND> &operation,
1052 std::function<Expr<RESULT>(Expr<OPERAND> &&)> &&f)
1053 -> std::optional<Expr<RESULT>> {
1054 auto &expr{operation.left()};
1055 expr = Fold(context, std::move(expr));
1056 if (expr.Rank() > 0) {
1057 if (std::optional<Shape> shape{GetShape(context, expr)}) {
1058 if (auto values{AsFlatArrayConstructor(expr)}) {
1059 return MapOperation(context, std::move(f), *shape, std::move(*values));
1060 }
1061 }
1062 }
1063 return std::nullopt;
1064 }
1065
1066 template <typename DERIVED, typename RESULT, typename OPERAND>
1067 auto ApplyElementwise(
1068 FoldingContext &context, Operation<DERIVED, RESULT, OPERAND> &operation)
1069 -> std::optional<Expr<RESULT>> {
1070 return ApplyElementwise(context, operation,
1071 std::function<Expr<RESULT>(Expr<OPERAND> &&)>{
1072 [](Expr<OPERAND> &&operand) {
1073 return Expr<RESULT>{DERIVED{std::move(operand)}};
1074 }});
1075 }
1076
1077 template <typename DERIVED, typename RESULT, typename LEFT, typename RIGHT>
1078 auto ApplyElementwise(FoldingContext &context,
1079 Operation<DERIVED, RESULT, LEFT, RIGHT> &operation,
1080 std::function<Expr<RESULT>(Expr<LEFT> &&, Expr<RIGHT> &&)> &&f)
1081 -> std::optional<Expr<RESULT>> {
1082 auto &leftExpr{operation.left()};
1083 leftExpr = Fold(context, std::move(leftExpr));
1084 auto &rightExpr{operation.right()};
1085 rightExpr = Fold(context, std::move(rightExpr));
1086 if (leftExpr.Rank() > 0) {
1087 if (std::optional<Shape> leftShape{GetShape(context, leftExpr)}) {
1088 if (auto left{AsFlatArrayConstructor(leftExpr)}) {
1089 if (rightExpr.Rank() > 0) {
1090 if (std::optional<Shape> rightShape{GetShape(context, rightExpr)}) {
1091 if (auto right{AsFlatArrayConstructor(rightExpr)}) {
1092 CheckConformance(context.messages(), *leftShape, *rightShape);
1093 return MapOperation(context, std::move(f), *leftShape,
1094 std::move(*left), std::move(*right));
1095 }
1096 }
1097 } else if (IsExpandableScalar(rightExpr)) {
1098 return MapOperation(
1099 context, std::move(f), *leftShape, std::move(*left), rightExpr);
1100 }
1101 }
1102 }
1103 } else if (rightExpr.Rank() > 0 && IsExpandableScalar(leftExpr)) {
1104 if (std::optional<Shape> shape{GetShape(context, rightExpr)}) {
1105 if (auto right{AsFlatArrayConstructor(rightExpr)}) {
1106 return MapOperation(
1107 context, std::move(f), *shape, leftExpr, std::move(*right));
1108 }
1109 }
1110 }
1111 return std::nullopt;
1112 }
1113
1114 template <typename DERIVED, typename RESULT, typename LEFT, typename RIGHT>
1115 auto ApplyElementwise(
1116 FoldingContext &context, Operation<DERIVED, RESULT, LEFT, RIGHT> &operation)
1117 -> std::optional<Expr<RESULT>> {
1118 return ApplyElementwise(context, operation,
1119 std::function<Expr<RESULT>(Expr<LEFT> &&, Expr<RIGHT> &&)>{
1120 [](Expr<LEFT> &&left, Expr<RIGHT> &&right) {
1121 return Expr<RESULT>{DERIVED{std::move(left), std::move(right)}};
1122 }});
1123 }
1124
1125 // Unary operations
1126
1127 template <typename TO, typename FROM>
1128 common::IfNoLvalue<std::optional<TO>, FROM> ConvertString(FROM &&s) {
1129 if constexpr (std::is_same_v<TO, FROM>) {
1130 return std::make_optional<TO>(std::move(s));
1131 } else {
1132 // Fortran character conversion is well defined between distinct kinds
1133 // only when the actual characters are valid 7-bit ASCII.
1134 TO str;
1135 for (auto iter{s.cbegin()}; iter != s.cend(); ++iter) {
1136 if (static_cast<std::uint64_t>(*iter) > 127) {
1137 return std::nullopt;
1138 }
1139 str.push_back(*iter);
1140 }
1141 return std::make_optional<TO>(std::move(str));
1142 }
1143 }
1144
1145 template <typename TO, TypeCategory FROMCAT>
1146 Expr<TO> FoldOperation(
1147 FoldingContext &context, Convert<TO, FROMCAT> &&convert) {
1148 if (auto array{ApplyElementwise(context, convert)}) {
1149 return *array;
1150 }
1151 return std::visit(
1152 [&](auto &kindExpr) -> Expr<TO> {
1153 using Operand = ResultType<decltype(kindExpr)>;
1154 char buffer[64];
1155 if (auto value{GetScalarConstantValue<Operand>(kindExpr)}) {
1156 if constexpr (TO::category == TypeCategory::Integer) {
1157 if constexpr (Operand::category == TypeCategory::Integer) {
1158 auto converted{Scalar<TO>::ConvertSigned(*value)};
1159 if (converted.overflow) {
1160 context.messages().Say(
1161 "INTEGER(%d) to INTEGER(%d) conversion overflowed"_en_US,
1162 Operand::kind, TO::kind);
1163 }
1164 return ScalarConstantToExpr(std::move(converted.value));
1165 } else if constexpr (Operand::category == TypeCategory::Real) {
1166 auto converted{value->template ToInteger<Scalar<TO>>()};
1167 if (converted.flags.test(RealFlag::InvalidArgument)) {
1168 context.messages().Say(
1169 "REAL(%d) to INTEGER(%d) conversion: invalid argument"_en_US,
1170 Operand::kind, TO::kind);
1171 } else if (converted.flags.test(RealFlag::Overflow)) {
1172 context.messages().Say(
1173 "REAL(%d) to INTEGER(%d) conversion overflowed"_en_US,
1174 Operand::kind, TO::kind);
1175 }
1176 return ScalarConstantToExpr(std::move(converted.value));
1177 }
1178 } else if constexpr (TO::category == TypeCategory::Real) {
1179 if constexpr (Operand::category == TypeCategory::Integer) {
1180 auto converted{Scalar<TO>::FromInteger(*value)};
1181 if (!converted.flags.empty()) {
1182 std::snprintf(buffer, sizeof buffer,
1183 "INTEGER(%d) to REAL(%d) conversion", Operand::kind,
1184 TO::kind);
1185 RealFlagWarnings(context, converted.flags, buffer);
1186 }
1187 return ScalarConstantToExpr(std::move(converted.value));
1188 } else if constexpr (Operand::category == TypeCategory::Real) {
1189 auto converted{Scalar<TO>::Convert(*value)};
1190 if (!converted.flags.empty()) {
1191 std::snprintf(buffer, sizeof buffer,
1192 "REAL(%d) to REAL(%d) conversion", Operand::kind, TO::kind);
1193 RealFlagWarnings(context, converted.flags, buffer);
1194 }
1195 if (context.flushSubnormalsToZero()) {
1196 converted.value = converted.value.FlushSubnormalToZero();
1197 }
1198 return ScalarConstantToExpr(std::move(converted.value));
1199 }
1200 } else if constexpr (TO::category == TypeCategory::Character &&
1201 Operand::category == TypeCategory::Character) {
1202 if (auto converted{ConvertString<Scalar<TO>>(std::move(*value))}) {
1203 return ScalarConstantToExpr(std::move(*converted));
1204 }
1205 } else if constexpr (TO::category == TypeCategory::Logical &&
1206 Operand::category == TypeCategory::Logical) {
1207 return Expr<TO>{value->IsTrue()};
1208 }
1209 } else if constexpr (std::is_same_v<Operand, TO> &&
1210 FROMCAT != TypeCategory::Character) {
1211 return std::move(kindExpr); // remove needless conversion
1212 }
1213 return Expr<TO>{std::move(convert)};
1214 },
1215 convert.left().u);
1216 }
1217
1218 template <typename T>
1219 Expr<T> FoldOperation(FoldingContext &context, Parentheses<T> &&x) {
1220 auto &operand{x.left()};
1221 operand = Fold(context, std::move(operand));
1222 if (auto value{GetScalarConstantValue<T>(operand)}) {
1223 // Preserve parentheses, even around constants.
1224 return Expr<T>{Parentheses<T>{Expr<T>{Constant<T>{*value}}}};
1225 } else if (std::holds_alternative<Parentheses<T>>(operand.u)) {
1226 // ((x)) -> (x)
1227 return std::move(operand);
1228 } else {
1229 return Expr<T>{Parentheses<T>{std::move(operand)}};
1230 }
1231 }
1232
1233 template <typename T>
1234 Expr<T> FoldOperation(FoldingContext &context, Negate<T> &&x) {
1235 if (auto array{ApplyElementwise(context, x)}) {
1236 return *array;
1237 }
1238 auto &operand{x.left()};
1239 if (auto value{GetScalarConstantValue<T>(operand)}) {
1240 if constexpr (T::category == TypeCategory::Integer) {
1241 auto negated{value->Negate()};
1242 if (negated.overflow) {
1243 context.messages().Say(
1244 "INTEGER(%d) negation overflowed"_en_US, T::kind);
1245 }
1246 return Expr<T>{Constant<T>{std::move(negated.value)}};
1247 } else {
1248 // REAL & COMPLEX negation: no exceptions possible
1249 return Expr<T>{Constant<T>{value->Negate()}};
1250 }
1251 }
1252 return Expr<T>{std::move(x)};
1253 }
1254
1255 // Binary (dyadic) operations
1256
1257 template <typename LEFT, typename RIGHT>
1258 std::optional<std::pair<Scalar<LEFT>, Scalar<RIGHT>>> OperandsAreConstants(
1259 const Expr<LEFT> &x, const Expr<RIGHT> &y) {
1260 if (auto xvalue{GetScalarConstantValue<LEFT>(x)}) {
1261 if (auto yvalue{GetScalarConstantValue<RIGHT>(y)}) {
1262 return {std::make_pair(*xvalue, *yvalue)};
1263 }
1264 }
1265 return std::nullopt;
1266 }
1267
1268 template <typename DERIVED, typename RESULT, typename LEFT, typename RIGHT>
1269 std::optional<std::pair<Scalar<LEFT>, Scalar<RIGHT>>> OperandsAreConstants(
1270 const Operation<DERIVED, RESULT, LEFT, RIGHT> &operation) {
1271 return OperandsAreConstants(operation.left(), operation.right());
1272 }
1273
1274 template <typename T>
1275 Expr<T> FoldOperation(FoldingContext &context, Add<T> &&x) {
1276 if (auto array{ApplyElementwise(context, x)}) {
1277 return *array;
1278 }
1279 if (auto folded{OperandsAreConstants(x)}) {
1280 if constexpr (T::category == TypeCategory::Integer) {
1281 auto sum{folded->first.AddSigned(folded->second)};
1282 if (sum.overflow) {
1283 context.messages().Say(
1284 "INTEGER(%d) addition overflowed"_en_US, T::kind);
1285 }
1286 return Expr<T>{Constant<T>{sum.value}};
1287 } else {
1288 auto sum{folded->first.Add(folded->second, context.rounding())};
1289 RealFlagWarnings(context, sum.flags, "addition");
1290 if (context.flushSubnormalsToZero()) {
1291 sum.value = sum.value.FlushSubnormalToZero();
1292 }
1293 return Expr<T>{Constant<T>{sum.value}};
1294 }
1295 }
1296 return Expr<T>{std::move(x)};
1297 }
1298
1299 template <typename T>
1300 Expr<T> FoldOperation(FoldingContext &context, Subtract<T> &&x) {
1301 if (auto array{ApplyElementwise(context, x)}) {
1302 return *array;
1303 }
1304 if (auto folded{OperandsAreConstants(x)}) {
1305 if constexpr (T::category == TypeCategory::Integer) {
1306 auto difference{folded->first.SubtractSigned(folded->second)};
1307 if (difference.overflow) {
1308 context.messages().Say(
1309 "INTEGER(%d) subtraction overflowed"_en_US, T::kind);
1310 }
1311 return Expr<T>{Constant<T>{difference.value}};
1312 } else {
1313 auto difference{
1314 folded->first.Subtract(folded->second, context.rounding())};
1315 RealFlagWarnings(context, difference.flags, "subtraction");
1316 if (context.flushSubnormalsToZero()) {
1317 difference.value = difference.value.FlushSubnormalToZero();
1318 }
1319 return Expr<T>{Constant<T>{difference.value}};
1320 }
1321 }
1322 return Expr<T>{std::move(x)};
1323 }
1324
1325 template <typename T>
1326 Expr<T> FoldOperation(FoldingContext &context, Multiply<T> &&x) {
1327 if (auto array{ApplyElementwise(context, x)}) {
1328 return *array;
1329 }
1330 if (auto folded{OperandsAreConstants(x)}) {
1331 if constexpr (T::category == TypeCategory::Integer) {
1332 auto product{folded->first.MultiplySigned(folded->second)};
1333 if (product.SignedMultiplicationOverflowed()) {
1334 context.messages().Say(
1335 "INTEGER(%d) multiplication overflowed"_en_US, T::kind);
1336 }
1337 return Expr<T>{Constant<T>{product.lower}};
1338 } else {
1339 auto product{folded->first.Multiply(folded->second, context.rounding())};
1340 RealFlagWarnings(context, product.flags, "multiplication");
1341 if (context.flushSubnormalsToZero()) {
1342 product.value = product.value.FlushSubnormalToZero();
1343 }
1344 return Expr<T>{Constant<T>{product.value}};
1345 }
1346 }
1347 return Expr<T>{std::move(x)};
1348 }
1349
1350 template <typename T>
1351 Expr<T> FoldOperation(FoldingContext &context, Divide<T> &&x) {
1352 if (auto array{ApplyElementwise(context, x)}) {
1353 return *array;
1354 }
1355 if (auto folded{OperandsAreConstants(x)}) {
1356 if constexpr (T::category == TypeCategory::Integer) {
1357 auto quotAndRem{folded->first.DivideSigned(folded->second)};
1358 if (quotAndRem.divisionByZero) {
1359 context.messages().Say("INTEGER(%d) division by zero"_en_US, T::kind);
1360 return Expr<T>{std::move(x)};
1361 }
1362 if (quotAndRem.overflow) {
1363 context.messages().Say(
1364 "INTEGER(%d) division overflowed"_en_US, T::kind);
1365 }
1366 return Expr<T>{Constant<T>{quotAndRem.quotient}};
1367 } else {
1368 auto quotient{folded->first.Divide(folded->second, context.rounding())};
1369 RealFlagWarnings(context, quotient.flags, "division");
1370 if (context.flushSubnormalsToZero()) {
1371 quotient.value = quotient.value.FlushSubnormalToZero();
1372 }
1373 return Expr<T>{Constant<T>{quotient.value}};
1374 }
1375 }
1376 return Expr<T>{std::move(x)};
1377 }
1378
1379 template <typename T>
1380 Expr<T> FoldOperation(FoldingContext &context, Power<T> &&x) {
1381 if (auto array{ApplyElementwise(context, x)}) {
1382 return *array;
1383 }
1384 if (auto folded{OperandsAreConstants(x)}) {
1385 if constexpr (T::category == TypeCategory::Integer) {
1386 auto power{folded->first.Power(folded->second)};
1387 if (power.divisionByZero) {
1388 context.messages().Say(
1389 "INTEGER(%d) zero to negative power"_en_US, T::kind);
1390 } else if (power.overflow) {
1391 context.messages().Say("INTEGER(%d) power overflowed"_en_US, T::kind);
1392 } else if (power.zeroToZero) {
1393 context.messages().Say(
1394 "INTEGER(%d) 0**0 is not defined"_en_US, T::kind);
1395 }
1396 return Expr<T>{Constant<T>{power.power}};
1397 } else {
1398 if (auto callable{context.hostIntrinsicsLibrary()
1399 .GetHostProcedureWrapper<Scalar, T, T, T>("pow")}) {
1400 return Expr<T>{
1401 Constant<T>{(*callable)(context, folded->first, folded->second)}};
1402 } else {
1403 context.messages().Say(
1404 "Power for %s cannot be folded on host"_en_US, T{}.AsFortran());
1405 }
1406 }
1407 }
1408 return Expr<T>{std::move(x)};
1409 }
1410
1411 template <typename T>
1412 Expr<T> FoldOperation(FoldingContext &context, RealToIntPower<T> &&x) {
1413 if (auto array{ApplyElementwise(context, x)}) {
1414 return *array;
1415 }
1416 return std::visit(
1417 [&](auto &y) -> Expr<T> {
1418 if (auto folded{OperandsAreConstants(x.left(), y)}) {
1419 auto power{evaluate::IntPower(folded->first, folded->second)};
1420 RealFlagWarnings(context, power.flags, "power with INTEGER exponent");
1421 if (context.flushSubnormalsToZero()) {
1422 power.value = power.value.FlushSubnormalToZero();
1423 }
1424 return Expr<T>{Constant<T>{power.value}};
1425 } else {
1426 return Expr<T>{std::move(x)};
1427 }
1428 },
1429 x.right().u);
1430 }
1431
1432 template <typename T>
1433 Expr<T> FoldOperation(FoldingContext &context, Extremum<T> &&x) {
1434 if (auto array{ApplyElementwise(context, x,
1435 std::function<Expr<T>(Expr<T> &&, Expr<T> &&)>{[=](Expr<T> &&l,
1436 Expr<T> &&r) {
1437 return Expr<T>{Extremum<T>{x.ordering, std::move(l), std::move(r)}};
1438 }})}) {
1439 return *array;
1440 }
1441 if (auto folded{OperandsAreConstants(x)}) {
1442 if constexpr (T::category == TypeCategory::Integer) {
1443 if (folded->first.CompareSigned(folded->second) == x.ordering) {
1444 return Expr<T>{Constant<T>{folded->first}};
1445 }
1446 } else if constexpr (T::category == TypeCategory::Real) {
1447 if (folded->first.IsNotANumber() ||
1448 (folded->first.Compare(folded->second) == Relation::Less) ==
1449 (x.ordering == Ordering::Less)) {
1450 return Expr<T>{Constant<T>{folded->first}};
1451 }
1452 } else {
1453 static_assert(T::category == TypeCategory::Character);
1454 // Result of MIN and MAX on character has the length of
1455 // the longest argument.
1456 auto maxLen{std::max(folded->first.length(), folded->second.length())};
1457 bool isFirst{x.ordering == Compare(folded->first, folded->second)};
1458 auto res{isFirst ? std::move(folded->first) : std::move(folded->second)};
1459 res = res.length() == maxLen
1460 ? std::move(res)
1461 : CharacterUtils<T::kind>::Resize(res, maxLen);
1462 return Expr<T>{Constant<T>{std::move(res)}};
1463 }
1464 return Expr<T>{Constant<T>{folded->second}};
1465 }
1466 return Expr<T>{std::move(x)};
1467 }
1468
1469 template <int KIND>
1470 Expr<Type<TypeCategory::Real, KIND>> ToReal(
1471 FoldingContext &context, Expr<SomeType> &&expr) {
1472 using Result = Type<TypeCategory::Real, KIND>;
1473 std::optional<Expr<Result>> result;
1474 std::visit(
1475 [&](auto &&x) {
1476 using From = std::decay_t<decltype(x)>;
1477 if constexpr (std::is_same_v<From, BOZLiteralConstant>) {
1478 // Move the bits without any integer->real conversion
1479 From original{x};
1480 result = ConvertToType<Result>(std::move(x));
1481 const auto *constant{UnwrapExpr<Constant<Result>>(*result)};
1482 CHECK(constant);
1483 Scalar<Result> real{constant->GetScalarValue().value()};
1484 From converted{From::ConvertUnsigned(real.RawBits()).value};
1485 if (original != converted) { // C1601
1486 context.messages().Say(
1487 "Nonzero bits truncated from BOZ literal constant in REAL intrinsic"_en_US);
1488 }
1489 } else if constexpr (IsNumericCategoryExpr<From>()) {
1490 result = Fold(context, ConvertToType<Result>(std::move(x)));
1491 } else {
1492 common::die("ToReal: bad argument expression");
1493 }
1494 },
1495 std::move(expr.u));
1496 return result.value();
1497 }
1498
1499 template <typename T>
1500 Expr<T> ExpressionBase<T>::Rewrite(FoldingContext &context, Expr<T> &&expr) {
1501 return std::visit(
1502 [&](auto &&x) -> Expr<T> {
1503 if constexpr (IsSpecificIntrinsicType<T>) {
1504 return FoldOperation(context, std::move(x));
1505 } else if constexpr (std::is_same_v<T, SomeDerived>) {
1506 return FoldOperation(context, std::move(x));
1507 } else if constexpr (common::HasMember<decltype(x),
1508 TypelessExpression>) {
1509 return std::move(expr);
1510 } else {
1511 return Expr<T>{Fold(context, std::move(x))};
1512 }
1513 },
1514 std::move(expr.u));
1515 }
1516
1517 FOR_EACH_TYPE_AND_KIND(extern template class ExpressionBase, )
1518
1519 } // namespace Fortran::evaluate
1520 #endif // FORTRAN_EVALUATE_FOLD_IMPLEMENTATION_H_
Fortran::evaluate::Constant
Definition: constant.h:40
Fortran::evaluate::Subscript
Definition: variable.h:182
Fortran::evaluate::ArrayConstructor
Definition: expression.h:444
Fortran::evaluate::Constant< SomeDerived >
Definition: constant.h:202
Fortran::evaluate::Component
Definition: variable.h:73
IntrinsicLibrary
Definition: IntrinsicCall.cpp:172
Fortran::semantics::Symbol
Definition: symbol.h:479
Fortran::evaluate::ArrayRef
Definition: variable.h:196
Fortran::evaluate::FoldingContext
Definition: common.h:209
Fortran::evaluate::ImpliedDo
Definition: expression.h:383
Fortran::evaluate::FunctionRef
Definition: call.h:218
Fortran::evaluate::ArrayConstructorValue
Definition: expression.h:411
Fortran::common::Indirection< A, true >
Definition: indirection.h:72
Fortran::evaluate::ArrayConstructorValues
Definition: expression.h:374
Fortran::evaluate::Designator
Definition: variable.h:369
Fortran::evaluate::NamedEntity
Definition: variable.h:99
Fortran::evaluate::Expr
Definition: common.h:207
Fortran::evaluate::ArrayConstructorFolder
Definition: fold-implementation.h:756
Fortran::evaluate::Folder
Definition: fold-implementation.h:48