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