9#ifndef FORTRAN_EVALUATE_FOLD_IMPLEMENTATION_H_
10#define FORTRAN_EVALUATE_FOLD_IMPLEMENTATION_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"
52static constexpr bool useKahanSummation{
false};
58 : context_{c}, forOptionalArgument_{forOptionalArgument} {}
59 std::optional<Constant<T>> GetNamedConstant(
const Symbol &);
60 std::optional<Constant<T>> ApplySubscripts(
const Constant<T> &array,
65 std::optional<Constant<T>> GetConstantComponent(
67 std::optional<Constant<T>> Folding(
ArrayRef &);
68 std::optional<Constant<T>> Folding(
DataRef &);
70 Constant<T> *Folding(std::optional<ActualArgument> &);
85 bool forOptionalArgument_{
false};
88std::optional<Constant<SubscriptInteger>> GetConstantSubscript(
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)}) {
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)))
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)};
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 &&);
134Expr<T> FoldOperation(FoldingContext &, FunctionRef<T> &&);
136Expr<T> FoldOperation(FoldingContext &context, Designator<T> &&designator) {
137 return Folder<T>{context}.Folding(std::move(designator));
139Expr<TypeParamInquiry::Result> FoldOperation(
140 FoldingContext &, TypeParamInquiry &&);
141Expr<ImpliedDoIndex::Result> FoldOperation(
142 FoldingContext &context, ImpliedDoIndex &&);
144Expr<T> FoldOperation(FoldingContext &, ArrayConstructor<T> &&);
145Expr<SomeDerived> FoldOperation(FoldingContext &, StructureConstructor &&);
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())}) {
162std::optional<Constant<T>> Folder<T>::Folding(ArrayRef &aRef) {
163 std::vector<Constant<SubscriptInteger>> subscripts;
165 for (Subscript &ss : aRef.subscript()) {
166 if (
auto constant{GetConstantSubscript(context_, ss, aRef.base(), dim++)}) {
167 subscripts.emplace_back(std::move(*constant));
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);
183std::optional<Constant<T>> Folder<T>::Folding(DataRef &ref) {
184 return common::visit(
186 [
this](SymbolRef &sym) {
return GetNamedConstant(*sym); },
187 [
this](Component &comp) {
188 comp = FoldOperation(context_, std::move(comp));
189 return GetConstantComponent(comp);
191 [
this](ArrayRef &aRef) {
192 aRef = FoldOperation(context_, std::move(aRef));
193 return Folding(aRef);
195 [](CoarrayRef &) {
return std::optional<Constant<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) {
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};
225 for (
int j{0}; j < rank; ++j) {
226 if (subscripts[j].Rank() == 0) {
227 at[j] = subscripts[j].GetScalarValue().value().ToInt64();
229 CHECK(k < GetRank(resultShape));
230 tmp[0] = ssLB.at(k) + ssAt.at(k);
231 at[j] = subscripts[j].At(tmp).ToInt64();
233 if (++ssAt[k] == resultShape[k]) {
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,
248 values.emplace_back(array.At(at));
249 CHECK(!increment || elements == 0);
250 CHECK(k == GetRank(resultShape));
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)};
258 return Constant<T>{std::move(values), std::move(resultShape)};
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)}) {
270 return ApplySubscripts(*value, *subscripts);
278 std::unique_ptr<ArrayConstructor<T>> array;
279 if (structures.empty()) {
282 ConstantSubscripts at{structures.lbounds()};
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())}) {
290 auto *typedExpr{UnwrapExpr<Expr<T>>(expr.value())};
292 array = std::make_unique<ArrayConstructor<T>>(*typedExpr);
293 if constexpr (T::category == TypeCategory::Character) {
294 array->set_LEN(Expr<SubscriptInteger>{value->LEN()});
298 if (
auto element{ApplySubscripts(*value, *subscripts)}) {
299 CHECK(element->Rank() == 0);
300 array->Push(Expr<T>{std::move(*element)});
305 CHECK(value->Rank() == 0);
306 array->Push(Expr<T>{*value});
312 }
while (structures.IncrementSubscripts(at));
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()));
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(
328 [&](
const Symbol &symbol) {
329 return Folder<SomeDerived>{context_}.GetNamedConstant(symbol);
331 [&](ArrayRef &aRef) {
332 return Folder<SomeDerived>{context_}.Folding(aRef);
334 [&](Component &base) {
335 return Folder<SomeDerived>{context_}.GetConstantComponent(base);
338 return std::optional<Constant<SomeDerived>>{};
341 component.base().u)}) {
342 return ApplyComponent(
343 std::move(*structures), component.GetLastSymbol(), subscripts);
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);
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)}}});
372 return Expr<T>{Designator<T>{std::move(*zPart)}};
376 return common::visit(
378 [&](SymbolRef &&symbol) {
379 if (
auto constant{GetNamedConstant(*symbol)}) {
380 return Expr<T>{std::move(*constant)};
382 return Expr<T>{std::move(designator)};
384 [&](ArrayRef &&aRef) {
385 aRef = FoldOperation(context_, std::move(aRef));
386 if (
auto c{Folding(aRef)}) {
387 return Expr<T>{std::move(*c)};
389 return Expr<T>{Designator<T>{std::move(aRef)}};
392 [&](Component &&component) {
393 component = FoldOperation(context_, std::move(component));
394 if (
auto c{GetConstantComponent(component)}) {
395 return Expr<T>{std::move(*c)};
397 return Expr<T>{Designator<T>{std::move(component)}};
402 Designator<T>{FoldOperation(context_, std::move(x))}};
405 std::move(designator.u));
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)) {
417 var{forOptionalArgument_
418 ? UnwrapWholeSymbolOrComponentDataRef(*expr)
420 var && (IsOptional(*var) || IsAllocatableOrObjectPointer(var))) {
422 }
else if (
auto converted{
423 ConvertToType(T::GetType(), std::move(*expr))}) {
424 *expr = Fold(context_, std::move(*converted));
428 return UnwrapConstantValue<T>(*expr);
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)))) {
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...>{});
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...>) {
459 GetConstantArguments<A...>(context, args, hasOptionalArgument)}) {
460 return std::tuple<Scalar<A>...>{
461 std::get<I>(*constArgs)->GetScalarValue().value()...};
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...>{});
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> &...)>;
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)}) {
493 ConstantSubscripts shape;
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) {
503 if (shape != *shapes[i]) {
508 context.messages().Say(
509 "Arguments in elemental intrinsic function are not conformable"_err_en_US);
510 return Expr<TR>{std::move(funcRef)};
515 CHECK(rank == GetRank(shape));
517 std::vector<Scalar<TR>> results;
518 std::optional<uint64_t> n{TotalElementCount(shape)};
520 context.messages().Say(
521 "Too many elements in elemental intrinsic function result"_err_en_US);
522 return Expr<TR>{std::move(funcRef)};
525 ConstantBounds bounds{shape};
526 ConstantSubscripts resultIndex(rank, 1);
527 ConstantSubscripts argIndex[]{std::get<I>(*args)->lbounds()...};
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])...));
537 (std::get<I>(*args)->IncrementSubscripts(argIndex[I]), ...);
538 }
while (bounds.IncrementSubscripts(resultIndex));
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)}};
553 return Expr<TR>{Constant<TR>{std::move(results), std::move(shape)}};
556 return Expr<TR>{std::move(funcRef)};
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...>{});
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...>{});
576std::optional<std::int64_t> GetInt64ArgOr(
577 const std::optional<ActualArgument> &, std::int64_t defaultValue);
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()));
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())}}};
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)};
622 auto convertedShift{Fold(context_,
623 ConvertToType<SubscriptInteger>(Expr<SomeInteger>{*shiftExpr}))};
624 const auto *shift{UnwrapConstantValue<SubscriptInteger>(convertedShift)};
626 return Expr<T>{std::move(funcRef)};
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) {
635 int rank{array->Rank()};
636 int zbDim{
static_cast<int>(*dim) - 1};
638 if (shift->Rank() > 0) {
640 for (
int j{0}; j < rank; ++j) {
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]));
654 std::vector<Scalar<T>> resultElements;
655 ConstantSubscripts arrayLB{array->lbounds()};
656 ConstantSubscripts arrayAt{arrayLB};
657 ConstantSubscript &dimIndex{arrayAt[zbDim]};
658 ConstantSubscript dimLB{dimIndex};
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) {
666 for (
int j{0}; j < rank; ++j) {
668 shiftAt.emplace_back(shiftLB[k++] + arrayAt[j] - arrayLB[j]);
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;
679 resultElements.push_back(array->At(arrayAt));
680 dimIndex = origDimIndex;
681 array->IncrementSubscripts(arrayAt);
683 return Expr<T>{PackageConstant<T>(
684 std::move(resultElements), *array, array->shape())};
688 return MakeInvalidIntrinsic(std::move(funcRef));
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)};
701 auto convertedShift{Fold(context_,
702 ConvertToType<SubscriptInteger>(Expr<SomeInteger>{*shiftExpr}))};
703 const auto *shift{UnwrapConstantValue<SubscriptInteger>(convertedShift)};
705 return Expr<T>{std::move(funcRef)};
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);
714 return Expr<T>{std::move(funcRef)};
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) {
724 }
else if (boundary && boundary->Rank() > 0 &&
725 boundary->Rank() != array->Rank() - 1) {
728 int rank{array->Rank()};
729 int zbDim{
static_cast<int>(*dim) - 1};
731 if (shift->Rank() > 0) {
733 for (
int j{0}; j < rank; ++j) {
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]));
746 if (boundary && boundary->Rank() > 0) {
748 for (
int j{0}; j < rank; ++j) {
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]));
762 std::vector<Scalar<T>> resultElements;
763 ConstantSubscripts arrayLB{array->lbounds()};
764 ConstantSubscripts arrayAt{arrayLB};
765 ConstantSubscript &dimIndex{arrayAt[zbDim]};
766 ConstantSubscript dimLB{dimIndex};
767 ConstantSubscript dimExtent{array->shape()[zbDim]};
768 ConstantSubscripts shiftLB{shift->lbounds()};
769 ConstantSubscripts boundaryLB;
771 boundaryLB = boundary->lbounds();
773 for (
auto n{GetSize(array->shape())}; n > 0; --n) {
774 ConstantSubscript origDimIndex{dimIndex};
775 ConstantSubscripts shiftAt;
776 if (shift->Rank() > 0) {
778 for (
int j{0}; j < rank; ++j) {
780 shiftAt.emplace_back(shiftLB[k++] + arrayAt[j] - arrayLB[j]);
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) {
794 boundaryAt.emplace_back(
795 boundaryLB[k++] + arrayAt[j] - arrayLB[j]);
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);
811 DIE(
"no derived type boundary");
813 dimIndex = origDimIndex;
814 array->IncrementSubscripts(arrayAt);
816 return Expr<T>{PackageConstant<T>(
817 std::move(resultElements), *array, array->shape())};
821 return MakeInvalidIntrinsic(std::move(funcRef));
824template <
typename T> Expr<T> Folder<T>::MERGE(FunctionRef<T> &&funcRef) {
825 return FoldElementalIntrinsic<T, T, T, LogicalResult>(context_,
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;
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)};
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;
854 }
else if (array->shape() != mask->shape()) {
856 return MakeInvalidIntrinsic(std::move(funcRef));
858 for (ConstantSubscript j{0}; j < arrayElements;
859 ++j, mask->IncrementSubscripts(maskAt)) {
860 if (mask->At(maskAt).IsTrue()) {
865 std::vector<Scalar<T>> resultElements;
866 ConstantSubscripts arrayAt{array->lbounds()};
867 ConstantSubscript resultSize{truths};
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));
878 for (ConstantSubscript j{0}; j < truths;) {
879 if (mask->At(maskAt).IsTrue()) {
880 resultElements.push_back(array->At(arrayAt));
883 array->IncrementSubscripts(arrayAt);
884 mask->IncrementSubscripts(maskAt);
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));
894 return Expr<T>{PackageConstant<T>(std::move(resultElements), *array,
895 ConstantSubscripts{
static_cast<ConstantSubscript
>(resultSize)})};
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;
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);
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());
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());
930 dimOrder = ValidateDimensionOrder(GetRank(*shape), *order);
932 context_.messages().Say(
933 "Invalid 'order=' argument (%s) in RESHAPE"_err_en_US,
934 DEREF(args[3]->UnwrapExpr()).AsFortran());
941 }
else if (!source || !shape || (args[2] && !pad) || (args[3] && !order)) {
942 return Expr<T>{std::move(funcRef)};
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);
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) {
961 copied += result.CopyFrom(
962 *pad, resultElements - copied, subscripts, dimOrderPtr);
964 CHECK(copied == resultElements);
965 return Expr<T>{std::move(result)};
969 return MakeInvalidIntrinsic(std::move(funcRef));
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)};
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,
990 }
else if (!ncopies) {
991 return Expr<T>{std::move(funcRef)};
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())};
1006 context_.messages().Say(
"Too many elements in SPREAD result"_err_en_US);
1008 std::vector<int> dimOrder;
1009 for (
int j{0}; j < sourceRank; ++j) {
1010 dimOrder.push_back(j < *dim - 1 ? j : j + 1);
1012 dimOrder.push_back(*dim - 1);
1013 ConstantSubscripts at{spread.lbounds()};
1014 spread.CopyFrom(*source, *n, at, &dimOrder);
1015 return Expr<T>{std::move(spread)};
1019 return MakeInvalidIntrinsic(std::move(funcRef));
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])};
1027 return Expr<T>{std::move(funcRef)};
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));
1039 at = matrix->shape();
1040 std::swap(at[0], at[1]);
1041 return Expr<T>{PackageConstant<T>(std::move(resultElements), *matrix, at)};
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)};
1057 if (field->Rank() > 0 && field->shape() != mask->shape()) {
1059 return MakeInvalidIntrinsic(std::move(funcRef));
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()) {
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));
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);
1085 resultElements.push_back(field->At(fieldAt));
1087 mask->IncrementSubscripts(maskAt);
1088 field->IncrementSubscripts(fieldAt);
1091 PackageConstant<T>(std::move(resultElements), *vector, mask->shape())};
1094std::optional<Expr<SomeType>> FoldTransfer(
1095 FoldingContext &,
const ActualArguments &);
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));
1101 return Expr<T>{std::move(funcRef)};
1105template <
typename T>
1106Expr<T> FoldMINorMAX(
1107 FoldingContext &context, FunctionRef<T> &&funcRef, Ordering order) {
1108 static_assert(T::category == TypeCategory::Integer ||
1109 T::category == TypeCategory::Unsigned ||
1110 T::category == TypeCategory::Real ||
1111 T::category == TypeCategory::Character);
1112 auto &args{funcRef.arguments()};
1114 std::optional<Expr<T>> result;
1115 Folder<T> folder{context};
1116 for (std::optional<ActualArgument> &arg : args) {
1118 if (!folder.Folding(arg)) {
1128 if (!context.moduleFileName()) {
1132 Expr<SomeType> *argExpr{arg ? arg->UnwrapExpr() :
nullptr};
1134 *argExpr = Fold(context, std::move(*argExpr));
1136 if (Expr<T> * tExpr{UnwrapExpr<Expr<T>>(argExpr)}) {
1138 result = FoldOperation(
1139 context, Extremum<T>{order, std::move(*result), Expr<T>{*tExpr}});
1141 result = Expr<T>{*tExpr};
1147 return ok && result ? std::move(*result) : Expr<T>{std::move(funcRef)};
1157template <
typename T>
1158Expr<T> RewriteSpecificMINorMAX(
1159 FoldingContext &context, FunctionRef<T> &&funcRef) {
1160 ActualArguments &args{funcRef.arguments()};
1161 auto &intrinsic{DEREF(std::get_if<SpecificIntrinsic>(&funcRef.proc().u))};
1164 std::optional<DynamicType> resultType;
1165 ActualArgument *resultTypeArg{
nullptr};
1166 for (
auto j{args.size()}; j-- > 0;) {
1168 DynamicType type{args[j]->GetType().value()};
1173 (type.category() == resultType->category() &&
1174 type.kind() > resultType->kind()) ||
1175 resultType->category() == TypeCategory::Integer) {
1177 resultTypeArg = &*args[j];
1182 return Expr<T>{std::move(funcRef)};
1185 intrinsic.name.find(
"max") != std::string::npos ?
"max"s :
"min"s;
1186 intrinsic.characteristics.value().functionResult.value().SetType(*resultType);
1187 auto insertConversion{[&](
const auto &x) -> Expr<T> {
1188 using TR = ResultType<
decltype(x)>;
1189 FunctionRef<TR> maxRef{
1190 ProcedureDesignator{funcRef.proc()}, ActualArguments{args}};
1191 return Fold(context, ConvertToType<T>(AsCategoryExpr(std::move(maxRef))));
1193 if (
auto *sx{UnwrapExpr<Expr<SomeReal>>(*resultTypeArg)}) {
1194 return common::visit(insertConversion, sx->u);
1195 }
else if (
auto *sx{UnwrapExpr<Expr<SomeInteger>>(*resultTypeArg)}) {
1196 return common::visit(insertConversion, sx->u);
1198 return Expr<T>{std::move(funcRef)};
1204Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
1205 FoldingContext &context, FunctionRef<Type<TypeCategory::Integer, KIND>> &&);
1207Expr<Type<TypeCategory::Unsigned, KIND>> FoldIntrinsicFunction(
1208 FoldingContext &context,
1209 FunctionRef<Type<TypeCategory::Unsigned, KIND>> &&);
1211Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
1212 FoldingContext &context, FunctionRef<Type<TypeCategory::Real, KIND>> &&);
1214Expr<Type<TypeCategory::Complex, KIND>> FoldIntrinsicFunction(
1215 FoldingContext &context, FunctionRef<Type<TypeCategory::Complex, KIND>> &&);
1217Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
1218 FoldingContext &context, FunctionRef<Type<TypeCategory::Logical, KIND>> &&);
1220template <
typename T>
1221Expr<T> FoldOperation(FoldingContext &context, FunctionRef<T> &&funcRef) {
1222 ActualArguments &args{funcRef.arguments()};
1223 const auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)};
1224 if (!intrinsic || intrinsic->name !=
"kind") {
1227 for (std::optional<ActualArgument> &arg : args) {
1228 if (
auto *expr{UnwrapExpr<Expr<SomeType>>(arg)}) {
1229 *expr = Fold(context, std::move(*expr));
1234 const std::string name{intrinsic->name};
1235 if (name ==
"cshift") {
1236 return Folder<T>{context}.CSHIFT(std::move(funcRef));
1237 }
else if (name ==
"eoshift") {
1238 return Folder<T>{context}.EOSHIFT(std::move(funcRef));
1239 }
else if (name ==
"merge") {
1240 return Folder<T>{context}.MERGE(std::move(funcRef));
1241 }
else if (name ==
"pack") {
1242 return Folder<T>{context}.PACK(std::move(funcRef));
1243 }
else if (name ==
"reshape") {
1244 return Folder<T>{context}.RESHAPE(std::move(funcRef));
1245 }
else if (name ==
"spread") {
1246 return Folder<T>{context}.SPREAD(std::move(funcRef));
1247 }
else if (name ==
"transfer") {
1248 return Folder<T>{context}.TRANSFER(std::move(funcRef));
1249 }
else if (name ==
"transpose") {
1250 return Folder<T>{context}.TRANSPOSE(std::move(funcRef));
1251 }
else if (name ==
"unpack") {
1252 return Folder<T>{context}.UNPACK(std::move(funcRef));
1255 if constexpr (!std::is_same_v<T, SomeDerived>) {
1256 return FoldIntrinsicFunction(context, std::move(funcRef));
1259 return Expr<T>{std::move(funcRef)};
1262Expr<ImpliedDoIndex::Result> FoldOperation(FoldingContext &, ImpliedDoIndex &&);
1270 if constexpr (T::category == TypeCategory::Character) {
1271 if (
const auto *len{array.LEN()}) {
1272 charLength_ = ToInt64(Fold(context_, common::Clone(*len)));
1273 knownCharLength_ = charLength_.has_value();
1277 if (FoldArray(array)) {
1278 auto n{
static_cast<ConstantSubscript
>(elements_.size())};
1279 if constexpr (std::is_same_v<T, SomeDerived>) {
1281 std::move(elements_), ConstantSubscripts{n}}};
1282 }
else if constexpr (T::category == TypeCategory::Character) {
1285 *charLength_, std::move(elements_), ConstantSubscripts{n}}};
1289 Constant<T>{std::move(elements_), ConstantSubscripts{n}}};
1292 return Expr<T>{std::move(array)};
1296 bool FoldArray(
const Expr<T> &expr) {
1297 Expr<T> folded{Fold(context_, common::Clone(expr))};
1298 if (
const auto *c{UnwrapConstantValue<T>(folded)}) {
1301 ConstantSubscripts index{c->lbounds()};
1303 elements_.emplace_back(c->At(index));
1304 }
while (c->IncrementSubscripts(index));
1306 if constexpr (T::category == TypeCategory::Character) {
1307 if (!knownCharLength_) {
1308 charLength_ = std::max(c->LEN(), charLength_.value_or(-1));
1317 return FoldArray(expr.value());
1326 std::optional<ConstantSubscript> start{ToInt64(lower)}, end{ToInt64(upper)},
1327 step{ToInt64(stride)};
1328 if (start && end && step && *step != 0) {
1330 ConstantSubscript &j{context_.StartImpliedDo(iDo.name(), *start)};
1332 for (; j <= *end; j += *step) {
1333 result &= FoldArray(iDo.values());
1336 for (; j >= *end; j += *step) {
1337 result &= FoldArray(iDo.values());
1340 context_.EndImpliedDo(iDo.name());
1347 return common::visit([&](
const auto &y) {
return FoldArray(y); }, x.u);
1350 for (
const auto &x : xs) {
1351 if (!FoldArray(x)) {
1359 std::vector<Scalar<T>> elements_;
1360 std::optional<ConstantSubscript> charLength_;
1361 bool knownCharLength_{
false};
1364template <
typename T>
1377template <
typename T>
1378bool ArrayConstructorIsFlat(
const ArrayConstructorValues<T> &values) {
1379 for (
const ArrayConstructorValue<T> &x : values) {
1380 if (!std::holds_alternative<Expr<T>>(x.u)) {
1387template <
typename T>
1388std::optional<Expr<T>> AsFlatArrayConstructor(
const Expr<T> &expr) {
1389 if (
const auto *c{UnwrapConstantValue<T>(expr)}) {
1390 ArrayConstructor<T> result{expr};
1392 ConstantSubscripts at{c->lbounds()};
1394 result.Push(Expr<T>{Constant<T>{c->At(at)}});
1395 }
while (c->IncrementSubscripts(at));
1397 return std::make_optional<Expr<T>>(std::move(result));
1398 }
else if (
const auto *a{UnwrapExpr<ArrayConstructor<T>>(expr)}) {
1399 if (ArrayConstructorIsFlat(*a)) {
1400 return std::make_optional<Expr<T>>(expr);
1402 }
else if (
const auto *p{UnwrapExpr<Parentheses<T>>(expr)}) {
1403 return AsFlatArrayConstructor(Expr<T>{p->left()});
1405 return std::nullopt;
1408template <TypeCategory CAT>
1409std::enable_if_t<CAT != TypeCategory::Derived,
1410 std::optional<Expr<SomeKind<CAT>>>>
1411AsFlatArrayConstructor(
const Expr<SomeKind<CAT>> &expr) {
1412 return common::visit(
1413 [&](
const auto &kindExpr) -> std::optional<Expr<SomeKind<CAT>>> {
1414 if (
auto flattened{AsFlatArrayConstructor(kindExpr)}) {
1415 return Expr<SomeKind<CAT>>{std::move(*flattened)};
1417 return std::nullopt;
1427template <
typename T>
1428std::optional<Expr<T>> FromArrayConstructor(
1429 FoldingContext &context, ArrayConstructor<T> &&values,
const Shape &shape) {
1430 if (
auto constShape{AsConstantExtents(context, shape)};
1431 constShape && !HasNegativeExtent(*constShape)) {
1432 Expr<T> result{Fold(context, Expr<T>{std::move(values)})};
1433 if (
auto *constant{UnwrapConstantValue<T>(result)}) {
1435 return Expr<T>{constant->Reshape(std::move(*constShape))};
1437 if (constShape->size() == 1) {
1438 if (
auto elements{GetShape(context, result)}) {
1439 if (
auto constElements{AsConstantExtents(context, *elements)}) {
1440 if (constElements->size() == 1 &&
1441 constElements->at(0) == constShape->at(0)) {
1444 return std::move(result);
1450 return std::nullopt;
1461template <
typename RESULT,
typename OPERAND>
1462std::optional<Expr<RESULT>> MapOperation(FoldingContext &context,
1463 std::function<Expr<RESULT>(Expr<OPERAND> &&)> &&f,
const Shape &shape,
1464 [[maybe_unused]] std::optional<Expr<SubscriptInteger>> &&length,
1465 Expr<OPERAND> &&values) {
1466 ArrayConstructor<RESULT> result{values};
1467 if constexpr (common::HasMember<OPERAND, AllIntrinsicCategoryTypes>) {
1469 [&](
auto &&kindExpr) {
1470 using kindType = ResultType<
decltype(kindExpr)>;
1471 auto &aConst{std::get<ArrayConstructor<kindType>>(kindExpr.u)};
1472 for (
auto &acValue : aConst) {
1473 auto &scalar{std::get<Expr<kindType>>(acValue.u)};
1474 result.Push(Fold(context, f(Expr<OPERAND>{std::move(scalar)})));
1477 std::move(values.u));
1479 auto &aConst{std::get<ArrayConstructor<OPERAND>>(values.u)};
1480 for (
auto &acValue : aConst) {
1481 auto &scalar{std::get<Expr<OPERAND>>(acValue.u)};
1482 result.Push(Fold(context, f(std::move(scalar))));
1485 if constexpr (RESULT::category == TypeCategory::Character) {
1487 result.set_LEN(std::move(*length));
1490 return FromArrayConstructor(context, std::move(result), shape);
1493template <
typename RESULT,
typename A>
1494ArrayConstructor<RESULT> ArrayConstructorFromMold(
1495 const A &prototype, std::optional<Expr<SubscriptInteger>> &&length) {
1496 ArrayConstructor<RESULT> result{prototype};
1497 if constexpr (RESULT::category == TypeCategory::Character) {
1499 result.set_LEN(std::move(*length));
1505template <
typename LEFT,
typename RIGHT>
1506bool ShapesMatch(FoldingContext &context,
1507 const ArrayConstructor<LEFT> &leftArrConst,
1508 const ArrayConstructor<RIGHT> &rightArrConst) {
1509 auto rightIter{rightArrConst.begin()};
1510 for (
auto &leftValue : leftArrConst) {
1511 CHECK(rightIter != rightArrConst.end());
1512 auto &leftExpr{std::get<Expr<LEFT>>(leftValue.u)};
1513 auto &rightExpr{std::get<Expr<RIGHT>>(rightIter->u)};
1514 if (leftExpr.Rank() != rightExpr.Rank()) {
1517 std::optional<Shape> leftShape{GetShape(context, leftExpr)};
1518 std::optional<Shape> rightShape{GetShape(context, rightExpr)};
1519 if (!leftShape || !rightShape || *leftShape != *rightShape) {
1528template <
typename RESULT,
typename LEFT,
typename RIGHT>
1529auto MapOperation(FoldingContext &context,
1530 std::function<Expr<RESULT>(Expr<LEFT> &&, Expr<RIGHT> &&)> &&f,
1531 const Shape &shape, std::optional<Expr<SubscriptInteger>> &&length,
1532 Expr<LEFT> &&leftValues, Expr<RIGHT> &&rightValues)
1533 -> std::optional<Expr<RESULT>> {
1534 auto result{ArrayConstructorFromMold<RESULT>(leftValues, std::move(length))};
1535 auto &leftArrConst{std::get<ArrayConstructor<LEFT>>(leftValues.u)};
1536 if constexpr (common::HasMember<RIGHT, AllIntrinsicCategoryTypes>) {
1537 bool mapped{common::visit(
1538 [&](
auto &&kindExpr) ->
bool {
1539 using kindType = ResultType<
decltype(kindExpr)>;
1541 auto &rightArrConst{std::get<ArrayConstructor<kindType>>(kindExpr.u)};
1542 if (!ShapesMatch(context, leftArrConst, rightArrConst)) {
1545 auto rightIter{rightArrConst.begin()};
1546 for (
auto &leftValue : leftArrConst) {
1547 CHECK(rightIter != rightArrConst.end());
1548 auto &leftScalar{std::get<Expr<LEFT>>(leftValue.u)};
1549 auto &rightScalar{std::get<Expr<kindType>>(rightIter->u)};
1550 result.Push(Fold(context,
1551 f(std::move(leftScalar), Expr<RIGHT>{std::move(rightScalar)})));
1556 std::move(rightValues.u))};
1558 return std::nullopt;
1561 auto &rightArrConst{std::get<ArrayConstructor<RIGHT>>(rightValues.u)};
1562 if (!ShapesMatch(context, leftArrConst, rightArrConst)) {
1563 return std::nullopt;
1565 auto rightIter{rightArrConst.begin()};
1566 for (
auto &leftValue : leftArrConst) {
1567 CHECK(rightIter != rightArrConst.end());
1568 auto &leftScalar{std::get<Expr<LEFT>>(leftValue.u)};
1569 auto &rightScalar{std::get<Expr<RIGHT>>(rightIter->u)};
1571 Fold(context, f(std::move(leftScalar), std::move(rightScalar))));
1575 return FromArrayConstructor(context, std::move(result), shape);
1579template <
typename RESULT,
typename LEFT,
typename RIGHT>
1580auto MapOperation(FoldingContext &context,
1581 std::function<Expr<RESULT>(Expr<LEFT> &&, Expr<RIGHT> &&)> &&f,
1582 const Shape &shape, std::optional<Expr<SubscriptInteger>> &&length,
1583 Expr<LEFT> &&leftValues,
const Expr<RIGHT> &rightScalar)
1584 -> std::optional<Expr<RESULT>> {
1585 auto result{ArrayConstructorFromMold<RESULT>(leftValues, std::move(length))};
1586 auto &leftArrConst{std::get<ArrayConstructor<LEFT>>(leftValues.u)};
1587 for (
auto &leftValue : leftArrConst) {
1588 auto &leftScalar{std::get<Expr<LEFT>>(leftValue.u)};
1590 Fold(context, f(std::move(leftScalar), Expr<RIGHT>{rightScalar})));
1592 return FromArrayConstructor(context, std::move(result), shape);
1596template <
typename RESULT,
typename LEFT,
typename RIGHT>
1597auto MapOperation(FoldingContext &context,
1598 std::function<Expr<RESULT>(Expr<LEFT> &&, Expr<RIGHT> &&)> &&f,
1599 const Shape &shape, std::optional<Expr<SubscriptInteger>> &&length,
1600 const Expr<LEFT> &leftScalar, Expr<RIGHT> &&rightValues)
1601 -> std::optional<Expr<RESULT>> {
1602 auto result{ArrayConstructorFromMold<RESULT>(leftScalar, std::move(length))};
1603 if constexpr (common::HasMember<RIGHT, AllIntrinsicCategoryTypes>) {
1605 [&](
auto &&kindExpr) {
1606 using kindType = ResultType<
decltype(kindExpr)>;
1607 auto &rightArrConst{std::get<ArrayConstructor<kindType>>(kindExpr.u)};
1608 for (
auto &rightValue : rightArrConst) {
1609 auto &rightScalar{std::get<Expr<kindType>>(rightValue.u)};
1610 result.Push(Fold(context,
1611 f(Expr<LEFT>{leftScalar},
1612 Expr<RIGHT>{std::move(rightScalar)})));
1615 std::move(rightValues.u));
1617 auto &rightArrConst{std::get<ArrayConstructor<RIGHT>>(rightValues.u)};
1618 for (
auto &rightValue : rightArrConst) {
1619 auto &rightScalar{std::get<Expr<RIGHT>>(rightValue.u)};
1621 Fold(context, f(Expr<LEFT>{leftScalar}, std::move(rightScalar))));
1624 return FromArrayConstructor(context, std::move(result), shape);
1627template <
typename DERIVED,
typename RESULT,
typename... OPD>
1628std::optional<Expr<SubscriptInteger>> ComputeResultLength(
1629 Operation<DERIVED, RESULT, OPD...> &operation) {
1630 if constexpr (RESULT::category == TypeCategory::Character) {
1631 return Expr<RESULT>{operation.derived()}.LEN();
1633 return std::nullopt;
1640template <
typename DERIVED,
typename RESULT,
typename OPERAND>
1641auto ApplyElementwise(FoldingContext &context,
1642 Operation<DERIVED, RESULT, OPERAND> &operation,
1643 std::function<Expr<RESULT>(Expr<OPERAND> &&)> &&f)
1644 -> std::optional<Expr<RESULT>> {
1645 auto &expr{operation.left()};
1646 expr = Fold(context, std::move(expr));
1647 if (expr.Rank() > 0) {
1648 if (std::optional<Shape> shape{GetShape(context, expr)}) {
1649 if (
auto values{AsFlatArrayConstructor(expr)}) {
1650 return MapOperation(context, std::move(f), *shape,
1651 ComputeResultLength(operation), std::move(*values));
1655 return std::nullopt;
1658template <
typename DERIVED,
typename RESULT,
typename OPERAND>
1659auto ApplyElementwise(
1660 FoldingContext &context, Operation<DERIVED, RESULT, OPERAND> &operation)
1661 -> std::optional<Expr<RESULT>> {
1662 return ApplyElementwise(context, operation,
1663 std::function<Expr<RESULT>(Expr<OPERAND> &&)>{
1664 [](Expr<OPERAND> &&operand) {
1665 return Expr<RESULT>{DERIVED{std::move(operand)}};
1669template <
typename DERIVED,
typename RESULT,
typename LEFT,
typename RIGHT>
1670auto ApplyElementwise(FoldingContext &context,
1671 Operation<DERIVED, RESULT, LEFT, RIGHT> &operation,
1672 std::function<Expr<RESULT>(Expr<LEFT> &&, Expr<RIGHT> &&)> &&f)
1673 -> std::optional<Expr<RESULT>> {
1674 auto resultLength{ComputeResultLength(operation)};
1675 auto &leftExpr{operation.left()};
1676 auto &rightExpr{operation.right()};
1677 if (leftExpr.Rank() != rightExpr.Rank() && leftExpr.Rank() != 0 &&
1678 rightExpr.Rank() != 0) {
1679 return std::nullopt;
1681 leftExpr = Fold(context, std::move(leftExpr));
1682 rightExpr = Fold(context, std::move(rightExpr));
1683 if (leftExpr.Rank() > 0) {
1684 if (std::optional<Shape> leftShape{GetShape(context, leftExpr)}) {
1685 if (
auto left{AsFlatArrayConstructor(leftExpr)}) {
1686 if (rightExpr.Rank() > 0) {
1687 if (std::optional<Shape> rightShape{GetShape(context, rightExpr)}) {
1688 if (
auto right{AsFlatArrayConstructor(rightExpr)}) {
1689 if (CheckConformance(context.messages(), *leftShape, *rightShape,
1690 CheckConformanceFlags::EitherScalarExpandable)
1691 .value_or(
false )) {
1692 return MapOperation(context, std::move(f), *leftShape,
1693 std::move(resultLength), std::move(*left),
1696 return std::nullopt;
1698 return MapOperation(context, std::move(f), *leftShape,
1699 std::move(resultLength), std::move(*left), std::move(*right));
1702 }
else if (IsExpandableScalar(rightExpr, context, *leftShape)) {
1703 return MapOperation(context, std::move(f), *leftShape,
1704 std::move(resultLength), std::move(*left), rightExpr);
1708 }
else if (rightExpr.Rank() > 0) {
1709 if (std::optional<Shape> rightShape{GetShape(context, rightExpr)}) {
1710 if (IsExpandableScalar(leftExpr, context, *rightShape)) {
1711 if (
auto right{AsFlatArrayConstructor(rightExpr)}) {
1712 return MapOperation(context, std::move(f), *rightShape,
1713 std::move(resultLength), leftExpr, std::move(*right));
1718 return std::nullopt;
1721template <
typename DERIVED,
typename RESULT,
typename LEFT,
typename RIGHT>
1722auto ApplyElementwise(
1723 FoldingContext &context, Operation<DERIVED, RESULT, LEFT, RIGHT> &operation)
1724 -> std::optional<Expr<RESULT>> {
1725 return ApplyElementwise(context, operation,
1726 std::function<Expr<RESULT>(Expr<LEFT> &&, Expr<RIGHT> &&)>{
1727 [](Expr<LEFT> &&left, Expr<RIGHT> &&right) {
1728 return Expr<RESULT>{DERIVED{std::move(left), std::move(right)}};
1734template <
typename TO,
typename FROM>
1735common::IfNoLvalue<std::optional<TO>, FROM> ConvertString(FROM &&s) {
1736 if constexpr (std::is_same_v<TO, FROM>) {
1737 return std::make_optional<TO>(std::move(s));
1742 for (
auto iter{s.cbegin()}; iter != s.cend(); ++iter) {
1743 if (
static_cast<std::uint64_t
>(*iter) > 127) {
1744 return std::nullopt;
1746 str.push_back(*iter);
1748 return std::make_optional<TO>(std::move(str));
1752template <
typename TO, TypeCategory FROMCAT>
1753Expr<TO> FoldOperation(
1754 FoldingContext &context, Convert<TO, FROMCAT> &&convert) {
1755 if (
auto array{ApplyElementwise(context, convert)}) {
1759 FoldingContext &context;
1760 Convert<TO, FROMCAT> &convert;
1761 } msvcWorkaround{context, convert};
1762 return common::visit(
1763 [&msvcWorkaround](
auto &kindExpr) -> Expr<TO> {
1764 using Operand = ResultType<
decltype(kindExpr)>;
1767 TypeCategory
constexpr FromCat{FROMCAT};
1768 static_assert(FromCat == Operand::category);
1769 auto &convert{msvcWorkaround.convert};
1770 if (
auto value{GetScalarConstantValue<Operand>(kindExpr)}) {
1771 FoldingContext &ctx{msvcWorkaround.context};
1772 if constexpr (TO::category == TypeCategory::Integer) {
1773 if constexpr (FromCat == TypeCategory::Integer) {
1774 auto converted{Scalar<TO>::ConvertSigned(*value)};
1775 if (converted.overflow &&
1776 msvcWorkaround.context.languageFeatures().ShouldWarn(
1777 common::UsageWarning::FoldingException)) {
1778 ctx.messages().Say(common::UsageWarning::FoldingException,
1779 "conversion of %s_%d to INTEGER(%d) overflowed; result is %s"_warn_en_US,
1780 value->SignedDecimal(), Operand::kind, TO::kind,
1781 converted.value.SignedDecimal());
1783 return ScalarConstantToExpr(std::move(converted.value));
1784 }
else if constexpr (FromCat == TypeCategory::Unsigned) {
1785 auto converted{Scalar<TO>::ConvertUnsigned(*value)};
1786 if ((converted.overflow || converted.value.IsNegative()) &&
1787 msvcWorkaround.context.languageFeatures().ShouldWarn(
1788 common::UsageWarning::FoldingException)) {
1789 ctx.messages().Say(common::UsageWarning::FoldingException,
1790 "conversion of %s_U%d to INTEGER(%d) overflowed; result is %s"_warn_en_US,
1791 value->UnsignedDecimal(), Operand::kind, TO::kind,
1792 converted.value.SignedDecimal());
1794 return ScalarConstantToExpr(std::move(converted.value));
1795 }
else if constexpr (FromCat == TypeCategory::Real) {
1796 auto converted{value->template ToInteger<Scalar<TO>>()};
1797 if (msvcWorkaround.context.languageFeatures().ShouldWarn(
1798 common::UsageWarning::FoldingException)) {
1799 if (converted.flags.test(RealFlag::InvalidArgument)) {
1800 ctx.messages().Say(common::UsageWarning::FoldingException,
1801 "REAL(%d) to INTEGER(%d) conversion: invalid argument"_warn_en_US,
1802 Operand::kind, TO::kind);
1803 }
else if (converted.flags.test(RealFlag::Overflow)) {
1805 "REAL(%d) to INTEGER(%d) conversion overflowed"_warn_en_US,
1806 Operand::kind, TO::kind);
1809 return ScalarConstantToExpr(std::move(converted.value));
1811 }
else if constexpr (TO::category == TypeCategory::Unsigned) {
1812 if constexpr (FromCat == TypeCategory::Integer ||
1813 FromCat == TypeCategory::Unsigned) {
1815 Constant<TO>{Scalar<TO>::ConvertUnsigned(*value).value}};
1816 }
else if constexpr (FromCat == TypeCategory::Real) {
1818 Constant<TO>{value->template ToInteger<Scalar<TO>>().value}};
1820 }
else if constexpr (TO::category == TypeCategory::Real) {
1821 if constexpr (FromCat == TypeCategory::Integer ||
1822 FromCat == TypeCategory::Unsigned) {
1823 auto converted{Scalar<TO>::FromInteger(
1824 *value, FromCat == TypeCategory::Unsigned)};
1825 if (!converted.flags.empty()) {
1827 std::snprintf(buffer,
sizeof buffer,
1828 "INTEGER(%d) to REAL(%d) conversion", Operand::kind,
1830 RealFlagWarnings(ctx, converted.flags, buffer);
1832 return ScalarConstantToExpr(std::move(converted.value));
1833 }
else if constexpr (FromCat == TypeCategory::Real) {
1834 auto converted{Scalar<TO>::Convert(*value)};
1836 if (!converted.flags.empty()) {
1837 std::snprintf(buffer,
sizeof buffer,
1838 "REAL(%d) to REAL(%d) conversion", Operand::kind, TO::kind);
1839 RealFlagWarnings(ctx, converted.flags, buffer);
1841 if (ctx.targetCharacteristics().areSubnormalsFlushedToZero()) {
1842 converted.value = converted.value.FlushSubnormalToZero();
1844 return ScalarConstantToExpr(std::move(converted.value));
1846 }
else if constexpr (TO::category == TypeCategory::Complex) {
1847 if constexpr (FromCat == TypeCategory::Complex) {
1848 return FoldOperation(ctx,
1849 ComplexConstructor<TO::kind>{
1850 AsExpr(Convert<typename TO::Part>{AsCategoryExpr(
1851 Constant<typename Operand::Part>{value->REAL()})}),
1852 AsExpr(Convert<typename TO::Part>{AsCategoryExpr(
1853 Constant<typename Operand::Part>{value->AIMAG()})})});
1855 }
else if constexpr (TO::category == TypeCategory::Character &&
1856 FromCat == TypeCategory::Character) {
1857 if (
auto converted{ConvertString<Scalar<TO>>(std::move(*value))}) {
1858 return ScalarConstantToExpr(std::move(*converted));
1860 }
else if constexpr (TO::category == TypeCategory::Logical &&
1861 FromCat == TypeCategory::Logical) {
1862 return Expr<TO>{value->IsTrue()};
1864 }
else if constexpr (TO::category == FromCat &&
1865 FromCat != TypeCategory::Character) {
1867 if constexpr (std::is_same_v<Operand, TO>) {
1868 return std::move(kindExpr);
1869 }
else if constexpr (TO::category == TypeCategory::Logical ||
1870 TO::category == TypeCategory::Integer) {
1871 if (
auto *innerConv{
1872 std::get_if<Convert<Operand, TO::category>>(&kindExpr.u)}) {
1874 if (
auto *x{std::get_if<Expr<TO>>(&innerConv->left().u)}) {
1875 if constexpr (TO::category == TypeCategory::Logical ||
1876 TO::kind <= Operand::kind) {
1877 return std::move(*x);
1879 }
else if constexpr (std::is_same_v<TO,
1880 DescriptorInquiry::Result>) {
1881 if (std::holds_alternative<DescriptorInquiry>(x->u) ||
1882 std::holds_alternative<TypeParamInquiry>(x->u)) {
1884 return std::move(*x);
1891 return Expr<TO>{std::move(convert)};
1896template <
typename T>
1897Expr<T> FoldOperation(FoldingContext &context, Parentheses<T> &&x) {
1898 auto &operand{x.left()};
1899 operand = Fold(context, std::move(operand));
1900 if (
auto value{GetScalarConstantValue<T>(operand)}) {
1902 return Expr<T>{Parentheses<T>{Expr<T>{Constant<T>{*value}}}};
1903 }
else if (std::holds_alternative<Parentheses<T>>(operand.u)) {
1905 return std::move(operand);
1907 return Expr<T>{Parentheses<T>{std::move(operand)}};
1911template <
typename T>
1912Expr<T> FoldOperation(FoldingContext &context, Negate<T> &&x) {
1913 if (
auto array{ApplyElementwise(context, x)}) {
1916 auto &operand{x.left()};
1917 if (
auto *nn{std::get_if<Negate<T>>(&x.left().u)}) {
1919 if (IsVariable(nn->left())) {
1920 return FoldOperation(context, Parentheses<T>{std::move(nn->left())});
1922 return std::move(nn->left());
1924 }
else if (
auto value{GetScalarConstantValue<T>(operand)}) {
1925 if constexpr (T::category == TypeCategory::Integer) {
1926 auto negated{value->Negate()};
1927 if (negated.overflow &&
1928 context.languageFeatures().ShouldWarn(
1929 common::UsageWarning::FoldingException)) {
1930 context.messages().Say(common::UsageWarning::FoldingException,
1931 "INTEGER(%d) negation overflowed"_warn_en_US, T::kind);
1933 return Expr<T>{Constant<T>{std::move(negated.value)}};
1934 }
else if constexpr (T::category == TypeCategory::Unsigned) {
1935 return Expr<T>{Constant<T>{std::move(value->Negate().value)}};
1938 return Expr<T>{Constant<T>{value->Negate()}};
1941 return Expr<T>{std::move(x)};
1946template <
typename LEFT,
typename RIGHT>
1947std::optional<std::pair<Scalar<LEFT>, Scalar<RIGHT>>> OperandsAreConstants(
1948 const Expr<LEFT> &x,
const Expr<RIGHT> &y) {
1949 if (
auto xvalue{GetScalarConstantValue<LEFT>(x)}) {
1950 if (
auto yvalue{GetScalarConstantValue<RIGHT>(y)}) {
1951 return {std::make_pair(*xvalue, *yvalue)};
1954 return std::nullopt;
1957template <
typename DERIVED,
typename RESULT,
typename LEFT,
typename RIGHT>
1958std::optional<std::pair<Scalar<LEFT>, Scalar<RIGHT>>> OperandsAreConstants(
1959 const Operation<DERIVED, RESULT, LEFT, RIGHT> &operation) {
1960 return OperandsAreConstants(operation.left(), operation.right());
1963template <
typename T>
1964Expr<T> FoldOperation(FoldingContext &context, Add<T> &&x) {
1965 if (
auto array{ApplyElementwise(context, x)}) {
1968 if (
auto folded{OperandsAreConstants(x)}) {
1969 if constexpr (T::category == TypeCategory::Integer) {
1970 auto sum{folded->first.AddSigned(folded->second)};
1972 context.languageFeatures().ShouldWarn(
1973 common::UsageWarning::FoldingException)) {
1974 context.messages().Say(common::UsageWarning::FoldingException,
1975 "INTEGER(%d) addition overflowed"_warn_en_US, T::kind);
1977 return Expr<T>{Constant<T>{sum.value}};
1978 }
else if constexpr (T::category == TypeCategory::Unsigned) {
1980 Constant<T>{folded->first.AddUnsigned(folded->second).value}};
1982 auto sum{folded->first.Add(
1983 folded->second, context.targetCharacteristics().roundingMode())};
1984 RealFlagWarnings(context, sum.flags,
"addition");
1985 if (context.targetCharacteristics().areSubnormalsFlushedToZero()) {
1986 sum.value = sum.value.FlushSubnormalToZero();
1988 return Expr<T>{Constant<T>{sum.value}};
1991 return Expr<T>{std::move(x)};
1994template <
typename T>
1995Expr<T> FoldOperation(FoldingContext &context, Subtract<T> &&x) {
1996 if (
auto array{ApplyElementwise(context, x)}) {
1999 if (
auto folded{OperandsAreConstants(x)}) {
2000 if constexpr (T::category == TypeCategory::Integer) {
2001 auto difference{folded->first.SubtractSigned(folded->second)};
2002 if (difference.overflow &&
2003 context.languageFeatures().ShouldWarn(
2004 common::UsageWarning::FoldingException)) {
2005 context.messages().Say(common::UsageWarning::FoldingException,
2006 "INTEGER(%d) subtraction overflowed"_warn_en_US, T::kind);
2008 return Expr<T>{Constant<T>{difference.value}};
2009 }
else if constexpr (T::category == TypeCategory::Unsigned) {
2011 Constant<T>{folded->first.SubtractSigned(folded->second).value}};
2013 auto difference{folded->first.Subtract(
2014 folded->second, context.targetCharacteristics().roundingMode())};
2015 RealFlagWarnings(context, difference.flags,
"subtraction");
2016 if (context.targetCharacteristics().areSubnormalsFlushedToZero()) {
2017 difference.value = difference.value.FlushSubnormalToZero();
2019 return Expr<T>{Constant<T>{difference.value}};
2022 return Expr<T>{std::move(x)};
2025template <
typename T>
2026Expr<T> FoldOperation(FoldingContext &context, Multiply<T> &&x) {
2027 if (
auto array{ApplyElementwise(context, x)}) {
2030 if (
auto folded{OperandsAreConstants(x)}) {
2031 if constexpr (T::category == TypeCategory::Integer) {
2032 auto product{folded->first.MultiplySigned(folded->second)};
2033 if (product.SignedMultiplicationOverflowed() &&
2034 context.languageFeatures().ShouldWarn(
2035 common::UsageWarning::FoldingException)) {
2036 context.messages().Say(common::UsageWarning::FoldingException,
2037 "INTEGER(%d) multiplication overflowed"_warn_en_US, T::kind);
2039 return Expr<T>{Constant<T>{product.lower}};
2040 }
else if constexpr (T::category == TypeCategory::Unsigned) {
2042 Constant<T>{folded->first.MultiplyUnsigned(folded->second).lower}};
2044 auto product{folded->first.Multiply(
2045 folded->second, context.targetCharacteristics().roundingMode())};
2046 RealFlagWarnings(context, product.flags,
"multiplication");
2047 if (context.targetCharacteristics().areSubnormalsFlushedToZero()) {
2048 product.value = product.value.FlushSubnormalToZero();
2050 return Expr<T>{Constant<T>{product.value}};
2052 }
else if constexpr (T::category == TypeCategory::Integer) {
2053 if (
auto c{GetScalarConstantValue<T>(x.right())}) {
2054 x.right() = std::move(x.left());
2055 x.left() = Expr<T>{std::move(*c)};
2057 if (
auto c{GetScalarConstantValue<T>(x.left())}) {
2058 if (c->IsZero() && x.right().Rank() == 0) {
2059 return std::move(x.left());
2060 }
else if (c->CompareSigned(Scalar<T>{1}) == Ordering::Equal) {
2061 if (IsVariable(x.right())) {
2062 return FoldOperation(context, Parentheses<T>{std::move(x.right())});
2064 return std::move(x.right());
2066 }
else if (c->CompareSigned(Scalar<T>{-1}) == Ordering::Equal) {
2067 return FoldOperation(context, Negate<T>{std::move(x.right())});
2071 return Expr<T>{std::move(x)};
2074template <
typename T>
2075Expr<T> FoldOperation(FoldingContext &context, Divide<T> &&x) {
2076 if (
auto array{ApplyElementwise(context, x)}) {
2079 if (
auto folded{OperandsAreConstants(x)}) {
2080 if constexpr (T::category == TypeCategory::Integer) {
2081 auto quotAndRem{folded->first.DivideSigned(folded->second)};
2082 if (quotAndRem.divisionByZero) {
2083 if (context.languageFeatures().ShouldWarn(
2084 common::UsageWarning::FoldingException)) {
2085 context.messages().Say(common::UsageWarning::FoldingException,
2086 "INTEGER(%d) division by zero"_warn_en_US, T::kind);
2088 return Expr<T>{std::move(x)};
2090 if (quotAndRem.overflow &&
2091 context.languageFeatures().ShouldWarn(
2092 common::UsageWarning::FoldingException)) {
2093 context.messages().Say(common::UsageWarning::FoldingException,
2094 "INTEGER(%d) division overflowed"_warn_en_US, T::kind);
2096 return Expr<T>{Constant<T>{quotAndRem.quotient}};
2097 }
else if constexpr (T::category == TypeCategory::Unsigned) {
2098 auto quotAndRem{folded->first.DivideUnsigned(folded->second)};
2099 if (quotAndRem.divisionByZero) {
2100 if (context.languageFeatures().ShouldWarn(
2101 common::UsageWarning::FoldingException)) {
2102 context.messages().Say(common::UsageWarning::FoldingException,
2103 "UNSIGNED(%d) division by zero"_warn_en_US, T::kind);
2105 return Expr<T>{std::move(x)};
2107 return Expr<T>{Constant<T>{quotAndRem.quotient}};
2109 auto quotient{folded->first.Divide(
2110 folded->second, context.targetCharacteristics().roundingMode())};
2114 bool isCanonicalNaNOrInf{
false};
2115 if constexpr (T::category == TypeCategory::Real) {
2116 if (folded->second.IsZero() && context.moduleFileName().has_value()) {
2117 using IntType =
typename T::Scalar::Word;
2118 auto intNumerator{folded->first.template ToInteger<IntType>()};
2119 isCanonicalNaNOrInf = intNumerator.flags == RealFlags{} &&
2120 intNumerator.value >= IntType{-1} &&
2121 intNumerator.value <= IntType{1};
2124 if (!isCanonicalNaNOrInf) {
2125 RealFlagWarnings(context, quotient.flags,
"division");
2127 if (context.targetCharacteristics().areSubnormalsFlushedToZero()) {
2128 quotient.value = quotient.value.FlushSubnormalToZero();
2130 return Expr<T>{Constant<T>{quotient.value}};
2133 return Expr<T>{std::move(x)};
2136template <
typename T>
2137Expr<T> FoldOperation(FoldingContext &context, Power<T> &&x) {
2138 if (
auto array{ApplyElementwise(context, x)}) {
2141 if (
auto folded{OperandsAreConstants(x)}) {
2142 if constexpr (T::category == TypeCategory::Integer) {
2143 auto power{folded->first.Power(folded->second)};
2144 if (context.languageFeatures().ShouldWarn(
2145 common::UsageWarning::FoldingException)) {
2146 if (power.divisionByZero) {
2147 context.messages().Say(common::UsageWarning::FoldingException,
2148 "INTEGER(%d) zero to negative power"_warn_en_US, T::kind);
2149 }
else if (power.overflow) {
2150 context.messages().Say(common::UsageWarning::FoldingException,
2151 "INTEGER(%d) power overflowed"_warn_en_US, T::kind);
2152 }
else if (power.zeroToZero) {
2153 context.messages().Say(common::UsageWarning::FoldingException,
2154 "INTEGER(%d) 0**0 is not defined"_warn_en_US, T::kind);
2157 return Expr<T>{Constant<T>{power.power}};
2159 if (
auto callable{GetHostRuntimeWrapper<T, T, T>(
"pow")}) {
2161 Constant<T>{(*callable)(context, folded->first, folded->second)}};
2162 }
else if (context.languageFeatures().ShouldWarn(
2163 common::UsageWarning::FoldingFailure)) {
2164 context.messages().Say(common::UsageWarning::FoldingFailure,
2165 "Power for %s cannot be folded on host"_warn_en_US,
2170 return Expr<T>{std::move(x)};
2173template <
typename T>
2174Expr<T> FoldOperation(FoldingContext &context, RealToIntPower<T> &&x) {
2175 if (
auto array{ApplyElementwise(context, x)}) {
2178 return common::visit(
2179 [&](
auto &y) -> Expr<T> {
2180 if (
auto folded{OperandsAreConstants(x.left(), y)}) {
2181 auto power{evaluate::IntPower(folded->first, folded->second)};
2182 RealFlagWarnings(context, power.flags,
"power with INTEGER exponent");
2183 if (context.targetCharacteristics().areSubnormalsFlushedToZero()) {
2184 power.value = power.value.FlushSubnormalToZero();
2186 return Expr<T>{Constant<T>{power.value}};
2188 return Expr<T>{std::move(x)};
2194template <
typename T>
2195Expr<T> FoldOperation(FoldingContext &context, Extremum<T> &&x) {
2196 if (
auto array{ApplyElementwise(context, x,
2197 std::function<Expr<T>(Expr<T> &&, Expr<T> &&)>{[=](Expr<T> &&l,
2199 return Expr<T>{Extremum<T>{x.ordering, std::move(l), std::move(r)}};
2203 if (
auto folded{OperandsAreConstants(x)}) {
2204 if constexpr (T::category == TypeCategory::Integer) {
2205 if (folded->first.CompareSigned(folded->second) == x.ordering) {
2206 return Expr<T>{Constant<T>{folded->first}};
2208 }
else if constexpr (T::category == TypeCategory::Unsigned) {
2209 if (folded->first.CompareUnsigned(folded->second) == x.ordering) {
2210 return Expr<T>{Constant<T>{folded->first}};
2212 }
else if constexpr (T::category == TypeCategory::Real) {
2213 if (folded->first.IsNotANumber() ||
2214 (folded->first.Compare(folded->second) == Relation::Less) ==
2215 (x.ordering == Ordering::Less)) {
2216 return Expr<T>{Constant<T>{folded->first}};
2219 static_assert(T::category == TypeCategory::Character);
2222 auto maxLen{std::max(folded->first.length(), folded->second.length())};
2223 bool isFirst{x.ordering == Compare(folded->first, folded->second)};
2224 auto res{isFirst ? std::move(folded->first) : std::move(folded->second)};
2225 res = res.length() == maxLen
2227 : CharacterUtils<T::kind>::Resize(res, maxLen);
2228 return Expr<T>{Constant<T>{std::move(res)}};
2230 return Expr<T>{Constant<T>{folded->second}};
2232 return Expr<T>{std::move(x)};
2236Expr<Type<TypeCategory::Real, KIND>> ToReal(
2237 FoldingContext &context, Expr<SomeType> &&expr) {
2238 using Result = Type<TypeCategory::Real, KIND>;
2239 std::optional<Expr<Result>> result;
2242 using From = std::decay_t<
decltype(x)>;
2243 if constexpr (std::is_same_v<From, BOZLiteralConstant>) {
2246 result = ConvertToType<Result>(std::move(x));
2247 const auto *constant{UnwrapExpr<Constant<Result>>(*result)};
2249 Scalar<Result> real{constant->GetScalarValue().value()};
2250 From converted{From::ConvertUnsigned(real.RawBits()).value};
2251 if (original != converted &&
2252 context.languageFeatures().ShouldWarn(
2253 common::UsageWarning::FoldingValueChecks)) {
2254 context.messages().Say(common::UsageWarning::FoldingValueChecks,
2255 "Nonzero bits truncated from BOZ literal constant in REAL intrinsic"_warn_en_US);
2257 }
else if constexpr (IsNumericCategoryExpr<From>()) {
2258 result = Fold(context, ConvertToType<Result>(std::move(x)));
2260 common::die(
"ToReal: bad argument expression");
2264 return result.value();
2269Expr<Type<TypeCategory::Real, KIND>> FoldOperation(
2270 FoldingContext &context, ComplexComponent<KIND> &&x) {
2271 using Operand = Type<TypeCategory::Complex, KIND>;
2272 using Result = Type<TypeCategory::Real, KIND>;
2273 if (
auto array{ApplyElementwise(context, x,
2274 std::function<Expr<Result>(Expr<Operand> &&)>{
2275 [=](Expr<Operand> &&operand) {
2276 return Expr<Result>{ComplexComponent<KIND>{
2277 x.isImaginaryPart, std::move(operand)}};
2281 auto &operand{x.left()};
2282 if (
auto value{GetScalarConstantValue<Operand>(operand)}) {
2283 if (x.isImaginaryPart) {
2284 return Expr<Result>{Constant<Result>{value->AIMAG()}};
2286 return Expr<Result>{Constant<Result>{value->REAL()}};
2289 return Expr<Result>{std::move(x)};
2292template <
typename T>
2293Expr<T> ExpressionBase<T>::Rewrite(FoldingContext &context, Expr<T> &&expr) {
2294 return common::visit(
2295 [&](
auto &&x) -> Expr<T> {
2296 if constexpr (IsSpecificIntrinsicType<T>) {
2297 return FoldOperation(context, std::move(x));
2298 }
else if constexpr (std::is_same_v<T, SomeDerived>) {
2299 return FoldOperation(context, std::move(x));
2300 }
else if constexpr (common::HasMember<
decltype(x),
2301 TypelessExpression>) {
2302 return std::move(expr);
2304 return Expr<T>{Fold(context, std::move(x))};
2310FOR_EACH_TYPE_AND_KIND(
extern template class ExpressionBase, )
Definition: indirection.h:72
Definition: fold-implementation.h:1265
Definition: expression.h:438
Definition: expression.h:466
Definition: variable.h:208
Definition: variable.h:74
Definition: constant.h:141
Definition: variable.h:393
Definition: fold-implementation.h:55
Definition: expression.h:404
Definition: variable.h:104
Definition: expression.h:432
Definition: variable.h:300
Definition: variable.h:194