1589 lines · cpp
1//===-- lib/Evaluate/fold-integer.cpp -------------------------------------===//2//3// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.4// See https://llvm.org/LICENSE.txt for license information.5// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception6//7//===----------------------------------------------------------------------===//8 9#include "fold-implementation.h"10#include "fold-matmul.h"11#include "fold-reduction.h"12#include "flang/Evaluate/check-expression.h"13 14namespace Fortran::evaluate {15 16// Given a collection of ConstantSubscripts values, package them as a Constant.17// Return scalar value if asScalar == true and shape-dim array otherwise.18template <typename T>19Expr<T> PackageConstantBounds(20 const ConstantSubscripts &&bounds, bool asScalar = false) {21 if (asScalar) {22 return Expr<T>{Constant<T>{bounds.at(0)}};23 } else {24 // As rank-dim array25 const int rank{GetRank(bounds)};26 std::vector<Scalar<T>> packed(rank);27 std::transform(bounds.begin(), bounds.end(), packed.begin(),28 [](ConstantSubscript x) { return Scalar<T>(x); });29 return Expr<T>{Constant<T>{std::move(packed), ConstantSubscripts{rank}}};30 }31}32 33// If a DIM= argument to LBOUND(), UBOUND(), or SIZE() exists and has a valid34// constant value, return in "dimVal" that value, less 1 (to make it suitable35// for use as a C++ vector<> index). Also check for erroneous constant values36// and returns false on error.37static bool CheckDimArg(const std::optional<ActualArgument> &dimArg,38 const Expr<SomeType> &array, parser::ContextualMessages &messages,39 bool isLBound, std::optional<int> &dimVal) {40 dimVal.reset();41 if (int rank{array.Rank()}; rank > 0 || semantics::IsAssumedRank(array)) {42 auto named{ExtractNamedEntity(array)};43 if (auto dim64{ToInt64(dimArg)}) {44 if (*dim64 < 1) {45 messages.Say("DIM=%jd dimension must be positive"_err_en_US, *dim64);46 return false;47 } else if (!semantics::IsAssumedRank(array) && *dim64 > rank) {48 messages.Say(49 "DIM=%jd dimension is out of range for rank-%d array"_err_en_US,50 *dim64, rank);51 return false;52 } else if (!isLBound && named &&53 semantics::IsAssumedSizeArray(named->GetLastSymbol()) &&54 *dim64 == rank) {55 messages.Say(56 "DIM=%jd dimension is out of range for rank-%d assumed-size array"_err_en_US,57 *dim64, rank);58 return false;59 } else if (semantics::IsAssumedRank(array)) {60 if (*dim64 > common::maxRank) {61 messages.Say(62 "DIM=%jd dimension is too large for any array (maximum rank %d)"_err_en_US,63 *dim64, common::maxRank);64 return false;65 }66 } else {67 dimVal = static_cast<int>(*dim64 - 1); // 1-based to 0-based68 }69 }70 }71 return true;72}73 74static bool CheckCoDimArg(const std::optional<ActualArgument> &dimArg,75 const Symbol &symbol, parser::ContextualMessages &messages,76 std::optional<int> &dimVal) {77 dimVal.reset();78 if (int corank{symbol.Corank()}; corank > 0) {79 if (auto dim64{ToInt64(dimArg)}) {80 if (*dim64 < 1) {81 messages.Say("DIM=%jd dimension must be positive"_err_en_US, *dim64);82 return false;83 } else if (*dim64 > corank) {84 messages.Say(85 "DIM=%jd dimension is out of range for corank-%d coarray"_err_en_US,86 *dim64, corank);87 return false;88 } else {89 dimVal = static_cast<int>(*dim64 - 1); // 1-based to 0-based90 }91 }92 }93 return true;94}95 96// Class to retrieve the constant bound of an expression which is an97// array that devolves to a type of Constant<T>98class GetConstantArrayBoundHelper {99public:100 template <typename T>101 static Expr<T> GetLbound(102 const Expr<SomeType> &array, std::optional<int> dim) {103 return PackageConstantBounds<T>(104 GetConstantArrayBoundHelper(dim, /*getLbound=*/true).Get(array),105 dim.has_value());106 }107 108 template <typename T>109 static Expr<T> GetUbound(110 const Expr<SomeType> &array, std::optional<int> dim) {111 return PackageConstantBounds<T>(112 GetConstantArrayBoundHelper(dim, /*getLbound=*/false).Get(array),113 dim.has_value());114 }115 116private:117 GetConstantArrayBoundHelper(118 std::optional<ConstantSubscript> dim, bool getLbound)119 : dim_{dim}, getLbound_{getLbound} {}120 121 template <typename T> ConstantSubscripts Get(const T &) {122 // The method is needed for template expansion, but we should never get123 // here in practice.124 CHECK(false);125 return {0};126 }127 128 template <typename T> ConstantSubscripts Get(const Constant<T> &x) {129 if (getLbound_) {130 // Return the lower bound131 if (dim_) {132 return {x.lbounds().at(*dim_)};133 } else {134 return x.lbounds();135 }136 } else {137 // Return the upper bound138 if (arrayFromParenthesesExpr) {139 // Underlying array comes from (x) expression - return shapes140 if (dim_) {141 return {x.shape().at(*dim_)};142 } else {143 return x.shape();144 }145 } else {146 return x.ComputeUbounds(dim_);147 }148 }149 }150 151 template <typename T> ConstantSubscripts Get(const Parentheses<T> &x) {152 // Case of temp variable inside parentheses - return [1, ... 1] for lower153 // bounds and shape for upper bounds154 if (getLbound_) {155 return ConstantSubscripts(x.Rank(), ConstantSubscript{1});156 } else {157 // Indicate that underlying array comes from parentheses expression.158 // Continue to unwrap expression until we hit a constant159 arrayFromParenthesesExpr = true;160 return Get(x.left());161 }162 }163 164 template <typename T> ConstantSubscripts Get(const Expr<T> &x) {165 // recurse through Expr<T>'a until we hit a constant166 return common::visit([&](const auto &inner) { return Get(inner); },167 // [&](const auto &) { return 0; },168 x.u);169 }170 171 const std::optional<ConstantSubscript> dim_;172 const bool getLbound_;173 bool arrayFromParenthesesExpr{false};174};175 176template <int KIND>177Expr<Type<TypeCategory::Integer, KIND>> LBOUND(FoldingContext &context,178 FunctionRef<Type<TypeCategory::Integer, KIND>> &&funcRef) {179 using T = Type<TypeCategory::Integer, KIND>;180 ActualArguments &args{funcRef.arguments()};181 if (const auto *array{UnwrapExpr<Expr<SomeType>>(args[0])}) {182 std::optional<int> dim;183 if (funcRef.Rank() == 0) {184 // Optional DIM= argument is present: result is scalar.185 if (!CheckDimArg(args[1], *array, context.messages(), true, dim)) {186 return MakeInvalidIntrinsic<T>(std::move(funcRef));187 } else if (!dim) {188 // DIM= is present but not constant, or error189 return Expr<T>{std::move(funcRef)};190 }191 }192 if (semantics::IsAssumedRank(*array)) {193 // Would like to return 1 if DIM=.. is present, but that would be194 // hiding a runtime error if the DIM= were too large (including195 // the case of an assumed-rank argument that's scalar).196 } else if (int rank{array->Rank()}; rank > 0) {197 bool lowerBoundsAreOne{true};198 if (auto named{ExtractNamedEntity(*array)}) {199 const Symbol &symbol{named->GetLastSymbol()};200 if (symbol.Rank() == rank) {201 lowerBoundsAreOne = false;202 if (dim) {203 if (auto lb{GetLBOUND(context, *named, *dim)}) {204 return Fold(context, ConvertToType<T>(std::move(*lb)));205 }206 } else if (auto extents{207 AsExtentArrayExpr(GetLBOUNDs(context, *named))}) {208 return Fold(context,209 ConvertToType<T>(Expr<ExtentType>{std::move(*extents)}));210 }211 } else {212 lowerBoundsAreOne = symbol.Rank() == 0; // LBOUND(array%component)213 }214 }215 if (IsActuallyConstant(*array)) {216 return GetConstantArrayBoundHelper::GetLbound<T>(*array, dim);217 }218 if (lowerBoundsAreOne) {219 ConstantSubscripts ones(rank, ConstantSubscript{1});220 return PackageConstantBounds<T>(std::move(ones), dim.has_value());221 }222 }223 }224 return Expr<T>{std::move(funcRef)};225}226 227template <int KIND>228Expr<Type<TypeCategory::Integer, KIND>> UBOUND(FoldingContext &context,229 FunctionRef<Type<TypeCategory::Integer, KIND>> &&funcRef) {230 using T = Type<TypeCategory::Integer, KIND>;231 ActualArguments &args{funcRef.arguments()};232 if (auto *array{UnwrapExpr<Expr<SomeType>>(args[0])}) {233 std::optional<int> dim;234 if (funcRef.Rank() == 0) {235 // Optional DIM= argument is present: result is scalar.236 if (!CheckDimArg(args[1], *array, context.messages(), false, dim)) {237 return MakeInvalidIntrinsic<T>(std::move(funcRef));238 } else if (!dim) {239 // DIM= is present but not constant, or error240 return Expr<T>{std::move(funcRef)};241 }242 }243 if (semantics::IsAssumedRank(*array)) {244 } else if (int rank{array->Rank()}; rank > 0) {245 bool takeBoundsFromShape{true};246 if (auto named{ExtractNamedEntity(*array)}) {247 const Symbol &symbol{named->GetLastSymbol()};248 if (symbol.Rank() == rank) {249 takeBoundsFromShape = false;250 if (dim) {251 if (auto ub{GetUBOUND(context, *named, *dim)}) {252 return Fold(context, ConvertToType<T>(std::move(*ub)));253 }254 } else {255 Shape ubounds{GetUBOUNDs(context, *named)};256 if (semantics::IsAssumedSizeArray(symbol)) {257 CHECK(!ubounds.back());258 ubounds.back() = ExtentExpr{-1};259 }260 if (auto extents{AsExtentArrayExpr(ubounds)}) {261 return Fold(context,262 ConvertToType<T>(Expr<ExtentType>{std::move(*extents)}));263 }264 }265 } else {266 takeBoundsFromShape = symbol.Rank() == 0; // UBOUND(array%component)267 }268 }269 if (IsActuallyConstant(*array)) {270 return GetConstantArrayBoundHelper::GetUbound<T>(*array, dim);271 }272 if (takeBoundsFromShape) {273 if (auto shape{GetContextFreeShape(context, *array)}) {274 if (dim) {275 if (auto &dimSize{shape->at(*dim)}) {276 return Fold(context,277 ConvertToType<T>(Expr<ExtentType>{std::move(*dimSize)}));278 }279 } else if (auto shapeExpr{AsExtentArrayExpr(*shape)}) {280 return Fold(context, ConvertToType<T>(std::move(*shapeExpr)));281 }282 }283 }284 }285 }286 return Expr<T>{std::move(funcRef)};287}288 289// LCOBOUND() & UCOBOUND()290template <int KIND>291Expr<Type<TypeCategory::Integer, KIND>> COBOUND(FoldingContext &context,292 FunctionRef<Type<TypeCategory::Integer, KIND>> &&funcRef, bool isUCOBOUND) {293 using T = Type<TypeCategory::Integer, KIND>;294 ActualArguments &args{funcRef.arguments()};295 if (const Symbol * coarray{UnwrapWholeSymbolOrComponentDataRef(args[0])}) {296 std::optional<int> dim;297 if (funcRef.Rank() == 0) {298 // Optional DIM= argument is present: result is scalar.299 if (!CheckCoDimArg(args[1], *coarray, context.messages(), dim)) {300 return MakeInvalidIntrinsic<T>(std::move(funcRef));301 } else if (!dim) {302 // DIM= is present but not constant, or error303 return Expr<T>{std::move(funcRef)};304 }305 }306 if (dim) {307 if (auto cb{isUCOBOUND ? GetUCOBOUND(*coarray, *dim)308 : GetLCOBOUND(*coarray, *dim)}) {309 return Fold(context, ConvertToType<T>(std::move(*cb)));310 }311 } else if (auto cbs{312 AsExtentArrayExpr(isUCOBOUND ? GetUCOBOUNDs(*coarray)313 : GetLCOBOUNDs(*coarray))}) {314 return Fold(context, ConvertToType<T>(Expr<ExtentType>{std::move(*cbs)}));315 }316 }317 return Expr<T>{std::move(funcRef)};318}319 320// COUNT()321template <typename T, int MASK_KIND> class CountAccumulator {322 using MaskT = Type<TypeCategory::Logical, MASK_KIND>;323 324public:325 CountAccumulator(const Constant<MaskT> &mask) : mask_{mask} {}326 void operator()(327 Scalar<T> &element, const ConstantSubscripts &at, bool /*first*/) {328 if (mask_.At(at).IsTrue()) {329 auto incremented{element.AddSigned(Scalar<T>{1})};330 overflow_ |= incremented.overflow;331 element = incremented.value;332 }333 }334 bool overflow() const { return overflow_; }335 void Done(Scalar<T> &) const {}336 337private:338 const Constant<MaskT> &mask_;339 bool overflow_{false};340};341 342template <typename T, int maskKind>343static Expr<T> FoldCount(FoldingContext &context, FunctionRef<T> &&ref) {344 using KindLogical = Type<TypeCategory::Logical, maskKind>;345 static_assert(T::category == TypeCategory::Integer);346 std::optional<int> dim;347 if (std::optional<ArrayAndMask<KindLogical>> arrayAndMask{348 ProcessReductionArgs<KindLogical>(349 context, ref.arguments(), dim, /*ARRAY=*/0, /*DIM=*/1)}) {350 CountAccumulator<T, maskKind> accumulator{arrayAndMask->array};351 Constant<T> result{DoReduction<T>(arrayAndMask->array, arrayAndMask->mask,352 dim, Scalar<T>{}, accumulator)};353 if (accumulator.overflow()) {354 context.Warn(common::UsageWarning::FoldingException,355 "Result of intrinsic function COUNT overflows its result type"_warn_en_US);356 }357 return Expr<T>{std::move(result)};358 }359 return Expr<T>{std::move(ref)};360}361 362// FINDLOC(), MAXLOC(), & MINLOC()363enum class WhichLocation { Findloc, Maxloc, Minloc };364template <WhichLocation WHICH> class LocationHelper {365public:366 LocationHelper(367 DynamicType &&type, ActualArguments &arg, FoldingContext &context)368 : type_{type}, arg_{arg}, context_{context} {}369 using Result = std::optional<Constant<SubscriptInteger>>;370 using Types = std::conditional_t<WHICH == WhichLocation::Findloc,371 AllIntrinsicTypes, RelationalTypes>;372 373 template <typename T> Result Test() const {374 if (T::category != type_.category() || T::kind != type_.kind()) {375 return std::nullopt;376 }377 CHECK(arg_.size() == (WHICH == WhichLocation::Findloc ? 6 : 5));378 Folder<T> folder{context_};379 Constant<T> *array{folder.Folding(arg_[0])};380 if (!array) {381 return std::nullopt;382 }383 std::optional<Constant<T>> value;384 if constexpr (WHICH == WhichLocation::Findloc) {385 if (const Constant<T> *p{folder.Folding(arg_[1])}) {386 value.emplace(*p);387 } else {388 return std::nullopt;389 }390 }391 std::optional<int> dim;392 Constant<LogicalResult> *mask{393 GetReductionMASK(arg_[maskArg], array->shape(), context_)};394 if ((!mask && arg_[maskArg]) ||395 !CheckReductionDIM(dim, context_, arg_, dimArg, array->Rank())) {396 return std::nullopt;397 }398 bool back{false};399 if (arg_[backArg]) {400 const auto *backConst{401 Folder<LogicalResult>{context_, /*forOptionalArgument=*/true}.Folding(402 arg_[backArg])};403 if (backConst) {404 back = backConst->GetScalarValue().value().IsTrue();405 } else {406 return std::nullopt;407 }408 }409 const RelationalOperator relation{WHICH == WhichLocation::Findloc410 ? RelationalOperator::EQ411 : WHICH == WhichLocation::Maxloc412 ? (back ? RelationalOperator::GE : RelationalOperator::GT)413 : back ? RelationalOperator::LE414 : RelationalOperator::LT};415 // Use lower bounds of 1 exclusively.416 array->SetLowerBoundsToOne();417 ConstantSubscripts at{array->lbounds()}, maskAt, resultIndices, resultShape;418 if (mask) {419 if (auto scalarMask{mask->GetScalarValue()}) {420 // Convert into array in case of scalar MASK= (for421 // MAXLOC/MINLOC/FINDLOC mask should be conformable)422 ConstantSubscript n{GetSize(array->shape())};423 std::vector<Scalar<LogicalResult>> mask_elements(424 n, Scalar<LogicalResult>{scalarMask.value()});425 *mask = Constant<LogicalResult>{426 std::move(mask_elements), ConstantSubscripts{array->shape()}};427 }428 mask->SetLowerBoundsToOne();429 maskAt = mask->lbounds();430 }431 if (dim) { // DIM=432 if (*dim < 1 || *dim > array->Rank()) {433 context_.messages().Say("DIM=%d is out of range"_err_en_US, *dim);434 return std::nullopt;435 }436 int zbDim{*dim - 1};437 resultShape = array->shape();438 resultShape.erase(439 resultShape.begin() + zbDim); // scalar if array is vector440 ConstantSubscript dimLength{array->shape()[zbDim]};441 ConstantSubscript n{GetSize(resultShape)};442 for (ConstantSubscript j{0}; j < n; ++j) {443 ConstantSubscript hit{0};444 if constexpr (WHICH == WhichLocation::Maxloc ||445 WHICH == WhichLocation::Minloc) {446 value.reset();447 }448 for (ConstantSubscript k{0}; k < dimLength;449 ++k, ++at[zbDim], mask && ++maskAt[zbDim]) {450 if ((!mask || mask->At(maskAt).IsTrue()) &&451 IsHit(array->At(at), value, relation, back)) {452 hit = at[zbDim];453 if constexpr (WHICH == WhichLocation::Findloc) {454 if (!back) {455 break;456 }457 }458 }459 }460 resultIndices.emplace_back(hit);461 at[zbDim] = std::max<ConstantSubscript>(dimLength, 1);462 array->IncrementSubscripts(at);463 at[zbDim] = 1;464 if (mask) {465 maskAt[zbDim] = mask->lbounds()[zbDim] +466 std::max<ConstantSubscript>(dimLength, 1) - 1;467 mask->IncrementSubscripts(maskAt);468 maskAt[zbDim] = mask->lbounds()[zbDim];469 }470 }471 } else { // no DIM=472 resultShape = ConstantSubscripts{array->Rank()}; // always a vector473 ConstantSubscript n{GetSize(array->shape())};474 resultIndices = ConstantSubscripts(array->Rank(), 0);475 for (ConstantSubscript j{0}; j < n; ++j, array->IncrementSubscripts(at),476 mask && mask->IncrementSubscripts(maskAt)) {477 if ((!mask || mask->At(maskAt).IsTrue()) &&478 IsHit(array->At(at), value, relation, back)) {479 resultIndices = at;480 if constexpr (WHICH == WhichLocation::Findloc) {481 if (!back) {482 break;483 }484 }485 }486 }487 }488 std::vector<Scalar<SubscriptInteger>> resultElements;489 for (ConstantSubscript j : resultIndices) {490 resultElements.emplace_back(j);491 }492 return Constant<SubscriptInteger>{493 std::move(resultElements), std::move(resultShape)};494 }495 496private:497 template <typename T>498 bool IsHit(typename Constant<T>::Element element,499 std::optional<Constant<T>> &value,500 [[maybe_unused]] RelationalOperator relation,501 [[maybe_unused]] bool back) const {502 std::optional<Expr<LogicalResult>> cmp;503 bool result{true};504 if (value) {505 if constexpr (T::category == TypeCategory::Logical) {506 // array(at) .EQV. value?507 static_assert(WHICH == WhichLocation::Findloc);508 cmp.emplace(ConvertToType<LogicalResult>(509 Expr<T>{LogicalOperation<T::kind>{LogicalOperator::Eqv,510 Expr<T>{Constant<T>{element}}, Expr<T>{Constant<T>{*value}}}}));511 } else { // compare array(at) to value512 if constexpr (T::category == TypeCategory::Real &&513 (WHICH == WhichLocation::Maxloc ||514 WHICH == WhichLocation::Minloc)) {515 if (value && value->GetScalarValue().value().IsNotANumber() &&516 (back || !element.IsNotANumber())) {517 // Replace NaN518 cmp.emplace(Constant<LogicalResult>{Scalar<LogicalResult>{true}});519 }520 }521 if (!cmp) {522 cmp.emplace(PackageRelation(relation, Expr<T>{Constant<T>{element}},523 Expr<T>{Constant<T>{*value}}));524 }525 }526 Expr<LogicalResult> folded{Fold(context_, std::move(*cmp))};527 result = GetScalarConstantValue<LogicalResult>(folded).value().IsTrue();528 } else {529 // first unmasked element for MAXLOC/MINLOC - always take it530 }531 if constexpr (WHICH == WhichLocation::Maxloc ||532 WHICH == WhichLocation::Minloc) {533 if (result) {534 value.emplace(std::move(element));535 }536 }537 return result;538 }539 540 static constexpr int dimArg{WHICH == WhichLocation::Findloc ? 2 : 1};541 static constexpr int maskArg{dimArg + 1};542 static constexpr int backArg{maskArg + 2};543 544 DynamicType type_;545 ActualArguments &arg_;546 FoldingContext &context_;547};548 549template <WhichLocation which>550static std::optional<Constant<SubscriptInteger>> FoldLocationCall(551 ActualArguments &arg, FoldingContext &context) {552 if (arg[0]) {553 if (auto type{arg[0]->GetType()}) {554 if constexpr (which == WhichLocation::Findloc) {555 // Both ARRAY and VALUE are susceptible to conversion to a common556 // comparison type.557 if (arg[1]) {558 if (auto valType{arg[1]->GetType()}) {559 if (auto compareType{ComparisonType(*type, *valType)}) {560 type = compareType;561 }562 }563 }564 }565 return common::SearchTypes(566 LocationHelper<which>{std::move(*type), arg, context});567 }568 }569 return std::nullopt;570}571 572template <WhichLocation which, typename T>573static Expr<T> FoldLocation(FoldingContext &context, FunctionRef<T> &&ref) {574 static_assert(T::category == TypeCategory::Integer);575 if (std::optional<Constant<SubscriptInteger>> found{576 FoldLocationCall<which>(ref.arguments(), context)}) {577 return Expr<T>{Fold(578 context, ConvertToType<T>(Expr<SubscriptInteger>{std::move(*found)}))};579 } else {580 return Expr<T>{std::move(ref)};581 }582}583 584// for IALL, IANY, & IPARITY585template <typename T>586static Expr<T> FoldBitReduction(FoldingContext &context, FunctionRef<T> &&ref,587 Scalar<T> (Scalar<T>::*operation)(const Scalar<T> &) const,588 Scalar<T> identity) {589 static_assert(T::category == TypeCategory::Integer ||590 T::category == TypeCategory::Unsigned);591 std::optional<int> dim;592 if (std::optional<ArrayAndMask<T>> arrayAndMask{593 ProcessReductionArgs<T>(context, ref.arguments(), dim,594 /*ARRAY=*/0, /*DIM=*/1, /*MASK=*/2)}) {595 OperationAccumulator<T> accumulator{arrayAndMask->array, operation};596 return Expr<T>{DoReduction<T>(597 arrayAndMask->array, arrayAndMask->mask, dim, identity, accumulator)};598 }599 return Expr<T>{std::move(ref)};600}601 602// Common cases for INTEGER and UNSIGNED603template <typename T>604std::optional<Expr<T>> FoldIntrinsicFunctionCommon(605 FoldingContext &context, FunctionRef<T> &funcRef) {606 ActualArguments &args{funcRef.arguments()};607 auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)};608 CHECK(intrinsic);609 std::string name{intrinsic->name};610 using Int4 = Type<TypeCategory::Integer, 4>;611 if (name == "bit_size") {612 return Expr<T>{Scalar<T>::bits};613 } else if (name == "digits") {614 if (const auto *cx{UnwrapExpr<Expr<SomeInteger>>(args[0])}) {615 return Expr<T>{common::visit(616 [](const auto &kx) {617 return Scalar<ResultType<decltype(kx)>>::DIGITS;618 },619 cx->u)};620 } else if (const auto *cx{UnwrapExpr<Expr<SomeUnsigned>>(args[0])}) {621 return Expr<T>{common::visit(622 [](const auto &kx) {623 return Scalar<ResultType<decltype(kx)>>::DIGITS + 1;624 },625 cx->u)};626 } else if (const auto *cx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {627 return Expr<T>{common::visit(628 [](const auto &kx) {629 return Scalar<ResultType<decltype(kx)>>::DIGITS;630 },631 cx->u)};632 } else if (const auto *cx{UnwrapExpr<Expr<SomeComplex>>(args[0])}) {633 return Expr<T>{common::visit(634 [](const auto &kx) {635 return Scalar<typename ResultType<decltype(kx)>::Part>::DIGITS;636 },637 cx->u)};638 }639 } else if (name == "dot_product") {640 return FoldDotProduct<T>(context, std::move(funcRef));641 } else if (name == "dshiftl" || name == "dshiftr") {642 const auto fptr{643 name == "dshiftl" ? &Scalar<T>::DSHIFTL : &Scalar<T>::DSHIFTR};644 // Third argument can be of any kind. However, it must be smaller or equal645 // than BIT_SIZE. It can be converted to Int4 to simplify.646 if (const auto *argCon{Folder<T>(context).Folding(args[0])};647 argCon && argCon->empty()) {648 } else if (const auto *shiftCon{Folder<Int4>(context).Folding(args[2])}) {649 for (const auto &scalar : shiftCon->values()) {650 std::int64_t shiftVal{scalar.ToInt64()};651 if (shiftVal < 0) {652 context.messages().Say("SHIFT=%jd count for %s is negative"_err_en_US,653 std::intmax_t{shiftVal}, name);654 break;655 } else if (shiftVal > T::Scalar::bits) {656 context.messages().Say(657 "SHIFT=%jd count for %s is greater than %d"_err_en_US,658 std::intmax_t{shiftVal}, name, T::Scalar::bits);659 break;660 }661 }662 }663 return FoldElementalIntrinsic<T, T, T, Int4>(context, std::move(funcRef),664 ScalarFunc<T, T, T, Int4>(665 [&fptr](const Scalar<T> &i, const Scalar<T> &j,666 const Scalar<Int4> &shift) -> Scalar<T> {667 return std::invoke(fptr, i, j, static_cast<int>(shift.ToInt64()));668 }));669 } else if (name == "iand" || name == "ior" || name == "ieor") {670 auto fptr{&Scalar<T>::IAND};671 if (name == "iand") { // done in fptr declaration672 } else if (name == "ior") {673 fptr = &Scalar<T>::IOR;674 } else if (name == "ieor") {675 fptr = &Scalar<T>::IEOR;676 } else {677 common::die("missing case to fold intrinsic function %s", name.c_str());678 }679 return FoldElementalIntrinsic<T, T, T>(680 context, std::move(funcRef), ScalarFunc<T, T, T>(fptr));681 } else if (name == "iall") {682 return FoldBitReduction(683 context, std::move(funcRef), &Scalar<T>::IAND, Scalar<T>{}.NOT());684 } else if (name == "iany") {685 return FoldBitReduction(686 context, std::move(funcRef), &Scalar<T>::IOR, Scalar<T>{});687 } else if (name == "ibclr" || name == "ibset") {688 // Second argument can be of any kind. However, it must be smaller689 // than BIT_SIZE. It can be converted to Int4 to simplify.690 auto fptr{&Scalar<T>::IBCLR};691 if (name == "ibclr") { // done in fptr definition692 } else if (name == "ibset") {693 fptr = &Scalar<T>::IBSET;694 } else {695 common::die("missing case to fold intrinsic function %s", name.c_str());696 }697 if (const auto *argCon{Folder<T>(context).Folding(args[0])};698 argCon && argCon->empty()) {699 } else if (const auto *posCon{Folder<Int4>(context).Folding(args[1])}) {700 for (const auto &scalar : posCon->values()) {701 std::int64_t posVal{scalar.ToInt64()};702 if (posVal < 0) {703 context.messages().Say(704 "bit position for %s (%jd) is negative"_err_en_US, name,705 std::intmax_t{posVal});706 break;707 } else if (posVal >= T::Scalar::bits) {708 context.messages().Say(709 "bit position for %s (%jd) is not less than %d"_err_en_US, name,710 std::intmax_t{posVal}, T::Scalar::bits);711 break;712 }713 }714 }715 return FoldElementalIntrinsic<T, T, Int4>(context, std::move(funcRef),716 ScalarFunc<T, T, Int4>(717 [&](const Scalar<T> &i, const Scalar<Int4> &pos) -> Scalar<T> {718 return std::invoke(fptr, i, static_cast<int>(pos.ToInt64()));719 }));720 } else if (name == "ibits") {721 const auto *posCon{Folder<Int4>(context).Folding(args[1])};722 const auto *lenCon{Folder<Int4>(context).Folding(args[2])};723 if (const auto *argCon{Folder<T>(context).Folding(args[0])};724 argCon && argCon->empty()) {725 } else {726 std::size_t posCt{posCon ? posCon->size() : 0};727 std::size_t lenCt{lenCon ? lenCon->size() : 0};728 std::size_t n{std::max(posCt, lenCt)};729 for (std::size_t j{0}; j < n; ++j) {730 int posVal{j < posCt || posCt == 1731 ? static_cast<int>(posCon->values()[j % posCt].ToInt64())732 : 0};733 int lenVal{j < lenCt || lenCt == 1734 ? static_cast<int>(lenCon->values()[j % lenCt].ToInt64())735 : 0};736 if (posVal < 0) {737 context.messages().Say(738 "bit position for IBITS(POS=%jd) is negative"_err_en_US,739 std::intmax_t{posVal});740 break;741 } else if (lenVal < 0) {742 context.messages().Say(743 "bit length for IBITS(LEN=%jd) is negative"_err_en_US,744 std::intmax_t{lenVal});745 break;746 } else if (posVal + lenVal > T::Scalar::bits) {747 context.messages().Say(748 "IBITS() must have POS+LEN (>=%jd) no greater than %d"_err_en_US,749 std::intmax_t{posVal + lenVal}, T::Scalar::bits);750 break;751 }752 }753 }754 return FoldElementalIntrinsic<T, T, Int4, Int4>(context, std::move(funcRef),755 ScalarFunc<T, T, Int4, Int4>(756 [&](const Scalar<T> &i, const Scalar<Int4> &pos,757 const Scalar<Int4> &len) -> Scalar<T> {758 return i.IBITS(static_cast<int>(pos.ToInt64()),759 static_cast<int>(len.ToInt64()));760 }));761 } else if (name == "int" || name == "int2" || name == "int8" ||762 name == "uint") {763 if (auto *expr{UnwrapExpr<Expr<SomeType>>(args[0])}) {764 return common::visit(765 [&](auto &&x) -> Expr<T> {766 using From = std::decay_t<decltype(x)>;767 if constexpr (std::is_same_v<From, BOZLiteralConstant> ||768 IsNumericCategoryExpr<From>()) {769 return Fold(context, ConvertToType<T>(std::move(x)));770 }771 DIE("int() argument type not valid");772 },773 std::move(expr->u));774 }775 } else if (name == "iparity") {776 return FoldBitReduction(777 context, std::move(funcRef), &Scalar<T>::IEOR, Scalar<T>{});778 } else if (name == "ishft" || name == "ishftc") {779 const auto *argCon{Folder<T>(context).Folding(args[0])};780 const auto *shiftCon{Folder<Int4>(context).Folding(args[1])};781 const auto *shiftVals{shiftCon ? &shiftCon->values() : nullptr};782 const auto *sizeCon{args.size() == 3783 ? Folder<Int4>{context, /*forOptionalArgument=*/true}.Folding(784 args[2])785 : nullptr};786 const auto *sizeVals{sizeCon ? &sizeCon->values() : nullptr};787 if ((argCon && argCon->empty()) || !shiftVals || shiftVals->empty() ||788 (sizeVals && sizeVals->empty())) {789 // size= and shift= values don't need to be checked790 } else {791 for (const auto &scalar : *shiftVals) {792 std::int64_t shiftVal{scalar.ToInt64()};793 if (shiftVal < -T::Scalar::bits) {794 context.messages().Say(795 "SHIFT=%jd count for %s is less than %d"_err_en_US,796 std::intmax_t{shiftVal}, name, -T::Scalar::bits);797 break;798 } else if (shiftVal > T::Scalar::bits) {799 context.messages().Say(800 "SHIFT=%jd count for %s is greater than %d"_err_en_US,801 std::intmax_t{shiftVal}, name, T::Scalar::bits);802 break;803 }804 }805 if (sizeVals) {806 for (const auto &scalar : *sizeVals) {807 std::int64_t sizeVal{scalar.ToInt64()};808 if (sizeVal <= 0) {809 context.messages().Say(810 "SIZE=%jd count for ishftc is not positive"_err_en_US,811 std::intmax_t{sizeVal}, name);812 break;813 } else if (sizeVal > T::Scalar::bits) {814 context.messages().Say(815 "SIZE=%jd count for ishftc is greater than %d"_err_en_US,816 std::intmax_t{sizeVal}, T::Scalar::bits);817 break;818 }819 }820 if (shiftVals->size() == 1 || sizeVals->size() == 1 ||821 shiftVals->size() == sizeVals->size()) {822 auto iters{std::max(shiftVals->size(), sizeVals->size())};823 for (std::size_t j{0}; j < iters; ++j) {824 auto shiftVal{static_cast<int>(825 (*shiftVals)[j % shiftVals->size()].ToInt64())};826 auto sizeVal{827 static_cast<int>((*sizeVals)[j % sizeVals->size()].ToInt64())};828 if (sizeVal > 0 && std::abs(shiftVal) > sizeVal) {829 context.messages().Say(830 "SHIFT=%jd count for ishftc is greater in magnitude than SIZE=%jd"_err_en_US,831 std::intmax_t{shiftVal}, std::intmax_t{sizeVal});832 break;833 }834 }835 }836 }837 }838 if (name == "ishft") {839 return FoldElementalIntrinsic<T, T, Int4>(context, std::move(funcRef),840 ScalarFunc<T, T, Int4>(841 [&](const Scalar<T> &i, const Scalar<Int4> &shift) -> Scalar<T> {842 return i.ISHFT(static_cast<int>(shift.ToInt64()));843 }));844 } else if (!args.at(2)) { // ISHFTC(no SIZE=)845 return FoldElementalIntrinsic<T, T, Int4>(context, std::move(funcRef),846 ScalarFunc<T, T, Int4>(847 [&](const Scalar<T> &i, const Scalar<Int4> &shift) -> Scalar<T> {848 return i.ISHFTC(static_cast<int>(shift.ToInt64()));849 }));850 } else { // ISHFTC(with SIZE=)851 return FoldElementalIntrinsic<T, T, Int4, Int4>(context,852 std::move(funcRef),853 ScalarFunc<T, T, Int4, Int4>(854 [&](const Scalar<T> &i, const Scalar<Int4> &shift,855 const Scalar<Int4> &size) -> Scalar<T> {856 auto shiftVal{static_cast<int>(shift.ToInt64())};857 auto sizeVal{static_cast<int>(size.ToInt64())};858 return i.ISHFTC(shiftVal, sizeVal);859 }),860 /*hasOptionalArgument=*/true);861 }862 } else if (name == "izext" || name == "jzext") {863 if (args.size() == 1) {864 if (auto *expr{UnwrapExpr<Expr<SomeKind<T::category>>>(args[0])}) {865 // Rewrite to IAND(INT(n,k),255_k) for k=KIND(T)866 intrinsic->name = "iand";867 auto converted{ConvertToType<T>(std::move(*expr))};868 *expr =869 Fold(context, Expr<SomeKind<T::category>>{std::move(converted)});870 args.emplace_back(AsGenericExpr(Expr<T>{Scalar<T>{255}}));871 return FoldIntrinsicFunction(context, std::move(funcRef));872 }873 }874 } else if (name == "maskl" || name == "maskr" || name == "umaskl" ||875 name == "umaskr") {876 // Argument can be of any kind but value has to be smaller than BIT_SIZE.877 // It can be safely converted to Int4 to simplify.878 const auto fptr{name == "maskl" || name == "umaskl" ? &Scalar<T>::MASKL879 : &Scalar<T>::MASKR};880 return FoldElementalIntrinsic<T, Int4>(context, std::move(funcRef),881 ScalarFunc<T, Int4>([&fptr](const Scalar<Int4> &places) -> Scalar<T> {882 return fptr(static_cast<int>(places.ToInt64()));883 }));884 } else if (name == "matmul") {885 return FoldMatmul(context, std::move(funcRef));886 } else if (name == "max") {887 return FoldMINorMAX(context, std::move(funcRef), Ordering::Greater);888 } else if (name == "maxval") {889 return FoldMaxvalMinval<T>(context, std::move(funcRef),890 RelationalOperator::GT,891 T::category == TypeCategory::Unsigned ? typename T::Scalar{}892 : T::Scalar::Least());893 } else if (name == "merge_bits") {894 return FoldElementalIntrinsic<T, T, T, T>(895 context, std::move(funcRef), &Scalar<T>::MERGE_BITS);896 } else if (name == "min") {897 return FoldMINorMAX(context, std::move(funcRef), Ordering::Less);898 } else if (name == "minval") {899 return FoldMaxvalMinval<T>(context, std::move(funcRef),900 RelationalOperator::LT,901 T::category == TypeCategory::Unsigned ? typename T::Scalar{}.NOT()902 : T::Scalar::HUGE());903 } else if (name == "not") {904 return FoldElementalIntrinsic<T, T>(905 context, std::move(funcRef), &Scalar<T>::NOT);906 } else if (name == "product") {907 return FoldProduct<T>(context, std::move(funcRef), Scalar<T>{1});908 } else if (name == "radix") {909 return Expr<T>{2};910 } else if (name == "shifta" || name == "shiftr" || name == "shiftl") {911 // Second argument can be of any kind. However, it must be smaller or912 // equal than BIT_SIZE. It can be converted to Int4 to simplify.913 auto fptr{&Scalar<T>::SHIFTA};914 if (name == "shifta") { // done in fptr definition915 } else if (name == "shiftr") {916 fptr = &Scalar<T>::SHIFTR;917 } else if (name == "shiftl") {918 fptr = &Scalar<T>::SHIFTL;919 } else {920 common::die("missing case to fold intrinsic function %s", name.c_str());921 }922 if (const auto *argCon{Folder<T>(context).Folding(args[0])};923 argCon && argCon->empty()) {924 } else if (const auto *shiftCon{Folder<Int4>(context).Folding(args[1])}) {925 for (const auto &scalar : shiftCon->values()) {926 std::int64_t shiftVal{scalar.ToInt64()};927 if (shiftVal < 0) {928 context.messages().Say("SHIFT=%jd count for %s is negative"_err_en_US,929 std::intmax_t{shiftVal}, name, -T::Scalar::bits);930 break;931 } else if (shiftVal > T::Scalar::bits) {932 context.messages().Say(933 "SHIFT=%jd count for %s is greater than %d"_err_en_US,934 std::intmax_t{shiftVal}, name, T::Scalar::bits);935 break;936 }937 }938 }939 return FoldElementalIntrinsic<T, T, Int4>(context, std::move(funcRef),940 ScalarFunc<T, T, Int4>(941 [&](const Scalar<T> &i, const Scalar<Int4> &shift) -> Scalar<T> {942 return std::invoke(fptr, i, static_cast<int>(shift.ToInt64()));943 }));944 } else if (name == "sum") {945 return FoldSum<T>(context, std::move(funcRef));946 }947 return std::nullopt;948}949 950template <int KIND>951Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(952 FoldingContext &context,953 FunctionRef<Type<TypeCategory::Integer, KIND>> &&funcRef) {954 if (auto foldedCommon{FoldIntrinsicFunctionCommon(context, funcRef)}) {955 return std::move(*foldedCommon);956 }957 958 using T = Type<TypeCategory::Integer, KIND>;959 ActualArguments &args{funcRef.arguments()};960 auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)};961 CHECK(intrinsic);962 std::string name{intrinsic->name};963 964 auto FromInt64{[&name, &context](std::int64_t n) {965 Scalar<T> result{n};966 if (result.ToInt64() != n) {967 context.Warn(common::UsageWarning::FoldingException,968 "Result of intrinsic function '%s' (%jd) overflows its result type"_warn_en_US,969 name, std::intmax_t{n});970 }971 return result;972 }};973 974 if (name == "abs") { // incl. babs, iiabs, jiaabs, & kiabs975 return FoldElementalIntrinsic<T, T>(context, std::move(funcRef),976 ScalarFunc<T, T>([&context](const Scalar<T> &i) -> Scalar<T> {977 typename Scalar<T>::ValueWithOverflow j{i.ABS()};978 if (j.overflow) {979 context.Warn(common::UsageWarning::FoldingException,980 "abs(integer(kind=%d)) folding overflowed"_warn_en_US, KIND);981 }982 return j.value;983 }));984 } else if (name == "ceiling" || name == "floor" || name == "nint") {985 if (const auto *cx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {986 // NINT rounds ties away from zero, not to even987 common::RoundingMode mode{name == "ceiling" ? common::RoundingMode::Up988 : name == "floor" ? common::RoundingMode::Down989 : common::RoundingMode::TiesAwayFromZero};990 return common::visit(991 [&](const auto &kx) {992 using TR = ResultType<decltype(kx)>;993 return FoldElementalIntrinsic<T, TR>(context, std::move(funcRef),994 ScalarFunc<T, TR>([&](const Scalar<TR> &x) {995 auto y{x.template ToInteger<Scalar<T>>(mode)};996 if (y.flags.test(RealFlag::Overflow)) {997 context.Warn(common::UsageWarning::FoldingException,998 "%s intrinsic folding overflow"_warn_en_US, name);999 }1000 return y.value;1001 }));1002 },1003 cx->u);1004 }1005 } else if (name == "count") {1006 int maskKind = args[0]->GetType()->kind();1007 switch (maskKind) {1008 SWITCH_COVERS_ALL_CASES1009 case 1:1010 return FoldCount<T, 1>(context, std::move(funcRef));1011 case 2:1012 return FoldCount<T, 2>(context, std::move(funcRef));1013 case 4:1014 return FoldCount<T, 4>(context, std::move(funcRef));1015 case 8:1016 return FoldCount<T, 8>(context, std::move(funcRef));1017 }1018 } else if (name == "dim") {1019 return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),1020 ScalarFunc<T, T, T>(1021 [&context](const Scalar<T> &x, const Scalar<T> &y) -> Scalar<T> {1022 auto result{x.DIM(y)};1023 if (result.overflow) {1024 context.Warn(common::UsageWarning::FoldingException,1025 "DIM intrinsic folding overflow"_warn_en_US);1026 }1027 return result.value;1028 }));1029 } else if (name == "exponent") {1030 if (auto *sx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {1031 return common::visit(1032 [&funcRef, &context](const auto &x) -> Expr<T> {1033 using TR = typename std::decay_t<decltype(x)>::Result;1034 return FoldElementalIntrinsic<T, TR>(context, std::move(funcRef),1035 &Scalar<TR>::template EXPONENT<Scalar<T>>);1036 },1037 sx->u);1038 } else {1039 DIE("exponent argument must be real");1040 }1041 } else if (name == "findloc") {1042 return FoldLocation<WhichLocation::Findloc, T>(context, std::move(funcRef));1043 } else if (name == "huge") {1044 return Expr<T>{Scalar<T>::HUGE()};1045 } else if (name == "iachar" || name == "ichar") {1046 auto *someChar{UnwrapExpr<Expr<SomeCharacter>>(args[0])};1047 CHECK(someChar);1048 if (auto len{ToInt64(someChar->LEN())}) {1049 if (len.value() < 1) {1050 context.messages().Say(1051 "Character in intrinsic function %s must have length one"_err_en_US,1052 name);1053 } else {1054 // Do not die, this was not checked before1055 if (len.value() > 1) {1056 context.Warn(common::UsageWarning::Portability,1057 "Character in intrinsic function %s should have length one"_port_en_US,1058 name);1059 }1060 return common::visit(1061 [&funcRef, &context, &FromInt64](const auto &str) -> Expr<T> {1062 using Char = typename std::decay_t<decltype(str)>::Result;1063 (void)FromInt64;1064 return FoldElementalIntrinsic<T, Char>(context,1065 std::move(funcRef),1066 ScalarFunc<T, Char>(1067#ifndef _MSC_VER1068 [&FromInt64](const Scalar<Char> &c) {1069 return FromInt64(CharacterUtils<Char::kind>::ICHAR(1070 CharacterUtils<Char::kind>::Resize(c, 1)));1071 }));1072#else // _MSC_VER1073 // MSVC 14 get confused by the original code above and1074 // ends up emitting an error about passing a std::string1075 // to the std::u16string instantiation of1076 // CharacterUtils<2>::ICHAR(). Can't find a work-around,1077 // so remove the FromInt64 error checking lambda that1078 // seems to have caused the proble.1079 [](const Scalar<Char> &c) {1080 return CharacterUtils<Char::kind>::ICHAR(1081 CharacterUtils<Char::kind>::Resize(c, 1));1082 }));1083#endif // _MSC_VER1084 },1085 someChar->u);1086 }1087 }1088 } else if (name == "index" || name == "scan" || name == "verify") {1089 if (auto *charExpr{UnwrapExpr<Expr<SomeCharacter>>(args[0])}) {1090 return common::visit(1091 [&](const auto &kch) -> Expr<T> {1092 using TC = typename std::decay_t<decltype(kch)>::Result;1093 if (UnwrapExpr<Expr<SomeLogical>>(args[2])) { // BACK=1094 return FoldElementalIntrinsic<T, TC, TC, LogicalResult>(context,1095 std::move(funcRef),1096 ScalarFunc<T, TC, TC, LogicalResult>{1097 [&name, &FromInt64](const Scalar<TC> &str,1098 const Scalar<TC> &other,1099 const Scalar<LogicalResult> &back) {1100 return FromInt64(name == "index"1101 ? CharacterUtils<TC::kind>::INDEX(1102 str, other, back.IsTrue())1103 : name == "scan"1104 ? CharacterUtils<TC::kind>::SCAN(1105 str, other, back.IsTrue())1106 : CharacterUtils<TC::kind>::VERIFY(1107 str, other, back.IsTrue()));1108 }});1109 } else {1110 return FoldElementalIntrinsic<T, TC, TC>(context,1111 std::move(funcRef),1112 ScalarFunc<T, TC, TC>{1113 [&name, &FromInt64](1114 const Scalar<TC> &str, const Scalar<TC> &other) {1115 return FromInt64(name == "index"1116 ? CharacterUtils<TC::kind>::INDEX(str, other)1117 : name == "scan"1118 ? CharacterUtils<TC::kind>::SCAN(str, other)1119 : CharacterUtils<TC::kind>::VERIFY(str, other));1120 }});1121 }1122 },1123 charExpr->u);1124 } else {1125 DIE("first argument must be CHARACTER");1126 }1127 } else if (name == "int_ptr_kind") {1128 return Expr<T>{8};1129 } else if (name == "kind") {1130 // FoldOperation(FunctionRef &&) in fold-implementation.h will not1131 // have folded the argument; in the case of TypeParamInquiry,1132 // try to get the type of the parameter itself.1133 if (const auto *expr{args[0] ? args[0]->UnwrapExpr() : nullptr}) {1134 if (const auto *inquiry{UnwrapExpr<TypeParamInquiry>(*expr)}) {1135 if (const auto *typeSpec{inquiry->parameter().GetType()}) {1136 if (const auto *intrinType{typeSpec->AsIntrinsic()}) {1137 if (auto k{ToInt64(Fold(1138 context, Expr<SubscriptInteger>{intrinType->kind()}))}) {1139 return Expr<T>{*k};1140 }1141 }1142 }1143 } else if (auto dyType{expr->GetType()}) {1144 return Expr<T>{dyType->kind()};1145 }1146 }1147 } else if (name == "lbound") {1148 return LBOUND(context, std::move(funcRef));1149 } else if (name == "lcobound") {1150 return COBOUND(context, std::move(funcRef), /*isUCOBOUND=*/false);1151 } else if (name == "leadz" || name == "trailz" || name == "poppar" ||1152 name == "popcnt") {1153 if (auto *sn{UnwrapExpr<Expr<SomeKind<T::category>>>(args[0])}) {1154 return common::visit(1155 [&funcRef, &context, &name](const auto &n) -> Expr<T> {1156 using TI = typename std::decay_t<decltype(n)>::Result;1157 if (name == "poppar") {1158 return FoldElementalIntrinsic<T, TI>(context, std::move(funcRef),1159 ScalarFunc<T, TI>([](const Scalar<TI> &i) -> Scalar<T> {1160 return Scalar<T>{i.POPPAR() ? 1 : 0};1161 }));1162 }1163 auto fptr{&Scalar<TI>::LEADZ};1164 if (name == "leadz") { // done in fptr definition1165 } else if (name == "trailz") {1166 fptr = &Scalar<TI>::TRAILZ;1167 } else if (name == "popcnt") {1168 fptr = &Scalar<TI>::POPCNT;1169 } else {1170 common::die(1171 "missing case to fold intrinsic function %s", name.c_str());1172 }1173 return FoldElementalIntrinsic<T, TI>(context, std::move(funcRef),1174 // `i` should be declared as `const Scalar<TI>&`.1175 // We declare it as `auto` to workaround an msvc bug:1176 // https://developercommunity.visualstudio.com/t/Regression:-nested-closure-assumes-wrong/101302231177 ScalarFunc<T, TI>([&fptr](const auto &i) -> Scalar<T> {1178 return Scalar<T>{std::invoke(fptr, i)};1179 }));1180 },1181 sn->u);1182 } else {1183 DIE("leadz argument must be integer");1184 }1185 } else if (name == "len") {1186 if (auto *charExpr{UnwrapExpr<Expr<SomeCharacter>>(args[0])}) {1187 return common::visit(1188 [&](auto &kx) {1189 if (auto len{kx.LEN()}) {1190 if (IsScopeInvariantExpr(*len)) {1191 return Fold(context, ConvertToType<T>(*std::move(len)));1192 } else {1193 return Expr<T>{std::move(funcRef)};1194 }1195 } else {1196 return Expr<T>{std::move(funcRef)};1197 }1198 },1199 charExpr->u);1200 } else {1201 DIE("len() argument must be of character type");1202 }1203 } else if (name == "len_trim") {1204 if (auto *charExpr{UnwrapExpr<Expr<SomeCharacter>>(args[0])}) {1205 return common::visit(1206 [&](const auto &kch) -> Expr<T> {1207 using TC = typename std::decay_t<decltype(kch)>::Result;1208 return FoldElementalIntrinsic<T, TC>(context, std::move(funcRef),1209 ScalarFunc<T, TC>{[&FromInt64](const Scalar<TC> &str) {1210 return FromInt64(CharacterUtils<TC::kind>::LEN_TRIM(str));1211 }});1212 },1213 charExpr->u);1214 } else {1215 DIE("len_trim() argument must be of character type");1216 }1217 } else if (name == "max0" || name == "max1") {1218 return RewriteSpecificMINorMAX(context, std::move(funcRef));1219 } else if (name == "maxexponent") {1220 if (auto *sx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {1221 return common::visit(1222 [](const auto &x) {1223 using TR = typename std::decay_t<decltype(x)>::Result;1224 return Expr<T>{Scalar<TR>::MAXEXPONENT};1225 },1226 sx->u);1227 }1228 } else if (name == "maxloc") {1229 return FoldLocation<WhichLocation::Maxloc, T>(context, std::move(funcRef));1230 } else if (name == "min0" || name == "min1") {1231 return RewriteSpecificMINorMAX(context, std::move(funcRef));1232 } else if (name == "minexponent") {1233 if (auto *sx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {1234 return common::visit(1235 [](const auto &x) {1236 using TR = typename std::decay_t<decltype(x)>::Result;1237 return Expr<T>{Scalar<TR>::MINEXPONENT};1238 },1239 sx->u);1240 }1241 } else if (name == "minloc") {1242 return FoldLocation<WhichLocation::Minloc, T>(context, std::move(funcRef));1243 } else if (name == "mod") {1244 bool badPConst{false};1245 if (auto *pExpr{UnwrapExpr<Expr<T>>(args[1])}) {1246 *pExpr = Fold(context, std::move(*pExpr));1247 if (auto pConst{GetScalarConstantValue<T>(*pExpr)};1248 pConst && pConst->IsZero()) {1249 context.Warn(common::UsageWarning::FoldingAvoidsRuntimeCrash,1250 "MOD: P argument is zero"_warn_en_US);1251 badPConst = true;1252 }1253 }1254 return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),1255 ScalarFuncWithContext<T, T, T>(1256 [badPConst](FoldingContext &context, const Scalar<T> &x,1257 const Scalar<T> &y) -> Scalar<T> {1258 auto quotRem{x.DivideSigned(y)};1259 if (!badPConst && quotRem.divisionByZero) {1260 context.Warn(common::UsageWarning::FoldingAvoidsRuntimeCrash,1261 "mod() by zero"_warn_en_US);1262 } else if (quotRem.overflow) {1263 context.Warn(common::UsageWarning::FoldingAvoidsRuntimeCrash,1264 "mod() folding overflowed"_warn_en_US);1265 }1266 return quotRem.remainder;1267 }));1268 } else if (name == "modulo") {1269 bool badPConst{false};1270 if (auto *pExpr{UnwrapExpr<Expr<T>>(args[1])}) {1271 *pExpr = Fold(context, std::move(*pExpr));1272 if (auto pConst{GetScalarConstantValue<T>(*pExpr)};1273 pConst && pConst->IsZero()) {1274 context.Warn(common::UsageWarning::FoldingAvoidsRuntimeCrash,1275 "MODULO: P argument is zero"_warn_en_US);1276 badPConst = true;1277 }1278 }1279 return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),1280 ScalarFuncWithContext<T, T, T>([badPConst](FoldingContext &context,1281 const Scalar<T> &x,1282 const Scalar<T> &y) -> Scalar<T> {1283 auto result{x.MODULO(y)};1284 if (!badPConst && result.overflow) {1285 context.Warn(common::UsageWarning::FoldingException,1286 "modulo() folding overflowed"_warn_en_US);1287 }1288 return result.value;1289 }));1290 } else if (name == "precision") {1291 if (const auto *cx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {1292 return Expr<T>{common::visit(1293 [](const auto &kx) {1294 return Scalar<ResultType<decltype(kx)>>::PRECISION;1295 },1296 cx->u)};1297 } else if (const auto *cx{UnwrapExpr<Expr<SomeComplex>>(args[0])}) {1298 return Expr<T>{common::visit(1299 [](const auto &kx) {1300 return Scalar<typename ResultType<decltype(kx)>::Part>::PRECISION;1301 },1302 cx->u)};1303 }1304 } else if (name == "range") {1305 if (const auto *cx{UnwrapExpr<Expr<SomeInteger>>(args[0])}) {1306 return Expr<T>{common::visit(1307 [](const auto &kx) {1308 return Scalar<ResultType<decltype(kx)>>::RANGE;1309 },1310 cx->u)};1311 } else if (const auto *cx{UnwrapExpr<Expr<SomeUnsigned>>(args[0])}) {1312 return Expr<T>{common::visit(1313 [](const auto &kx) {1314 return Scalar<ResultType<decltype(kx)>>::UnsignedRANGE;1315 },1316 cx->u)};1317 } else if (const auto *cx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {1318 return Expr<T>{common::visit(1319 [](const auto &kx) {1320 return Scalar<ResultType<decltype(kx)>>::RANGE;1321 },1322 cx->u)};1323 } else if (const auto *cx{UnwrapExpr<Expr<SomeComplex>>(args[0])}) {1324 return Expr<T>{common::visit(1325 [](const auto &kx) {1326 return Scalar<typename ResultType<decltype(kx)>::Part>::RANGE;1327 },1328 cx->u)};1329 }1330 } else if (name == "rank") {1331 if (args[0]) {1332 const Symbol *symbol{nullptr};1333 if (auto dataRef{ExtractDataRef(args[0])}) {1334 symbol = &dataRef->GetLastSymbol();1335 } else {1336 symbol = args[0]->GetAssumedTypeDummy();1337 }1338 if (symbol && IsAssumedRank(*symbol)) {1339 // DescriptorInquiry can only be placed in expression of kind1340 // DescriptorInquiry::Result::kind.1341 return ConvertToType<T>(1342 Expr<Type<TypeCategory::Integer, DescriptorInquiry::Result::kind>>{1343 DescriptorInquiry{1344 NamedEntity{*symbol}, DescriptorInquiry::Field::Rank}});1345 }1346 return Expr<T>{args[0]->Rank()};1347 }1348 } else if (name == "selected_char_kind") {1349 if (const auto *chCon{UnwrapExpr<Constant<TypeOf<std::string>>>(args[0])}) {1350 if (std::optional<std::string> value{chCon->GetScalarValue()}) {1351 int defaultKind{1352 context.defaults().GetDefaultKind(TypeCategory::Character)};1353 return Expr<T>{SelectedCharKind(*value, defaultKind)};1354 }1355 }1356 } else if (name == "selected_int_kind" || name == "selected_unsigned_kind") {1357 if (auto p{ToInt64(args[0])}) {1358 return Expr<T>{context.targetCharacteristics().SelectedIntKind(*p)};1359 }1360 } else if (name == "selected_logical_kind") {1361 if (auto p{ToInt64(args[0])}) {1362 return Expr<T>{context.targetCharacteristics().SelectedLogicalKind(*p)};1363 }1364 } else if (name == "selected_real_kind" ||1365 name == "__builtin_ieee_selected_real_kind") {1366 if (auto p{GetInt64ArgOr(args[0], 0)}) {1367 if (auto r{GetInt64ArgOr(args[1], 0)}) {1368 if (auto radix{GetInt64ArgOr(args[2], 2)}) {1369 return Expr<T>{1370 context.targetCharacteristics().SelectedRealKind(*p, *r, *radix)};1371 }1372 }1373 }1374 } else if (name == "shape") {1375 if (auto shape{GetContextFreeShape(context, args[0])}) {1376 if (auto shapeExpr{AsExtentArrayExpr(*shape)}) {1377 return Fold(context, ConvertToType<T>(std::move(*shapeExpr)));1378 }1379 }1380 } else if (name == "sign") {1381 return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),1382 ScalarFunc<T, T, T>([&context](const Scalar<T> &j,1383 const Scalar<T> &k) -> Scalar<T> {1384 typename Scalar<T>::ValueWithOverflow result{j.SIGN(k)};1385 if (result.overflow) {1386 context.Warn(common::UsageWarning::FoldingException,1387 "sign(integer(kind=%d)) folding overflowed"_warn_en_US, KIND);1388 }1389 return result.value;1390 }));1391 } else if (name == "size") {1392 if (auto shape{GetContextFreeShape(context, args[0])}) {1393 if (args[1]) { // DIM= is present, get one extent1394 std::optional<int> dim;1395 if (const auto *array{args[0].value().UnwrapExpr()}; array &&1396 !CheckDimArg(args[1], *array, context.messages(), false, dim)) {1397 return MakeInvalidIntrinsic<T>(std::move(funcRef));1398 } else if (dim) {1399 if (auto &extent{shape->at(*dim)}) {1400 return Fold(context, ConvertToType<T>(std::move(*extent)));1401 }1402 }1403 } else if (auto extents{common::AllElementsPresent(std::move(*shape))}) {1404 // DIM= is absent; compute PRODUCT(SHAPE())1405 ExtentExpr product{1};1406 for (auto &&extent : std::move(*extents)) {1407 product = std::move(product) * std::move(extent);1408 }1409 return Expr<T>{ConvertToType<T>(Fold(context, std::move(product)))};1410 }1411 }1412 } else if (name == "sizeof") { // in bytes; extension1413 if (auto info{1414 characteristics::TypeAndShape::Characterize(args[0], context)}) {1415 if (auto bytes{info->MeasureSizeInBytes(context)}) {1416 return Expr<T>{Fold(context, ConvertToType<T>(std::move(*bytes)))};1417 }1418 }1419 } else if (name == "storage_size") { // in bits1420 if (auto info{1421 characteristics::TypeAndShape::Characterize(args[0], context)}) {1422 if (auto bytes{info->MeasureElementSizeInBytes(context, true)}) {1423 return Expr<T>{1424 Fold(context, Expr<T>{8} * ConvertToType<T>(std::move(*bytes)))};1425 }1426 }1427 } else if (name == "ubound") {1428 return UBOUND(context, std::move(funcRef));1429 } else if (name == "ucobound") {1430 return COBOUND(context, std::move(funcRef), /*isUCOBOUND=*/true);1431 } else if (name == "__builtin_numeric_storage_size") {1432 if (!context.moduleFileName()) {1433 // Don't fold this reference until it appears in the module file1434 // for ISO_FORTRAN_ENV -- the value depends on the compiler options1435 // that might be in force.1436 } else {1437 auto intBytes{1438 context.targetCharacteristics().GetByteSize(TypeCategory::Integer,1439 context.defaults().GetDefaultKind(TypeCategory::Integer))};1440 auto realBytes{1441 context.targetCharacteristics().GetByteSize(TypeCategory::Real,1442 context.defaults().GetDefaultKind(TypeCategory::Real))};1443 if (intBytes != realBytes) {1444 // Using the low-level API to bypass the module file check in this case.1445 context.messages().Warn(1446 /*isInModuleFile=*/false, context.languageFeatures(),1447 common::UsageWarning::FoldingValueChecks, *context.moduleFileName(),1448 "NUMERIC_STORAGE_SIZE from ISO_FORTRAN_ENV is not well-defined when default INTEGER and REAL are not consistent due to compiler options"_warn_en_US);1449 }1450 return Expr<T>{8 * std::min(intBytes, realBytes)};1451 }1452 }1453 return Expr<T>{std::move(funcRef)};1454}1455 1456template <int KIND>1457Expr<Type<TypeCategory::Unsigned, KIND>> FoldIntrinsicFunction(1458 FoldingContext &context,1459 FunctionRef<Type<TypeCategory::Unsigned, KIND>> &&funcRef) {1460 if (auto foldedCommon{FoldIntrinsicFunctionCommon(context, funcRef)}) {1461 return std::move(*foldedCommon);1462 }1463 using T = Type<TypeCategory::Unsigned, KIND>;1464 ActualArguments &args{funcRef.arguments()};1465 auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)};1466 CHECK(intrinsic);1467 std::string name{intrinsic->name};1468 if (name == "huge") {1469 return Expr<T>{Scalar<T>{}.NOT()};1470 } else if (name == "mod" || name == "modulo") {1471 bool badPConst{false};1472 if (auto *pExpr{UnwrapExpr<Expr<T>>(args[1])}) {1473 *pExpr = Fold(context, std::move(*pExpr));1474 if (auto pConst{GetScalarConstantValue<T>(*pExpr)};1475 pConst && pConst->IsZero()) {1476 context.Warn(common::UsageWarning::FoldingAvoidsRuntimeCrash,1477 "%s: P argument is zero"_warn_en_US, name);1478 badPConst = true;1479 }1480 }1481 return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),1482 ScalarFuncWithContext<T, T, T>(1483 [badPConst, &name](FoldingContext &context, const Scalar<T> &x,1484 const Scalar<T> &y) -> Scalar<T> {1485 auto quotRem{x.DivideUnsigned(y)};1486 if (!badPConst && quotRem.divisionByZero) {1487 context.Warn(common::UsageWarning::FoldingAvoidsRuntimeCrash,1488 "%s() by zero"_warn_en_US, name);1489 }1490 return quotRem.remainder;1491 }));1492 }1493 return Expr<T>{std::move(funcRef)};1494}1495 1496// Substitutes a bare type parameter reference with its value if it has one now1497// in an instantiation. Bare LEN type parameters are substituted only when1498// the known value is constant.1499Expr<TypeParamInquiry::Result> FoldOperation(1500 FoldingContext &context, TypeParamInquiry &&inquiry) {1501 std::optional<NamedEntity> base{inquiry.base()};1502 parser::CharBlock parameterName{inquiry.parameter().name()};1503 if (base) {1504 // Handling "designator%typeParam". Get the value of the type parameter1505 // from the instantiation of the base1506 if (const semantics::DeclTypeSpec *1507 declType{base->GetLastSymbol().GetType()}) {1508 if (const semantics::ParamValue *1509 paramValue{1510 declType->derivedTypeSpec().FindParameter(parameterName)}) {1511 const semantics::MaybeIntExpr ¶mExpr{paramValue->GetExplicit()};1512 if (paramExpr && IsConstantExpr(*paramExpr)) {1513 Expr<SomeInteger> intExpr{*paramExpr};1514 return Fold(context,1515 ConvertToType<TypeParamInquiry::Result>(std::move(intExpr)));1516 }1517 }1518 }1519 } else {1520 // A "bare" type parameter: replace with its value, if that's now known1521 // in a current derived type instantiation.1522 if (const auto *pdt{context.pdtInstance()}) {1523 auto restorer{context.WithoutPDTInstance()}; // don't loop1524 bool isLen{false};1525 if (const semantics::Scope * scope{pdt->scope()}) {1526 auto iter{scope->find(parameterName)};1527 if (iter != scope->end()) {1528 const Symbol &symbol{*iter->second};1529 const auto *details{symbol.detailsIf<semantics::TypeParamDetails>()};1530 if (details) {1531 isLen = details->attr() == common::TypeParamAttr::Len;1532 const semantics::MaybeIntExpr &initExpr{details->init()};1533 if (initExpr && IsConstantExpr(*initExpr) &&1534 (!isLen || ToInt64(*initExpr))) {1535 Expr<SomeInteger> expr{*initExpr};1536 return Fold(context,1537 ConvertToType<TypeParamInquiry::Result>(std::move(expr)));1538 }1539 }1540 }1541 }1542 if (const auto *value{pdt->FindParameter(parameterName)}) {1543 if (value->isExplicit()) {1544 auto folded{Fold(context,1545 AsExpr(ConvertToType<TypeParamInquiry::Result>(1546 Expr<SomeInteger>{value->GetExplicit().value()})))};1547 if (!isLen || ToInt64(folded)) {1548 return folded;1549 }1550 }1551 }1552 }1553 }1554 return AsExpr(std::move(inquiry));1555}1556 1557std::optional<std::int64_t> ToInt64(const Expr<SomeInteger> &expr) {1558 return common::visit(1559 [](const auto &kindExpr) { return ToInt64(kindExpr); }, expr.u);1560}1561 1562std::optional<std::int64_t> ToInt64(const Expr<SomeUnsigned> &expr) {1563 return common::visit(1564 [](const auto &kindExpr) { return ToInt64(kindExpr); }, expr.u);1565}1566 1567std::optional<std::int64_t> ToInt64(const Expr<SomeType> &expr) {1568 if (const auto *intExpr{UnwrapExpr<Expr<SomeInteger>>(expr)}) {1569 return ToInt64(*intExpr);1570 } else if (const auto *unsignedExpr{UnwrapExpr<Expr<SomeUnsigned>>(expr)}) {1571 return ToInt64(*unsignedExpr);1572 } else {1573 return std::nullopt;1574 }1575}1576 1577std::optional<std::int64_t> ToInt64(const ActualArgument &arg) {1578 return ToInt64(arg.UnwrapExpr());1579}1580 1581#ifdef _MSC_VER // disable bogus warning about missing definitions1582#pragma warning(disable : 4661)1583#endif1584FOR_EACH_INTEGER_KIND(template class ExpressionBase, )1585FOR_EACH_UNSIGNED_KIND(template class ExpressionBase, )1586template class ExpressionBase<SomeInteger>;1587template class ExpressionBase<SomeUnsigned>;1588} // namespace Fortran::evaluate1589