1244 lines · cpp
1//===-- lib/Evaluate/shape.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 "flang/Evaluate/shape.h"10#include "flang/Common/idioms.h"11#include "flang/Common/template.h"12#include "flang/Evaluate/characteristics.h"13#include "flang/Evaluate/check-expression.h"14#include "flang/Evaluate/fold.h"15#include "flang/Evaluate/intrinsics.h"16#include "flang/Evaluate/tools.h"17#include "flang/Evaluate/type.h"18#include "flang/Parser/message.h"19#include "flang/Semantics/semantics.h"20#include "flang/Semantics/symbol.h"21#include <functional>22 23using namespace std::placeholders; // _1, _2, &c. for std::bind()24 25namespace Fortran::evaluate {26 27FoldingContext &GetFoldingContextFrom(const Symbol &symbol) {28 return symbol.owner().context().foldingContext();29}30 31bool IsImpliedShape(const Symbol &original) {32 const Symbol &symbol{ResolveAssociations(original)};33 const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()};34 return details && symbol.attrs().test(semantics::Attr::PARAMETER) &&35 details->shape().CanBeImpliedShape();36}37 38bool IsExplicitShape(const Symbol &original) {39 const Symbol &symbol{ResolveAssociations(original)};40 if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {41 const auto &shape{details->shape()};42 return shape.Rank() == 0 ||43 shape.IsExplicitShape(); // true when scalar, too44 } else {45 return symbol46 .has<semantics::AssocEntityDetails>(); // exprs have explicit shape47 }48}49 50Shape GetShapeHelper::ConstantShape(const Constant<ExtentType> &arrayConstant) {51 CHECK(arrayConstant.Rank() == 1);52 Shape result;53 std::size_t dimensions{arrayConstant.size()};54 for (std::size_t j{0}; j < dimensions; ++j) {55 Scalar<ExtentType> extent{arrayConstant.values().at(j)};56 result.emplace_back(MaybeExtentExpr{ExtentExpr{std::move(extent)}});57 }58 return result;59}60 61auto GetShapeHelper::AsShapeResult(ExtentExpr &&arrayExpr) const -> Result {62 if (context_) {63 arrayExpr = Fold(*context_, std::move(arrayExpr));64 }65 if (const auto *constArray{UnwrapConstantValue<ExtentType>(arrayExpr)}) {66 return ConstantShape(*constArray);67 }68 if (auto *constructor{UnwrapExpr<ArrayConstructor<ExtentType>>(arrayExpr)}) {69 Shape result;70 for (auto &value : *constructor) {71 auto *expr{std::get_if<ExtentExpr>(&value.u)};72 if (expr && expr->Rank() == 0) {73 result.emplace_back(std::move(*expr));74 } else {75 return std::nullopt;76 }77 }78 return result;79 } else {80 return std::nullopt;81 }82}83 84Shape GetShapeHelper::CreateShape(int rank, NamedEntity &base) const {85 Shape shape;86 for (int dimension{0}; dimension < rank; ++dimension) {87 shape.emplace_back(GetExtent(base, dimension, invariantOnly_));88 }89 return shape;90}91 92std::optional<ExtentExpr> AsExtentArrayExpr(const Shape &shape) {93 ArrayConstructorValues<ExtentType> values;94 for (const auto &dim : shape) {95 if (dim) {96 values.Push(common::Clone(*dim));97 } else {98 return std::nullopt;99 }100 }101 return ExtentExpr{ArrayConstructor<ExtentType>{std::move(values)}};102}103 104std::optional<Constant<ExtentType>> AsConstantShape(105 FoldingContext &context, const Shape &shape) {106 if (auto shapeArray{AsExtentArrayExpr(shape)}) {107 auto folded{Fold(context, std::move(*shapeArray))};108 if (auto *p{UnwrapConstantValue<ExtentType>(folded)}) {109 return std::move(*p);110 }111 }112 return std::nullopt;113}114 115Constant<SubscriptInteger> AsConstantShape(const ConstantSubscripts &shape) {116 using IntType = Scalar<SubscriptInteger>;117 std::vector<IntType> result;118 for (auto dim : shape) {119 result.emplace_back(dim);120 }121 return {std::move(result), ConstantSubscripts{GetRank(shape)}};122}123 124ConstantSubscripts AsConstantExtents(const Constant<ExtentType> &shape) {125 ConstantSubscripts result;126 for (const auto &extent : shape.values()) {127 result.push_back(extent.ToInt64());128 }129 return result;130}131 132std::optional<ConstantSubscripts> AsConstantExtents(133 FoldingContext &context, const Shape &shape) {134 if (auto shapeConstant{AsConstantShape(context, shape)}) {135 return AsConstantExtents(*shapeConstant);136 } else {137 return std::nullopt;138 }139}140 141Shape AsShape(const ConstantSubscripts &shape) {142 Shape result;143 for (const auto &extent : shape) {144 result.emplace_back(ExtentExpr{extent});145 }146 return result;147}148 149std::optional<Shape> AsShape(const std::optional<ConstantSubscripts> &shape) {150 if (shape) {151 return AsShape(*shape);152 } else {153 return std::nullopt;154 }155}156 157Shape Fold(FoldingContext &context, Shape &&shape) {158 for (auto &dim : shape) {159 dim = Fold(context, std::move(dim));160 }161 return std::move(shape);162}163 164std::optional<Shape> Fold(165 FoldingContext &context, std::optional<Shape> &&shape) {166 if (shape) {167 return Fold(context, std::move(*shape));168 } else {169 return std::nullopt;170 }171}172 173static ExtentExpr ComputeTripCount(174 ExtentExpr &&lower, ExtentExpr &&upper, ExtentExpr &&stride) {175 ExtentExpr strideCopy{common::Clone(stride)};176 ExtentExpr span{177 (std::move(upper) - std::move(lower) + std::move(strideCopy)) /178 std::move(stride)};179 return ExtentExpr{180 Extremum<ExtentType>{Ordering::Greater, std::move(span), ExtentExpr{0}}};181}182 183ExtentExpr CountTrips(184 ExtentExpr &&lower, ExtentExpr &&upper, ExtentExpr &&stride) {185 return ComputeTripCount(186 std::move(lower), std::move(upper), std::move(stride));187}188 189ExtentExpr CountTrips(const ExtentExpr &lower, const ExtentExpr &upper,190 const ExtentExpr &stride) {191 return ComputeTripCount(192 common::Clone(lower), common::Clone(upper), common::Clone(stride));193}194 195MaybeExtentExpr CountTrips(MaybeExtentExpr &&lower, MaybeExtentExpr &&upper,196 MaybeExtentExpr &&stride) {197 std::function<ExtentExpr(ExtentExpr &&, ExtentExpr &&, ExtentExpr &&)> bound{198 std::bind(ComputeTripCount, _1, _2, _3)};199 return common::MapOptional(200 std::move(bound), std::move(lower), std::move(upper), std::move(stride));201}202 203MaybeExtentExpr GetSize(Shape &&shape) {204 ExtentExpr extent{1};205 for (auto &&dim : std::move(shape)) {206 if (dim) {207 extent = std::move(extent) * std::move(*dim);208 } else {209 return std::nullopt;210 }211 }212 return extent;213}214 215ConstantSubscript GetSize(const ConstantSubscripts &shape) {216 ConstantSubscript size{1};217 for (auto dim : shape) {218 CHECK(dim >= 0);219 size *= dim;220 }221 return size;222}223 224bool ContainsAnyImpliedDoIndex(const ExtentExpr &expr) {225 struct MyVisitor : public AnyTraverse<MyVisitor> {226 using Base = AnyTraverse<MyVisitor>;227 MyVisitor() : Base{*this} {}228 using Base::operator();229 bool operator()(const ImpliedDoIndex &) { return true; }230 };231 return MyVisitor{}(expr);232}233 234// Determines lower bound on a dimension. This can be other than 1 only235// for a reference to a whole array object or component. (See LBOUND, 16.9.109).236// ASSOCIATE construct entities may require traversal of their referents.237template <typename RESULT, bool LBOUND_SEMANTICS>238class GetLowerBoundHelper239 : public Traverse<GetLowerBoundHelper<RESULT, LBOUND_SEMANTICS>, RESULT> {240public:241 using Result = RESULT;242 using Base = Traverse<GetLowerBoundHelper, RESULT>;243 using Base::operator();244 explicit GetLowerBoundHelper(245 int d, FoldingContext *context, bool invariantOnly)246 : Base{*this}, dimension_{d}, context_{context},247 invariantOnly_{invariantOnly} {}248 static Result Default() { return Result{1}; }249 static Result Combine(Result &&, Result &&) {250 // Operator results and array references always have lower bounds == 1251 return Result{1};252 }253 254 Result GetLowerBound(const Symbol &symbol0, NamedEntity &&base) const {255 const Symbol &symbol{symbol0.GetUltimate()};256 if (const auto *object{257 symbol.detailsIf<semantics::ObjectEntityDetails>()}) {258 int rank{object->shape().Rank()};259 if (dimension_ < rank) {260 const semantics::ShapeSpec &shapeSpec{object->shape()[dimension_]};261 if (shapeSpec.lbound().isExplicit()) {262 if (const auto &lbound{shapeSpec.lbound().GetExplicit()};263 lbound && lbound->Rank() == 0) {264 if constexpr (LBOUND_SEMANTICS) {265 bool ok{false};266 auto lbValue{ToInt64(*lbound)};267 if (dimension_ == rank - 1 &&268 semantics::IsAssumedSizeArray(symbol)) {269 // last dimension of assumed-size dummy array: don't worry270 // about handling an empty dimension271 ok = !invariantOnly_ || IsScopeInvariantExpr(*lbound);272 } else if (lbValue.value_or(0) == 1) {273 // Lower bound is 1, regardless of extent274 ok = true;275 } else if (const auto &ubound{shapeSpec.ubound().GetExplicit()};276 ubound && ubound->Rank() == 0) {277 // If we can't prove that the dimension is nonempty,278 // we must be conservative.279 // TODO: simple symbolic math in expression rewriting to280 // cope with cases like A(J:J)281 if (context_) {282 auto extent{ToInt64(Fold(*context_,283 ExtentExpr{*ubound} - ExtentExpr{*lbound} +284 ExtentExpr{1}))};285 if (extent) {286 if (extent <= 0) {287 return Result{1};288 }289 ok = true;290 } else {291 ok = false;292 }293 } else {294 auto ubValue{ToInt64(*ubound)};295 if (lbValue && ubValue) {296 if (*lbValue > *ubValue) {297 return Result{1};298 }299 ok = true;300 } else {301 ok = false;302 }303 }304 }305 return ok ? *lbound : Result{};306 } else {307 return *lbound;308 }309 } else {310 return Result{1};311 }312 }313 if (IsDescriptor(symbol)) {314 return ExtentExpr{DescriptorInquiry{std::move(base),315 DescriptorInquiry::Field::LowerBound, dimension_}};316 }317 }318 } else if (const auto *assoc{319 symbol.detailsIf<semantics::AssocEntityDetails>()}) {320 if (assoc->IsAssumedSize()) { // RANK(*)321 return Result{1};322 } else if (assoc->IsAssumedRank()) { // RANK DEFAULT323 } else if (assoc->rank()) { // RANK(n)324 const Symbol &resolved{ResolveAssociations(symbol)};325 if (IsDescriptor(resolved) && dimension_ < *assoc->rank()) {326 return ExtentExpr{DescriptorInquiry{std::move(base),327 DescriptorInquiry::Field::LowerBound, dimension_}};328 }329 } else {330 Result exprLowerBound{((*this)(assoc->expr()))};331 if (IsActuallyConstant(exprLowerBound)) {332 return std::move(exprLowerBound);333 } else {334 // If the lower bound of the associated entity is not resolved to a335 // constant expression at the time of the association, it is unsafe336 // to re-evaluate it later in the associate construct. Statements337 // in between may have modified its operands value.338 return ExtentExpr{DescriptorInquiry{std::move(base),339 DescriptorInquiry::Field::LowerBound, dimension_}};340 }341 }342 }343 if constexpr (LBOUND_SEMANTICS) {344 return Result{};345 } else {346 return Result{1};347 }348 }349 350 Result operator()(const Symbol &symbol) const {351 return GetLowerBound(symbol, NamedEntity{symbol});352 }353 354 Result operator()(const Component &component) const {355 if (component.base().Rank() == 0) {356 return GetLowerBound(357 component.GetLastSymbol(), NamedEntity{common::Clone(component)});358 }359 return Result{1};360 }361 362 template <typename T> Result operator()(const Expr<T> &expr) const {363 if (const Symbol * whole{UnwrapWholeSymbolOrComponentDataRef(expr)}) {364 return (*this)(*whole);365 } else if constexpr (common::HasMember<Constant<T>, decltype(expr.u)>) {366 if (const auto *con{std::get_if<Constant<T>>(&expr.u)}) {367 ConstantSubscripts lb{con->lbounds()};368 if (dimension_ < GetRank(lb)) {369 return Result{lb[dimension_]};370 }371 } else { // operation372 return Result{1};373 }374 } else {375 return (*this)(expr.u);376 }377 if constexpr (LBOUND_SEMANTICS) {378 return Result{};379 } else {380 return Result{1};381 }382 }383 384private:385 int dimension_; // zero-based386 FoldingContext *context_{nullptr};387 bool invariantOnly_{false};388};389 390ExtentExpr GetRawLowerBound(391 const NamedEntity &base, int dimension, bool invariantOnly) {392 return GetLowerBoundHelper<ExtentExpr, false>{393 dimension, nullptr, invariantOnly}(base);394}395 396ExtentExpr GetRawLowerBound(FoldingContext &context, const NamedEntity &base,397 int dimension, bool invariantOnly) {398 return Fold(context,399 GetLowerBoundHelper<ExtentExpr, false>{400 dimension, &context, invariantOnly}(base));401}402 403MaybeExtentExpr GetLBOUND(404 const NamedEntity &base, int dimension, bool invariantOnly) {405 return GetLowerBoundHelper<MaybeExtentExpr, true>{406 dimension, nullptr, invariantOnly}(base);407}408 409MaybeExtentExpr GetLBOUND(FoldingContext &context, const NamedEntity &base,410 int dimension, bool invariantOnly) {411 return Fold(context,412 GetLowerBoundHelper<MaybeExtentExpr, true>{413 dimension, &context, invariantOnly}(base));414}415 416Shape GetRawLowerBounds(const NamedEntity &base, bool invariantOnly) {417 Shape result;418 int rank{base.Rank()};419 for (int dim{0}; dim < rank; ++dim) {420 result.emplace_back(GetRawLowerBound(base, dim, invariantOnly));421 }422 return result;423}424 425Shape GetRawLowerBounds(426 FoldingContext &context, const NamedEntity &base, bool invariantOnly) {427 Shape result;428 int rank{base.Rank()};429 for (int dim{0}; dim < rank; ++dim) {430 result.emplace_back(GetRawLowerBound(context, base, dim, invariantOnly));431 }432 return result;433}434 435Shape GetLBOUNDs(const NamedEntity &base, bool invariantOnly) {436 Shape result;437 int rank{base.Rank()};438 for (int dim{0}; dim < rank; ++dim) {439 result.emplace_back(GetLBOUND(base, dim, invariantOnly));440 }441 return result;442}443 444Shape GetLBOUNDs(445 FoldingContext &context, const NamedEntity &base, bool invariantOnly) {446 Shape result;447 int rank{base.Rank()};448 for (int dim{0}; dim < rank; ++dim) {449 result.emplace_back(GetLBOUND(context, base, dim, invariantOnly));450 }451 return result;452}453 454// If the upper and lower bounds are constant, return a constant expression for455// the extent. In particular, if the upper bound is less than the lower bound,456// return zero.457static MaybeExtentExpr GetNonNegativeExtent(458 const semantics::ShapeSpec &shapeSpec, bool invariantOnly) {459 const auto &ubound{shapeSpec.ubound().GetExplicit()};460 const auto &lbound{shapeSpec.lbound().GetExplicit()};461 std::optional<ConstantSubscript> uval{ToInt64(ubound)};462 std::optional<ConstantSubscript> lval{ToInt64(lbound)};463 if (uval && lval) {464 if (*uval < *lval) {465 return ExtentExpr{0};466 } else {467 return ExtentExpr{*uval - *lval + 1};468 }469 } else if (lbound && ubound && lbound->Rank() == 0 && ubound->Rank() == 0 &&470 (!invariantOnly ||471 (IsScopeInvariantExpr(*lbound) && IsScopeInvariantExpr(*ubound)))) {472 // Apply effective IDIM (MAX calculation with 0) so thet the473 // result is never negative474 if (lval.value_or(0) == 1) {475 return ExtentExpr{Extremum<SubscriptInteger>{476 Ordering::Greater, ExtentExpr{0}, common::Clone(*ubound)}};477 } else {478 return ExtentExpr{479 Extremum<SubscriptInteger>{Ordering::Greater, ExtentExpr{0},480 common::Clone(*ubound) - common::Clone(*lbound) + ExtentExpr{1}}};481 }482 } else {483 return std::nullopt;484 }485}486 487static MaybeExtentExpr GetAssociatedExtent(488 const Symbol &symbol, int dimension) {489 if (const auto *assoc{symbol.detailsIf<semantics::AssocEntityDetails>()};490 assoc && !assoc->rank()) { // not SELECT RANK case491 if (auto shape{GetShape(GetFoldingContextFrom(symbol), assoc->expr())};492 shape && dimension < static_cast<int>(shape->size())) {493 if (auto &extent{shape->at(dimension)};494 // Don't return a non-constant extent, as the variables that495 // determine the shape of the selector's expression may change496 // during execution of the construct.497 extent && IsActuallyConstant(*extent)) {498 return std::move(extent);499 }500 }501 }502 return ExtentExpr{DescriptorInquiry{503 NamedEntity{symbol}, DescriptorInquiry::Field::Extent, dimension}};504}505 506MaybeExtentExpr GetExtent(507 const NamedEntity &base, int dimension, bool invariantOnly) {508 CHECK(dimension >= 0);509 const Symbol &last{base.GetLastSymbol()};510 const Symbol &symbol{ResolveAssociations(last)};511 if (const auto *assoc{last.detailsIf<semantics::AssocEntityDetails>()}) {512 if (assoc->IsAssumedSize() || assoc->IsAssumedRank()) { // RANK(*)/DEFAULT513 return std::nullopt;514 } else if (assoc->rank()) { // RANK(n)515 if (semantics::IsDescriptor(symbol) && dimension < *assoc->rank()) {516 return ExtentExpr{DescriptorInquiry{517 NamedEntity{base}, DescriptorInquiry::Field::Extent, dimension}};518 } else {519 return std::nullopt;520 }521 } else {522 return GetAssociatedExtent(last, dimension);523 }524 }525 if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {526 if (IsImpliedShape(symbol) && details->init()) {527 if (auto shape{528 GetShape(GetFoldingContextFrom(symbol), symbol, invariantOnly)}) {529 if (dimension < static_cast<int>(shape->size())) {530 return std::move(shape->at(dimension));531 }532 }533 } else {534 int j{0};535 for (const auto &shapeSpec : details->shape()) {536 if (j++ == dimension) {537 if (auto extent{GetNonNegativeExtent(shapeSpec, invariantOnly)}) {538 return extent;539 } else if (semantics::IsAssumedSizeArray(symbol) &&540 j == symbol.Rank()) {541 break;542 } else if (semantics::IsDescriptor(symbol)) {543 return ExtentExpr{DescriptorInquiry{NamedEntity{base},544 DescriptorInquiry::Field::Extent, dimension}};545 } else {546 break;547 }548 }549 }550 }551 }552 return std::nullopt;553}554 555MaybeExtentExpr GetExtent(FoldingContext &context, const NamedEntity &base,556 int dimension, bool invariantOnly) {557 return Fold(context, GetExtent(base, dimension, invariantOnly));558}559 560MaybeExtentExpr GetExtent(const Subscript &subscript, const NamedEntity &base,561 int dimension, bool invariantOnly) {562 return common::visit(563 common::visitors{564 [&](const Triplet &triplet) -> MaybeExtentExpr {565 MaybeExtentExpr upper{triplet.upper()};566 if (!upper) {567 upper = GetUBOUND(base, dimension, invariantOnly);568 }569 MaybeExtentExpr lower{triplet.lower()};570 if (!lower) {571 lower = GetLBOUND(base, dimension, invariantOnly);572 }573 return CountTrips(std::move(lower), std::move(upper),574 MaybeExtentExpr{triplet.stride()});575 },576 [&](const IndirectSubscriptIntegerExpr &subs) -> MaybeExtentExpr {577 if (auto shape{GetShape(578 GetFoldingContextFrom(base.GetLastSymbol()), subs.value())};579 shape && GetRank(*shape) == 1) {580 // vector-valued subscript581 return std::move(shape->at(0));582 } else {583 return std::nullopt;584 }585 },586 },587 subscript.u);588}589 590MaybeExtentExpr GetExtent(FoldingContext &context, const Subscript &subscript,591 const NamedEntity &base, int dimension, bool invariantOnly) {592 return Fold(context, GetExtent(subscript, base, dimension, invariantOnly));593}594 595MaybeExtentExpr ComputeUpperBound(596 ExtentExpr &&lower, MaybeExtentExpr &&extent) {597 if (extent) {598 if (ToInt64(lower).value_or(0) == 1) {599 return std::move(*extent);600 } else {601 return std::move(*extent) + std::move(lower) - ExtentExpr{1};602 }603 } else {604 return std::nullopt;605 }606}607 608MaybeExtentExpr ComputeUpperBound(609 FoldingContext &context, ExtentExpr &&lower, MaybeExtentExpr &&extent) {610 return Fold(context, ComputeUpperBound(std::move(lower), std::move(extent)));611}612 613MaybeExtentExpr GetRawUpperBound(614 const NamedEntity &base, int dimension, bool invariantOnly) {615 const Symbol &symbol{ResolveAssociations(base.GetLastSymbol())};616 if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {617 int rank{details->shape().Rank()};618 if (dimension < rank) {619 const auto &bound{details->shape()[dimension].ubound().GetExplicit()};620 if (bound && bound->Rank() == 0 &&621 (!invariantOnly || IsScopeInvariantExpr(*bound))) {622 return *bound;623 } else if (semantics::IsAssumedSizeArray(symbol) &&624 dimension + 1 == symbol.Rank()) {625 return std::nullopt;626 } else if (IsSafelyCopyable(base, /*admitPureCall=*/true)) {627 return ComputeUpperBound(628 GetRawLowerBound(base, dimension), GetExtent(base, dimension));629 }630 }631 } else if (const auto *assoc{632 symbol.detailsIf<semantics::AssocEntityDetails>()}) {633 if (assoc->IsAssumedSize() || assoc->IsAssumedRank()) {634 return std::nullopt;635 } else if (assoc->rank() && dimension >= *assoc->rank()) {636 return std::nullopt;637 } else if (auto extent{GetAssociatedExtent(symbol, dimension)}) {638 return ComputeUpperBound(639 GetRawLowerBound(base, dimension), std::move(extent));640 }641 }642 return std::nullopt;643}644 645MaybeExtentExpr GetRawUpperBound(FoldingContext &context,646 const NamedEntity &base, int dimension, bool invariantOnly) {647 return Fold(context, GetRawUpperBound(base, dimension, invariantOnly));648}649 650static MaybeExtentExpr GetExplicitUBOUND(FoldingContext *context,651 const semantics::ShapeSpec &shapeSpec, bool invariantOnly) {652 const auto &ubound{shapeSpec.ubound().GetExplicit()};653 if (ubound && ubound->Rank() == 0 &&654 (!invariantOnly || IsScopeInvariantExpr(*ubound))) {655 if (auto extent{GetNonNegativeExtent(shapeSpec, invariantOnly)}) {656 if (auto cstExtent{ToInt64(657 context ? Fold(*context, std::move(*extent)) : *extent)}) {658 if (cstExtent > 0) {659 return *ubound;660 } else if (cstExtent == 0) {661 return ExtentExpr{0};662 }663 }664 }665 }666 return std::nullopt;667}668 669static MaybeExtentExpr GetUBOUND(FoldingContext *context,670 const NamedEntity &base, int dimension, bool invariantOnly) {671 const Symbol &symbol{ResolveAssociations(base.GetLastSymbol())};672 if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {673 int rank{details->shape().Rank()};674 if (dimension < rank) {675 const semantics::ShapeSpec &shapeSpec{details->shape()[dimension]};676 if (auto ubound{GetExplicitUBOUND(context, shapeSpec, invariantOnly)}) {677 return *ubound;678 } else if (semantics::IsAssumedSizeArray(symbol) &&679 dimension + 1 == symbol.Rank()) {680 return std::nullopt; // UBOUND() folding replaces with -1681 } else if (IsSafelyCopyable(base, /*admitPureCall=*/true)) {682 if (auto lb{GetLBOUND(base, dimension, invariantOnly)}) {683 return ComputeUpperBound(684 std::move(*lb), GetExtent(base, dimension, invariantOnly));685 }686 }687 }688 } else if (const auto *assoc{689 symbol.detailsIf<semantics::AssocEntityDetails>()}) {690 if (assoc->IsAssumedSize() || assoc->IsAssumedRank()) {691 return std::nullopt;692 } else if (assoc->rank()) { // RANK (n)693 const Symbol &resolved{ResolveAssociations(symbol)};694 if (IsDescriptor(resolved) && dimension < *assoc->rank()) {695 ExtentExpr lb{DescriptorInquiry{NamedEntity{base},696 DescriptorInquiry::Field::LowerBound, dimension}};697 ExtentExpr extent{DescriptorInquiry{698 std::move(base), DescriptorInquiry::Field::Extent, dimension}};699 return ComputeUpperBound(std::move(lb), std::move(extent));700 }701 } else if (auto extent{GetAssociatedExtent(symbol, dimension)}) {702 if (auto lb{GetLBOUND(base, dimension, invariantOnly)}) {703 return ComputeUpperBound(std::move(*lb), std::move(extent));704 }705 }706 }707 return std::nullopt;708}709 710MaybeExtentExpr GetUBOUND(711 const NamedEntity &base, int dimension, bool invariantOnly) {712 return GetUBOUND(nullptr, base, dimension, invariantOnly);713}714 715MaybeExtentExpr GetUBOUND(FoldingContext &context, const NamedEntity &base,716 int dimension, bool invariantOnly) {717 return Fold(context, GetUBOUND(&context, base, dimension, invariantOnly));718}719 720static Shape GetUBOUNDs(721 FoldingContext *context, const NamedEntity &base, bool invariantOnly) {722 Shape result;723 int rank{base.Rank()};724 for (int dim{0}; dim < rank; ++dim) {725 result.emplace_back(GetUBOUND(context, base, dim, invariantOnly));726 }727 return result;728}729 730Shape GetUBOUNDs(731 FoldingContext &context, const NamedEntity &base, bool invariantOnly) {732 return Fold(context, GetUBOUNDs(&context, base, invariantOnly));733}734 735Shape GetUBOUNDs(const NamedEntity &base, bool invariantOnly) {736 return GetUBOUNDs(nullptr, base, invariantOnly);737}738 739MaybeExtentExpr GetLCOBOUND(740 const Symbol &symbol0, int dimension, bool invariantOnly) {741 const Symbol &symbol{ResolveAssociations(symbol0)};742 if (const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {743 int corank{object->coshape().Rank()};744 if (dimension < corank) {745 const semantics::ShapeSpec &shapeSpec{object->coshape()[dimension]};746 if (const auto &lcobound{shapeSpec.lbound().GetExplicit()}) {747 if (lcobound->Rank() == 0 &&748 (!invariantOnly || IsScopeInvariantExpr(*lcobound))) {749 return *lcobound;750 }751 }752 }753 }754 return std::nullopt;755}756 757MaybeExtentExpr GetUCOBOUND(758 const Symbol &symbol0, int dimension, bool invariantOnly) {759 const Symbol &symbol{ResolveAssociations(symbol0)};760 if (const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {761 int corank{object->coshape().Rank()};762 if (dimension < corank - 1) {763 const semantics::ShapeSpec &shapeSpec{object->coshape()[dimension]};764 if (const auto ucobound{shapeSpec.ubound().GetExplicit()}) {765 if (ucobound->Rank() == 0 &&766 (!invariantOnly || IsScopeInvariantExpr(*ucobound))) {767 return *ucobound;768 }769 }770 }771 }772 return std::nullopt;773}774 775Shape GetLCOBOUNDs(const Symbol &symbol, bool invariantOnly) {776 Shape result;777 int corank{symbol.Corank()};778 for (int dim{0}; dim < corank; ++dim) {779 result.emplace_back(GetLCOBOUND(symbol, dim, invariantOnly));780 }781 return result;782}783 784Shape GetUCOBOUNDs(const Symbol &symbol, bool invariantOnly) {785 Shape result;786 int corank{symbol.Corank()};787 for (int dim{0}; dim < corank; ++dim) {788 result.emplace_back(GetUCOBOUND(symbol, dim, invariantOnly));789 }790 return result;791}792 793auto GetShapeHelper::operator()(const Symbol &symbol) const -> Result {794 return common::visit(795 common::visitors{796 [&](const semantics::ObjectEntityDetails &object) {797 if (IsImpliedShape(symbol) && object.init()) {798 return (*this)(object.init());799 } else if (IsAssumedRank(symbol)) {800 return Result{};801 } else {802 int n{object.shape().Rank()};803 NamedEntity base{symbol};804 return Result{CreateShape(n, base)};805 }806 },807 [](const semantics::EntityDetails &) {808 return ScalarShape(); // no dimensions seen809 },810 [&](const semantics::ProcEntityDetails &proc) {811 if (const Symbol * interface{proc.procInterface()}) {812 return (*this)(*interface);813 } else {814 return ScalarShape();815 }816 },817 [&](const semantics::AssocEntityDetails &assoc) {818 NamedEntity base{symbol};819 if (assoc.rank()) { // SELECT RANK case820 int n{assoc.rank().value()};821 return Result{CreateShape(n, base)};822 } else {823 auto exprShape{((*this)(assoc.expr()))};824 if (exprShape) {825 int rank{static_cast<int>(exprShape->size())};826 for (int dimension{0}; dimension < rank; ++dimension) {827 auto &extent{(*exprShape)[dimension]};828 if (extent && !IsActuallyConstant(*extent)) {829 extent = GetExtent(base, dimension);830 }831 }832 }833 return exprShape;834 }835 },836 [&](const semantics::SubprogramDetails &subp) -> Result {837 if (subp.isFunction()) {838 auto resultShape{(*this)(subp.result())};839 if (resultShape && !useResultSymbolShape_) {840 // Ensure the shape is constant. Otherwise, it may be reerring841 // to symbols that belong to the function's scope and are842 // meaningless on the caller side without the related call843 // expression.844 for (auto &extent : *resultShape) {845 if (extent && !IsActuallyConstant(*extent)) {846 extent.reset();847 }848 }849 }850 return resultShape;851 } else {852 return Result{};853 }854 },855 [&](const semantics::ProcBindingDetails &binding) {856 return (*this)(binding.symbol());857 },858 [](const semantics::TypeParamDetails &) { return ScalarShape(); },859 [](const auto &) { return Result{}; },860 },861 symbol.GetUltimate().details());862}863 864auto GetShapeHelper::operator()(const Component &component) const -> Result {865 const Symbol &symbol{component.GetLastSymbol()};866 int rank{symbol.Rank()};867 if (rank == 0) {868 return (*this)(component.base());869 } else if (symbol.has<semantics::ObjectEntityDetails>()) {870 NamedEntity base{Component{component}};871 return CreateShape(rank, base);872 } else {873 return (*this)(symbol);874 }875}876 877auto GetShapeHelper::operator()(const ArrayRef &arrayRef) const -> Result {878 Shape shape;879 int dimension{0};880 const NamedEntity &base{arrayRef.base()};881 for (const Subscript &ss : arrayRef.subscript()) {882 if (ss.Rank() > 0) {883 shape.emplace_back(GetExtent(ss, base, dimension));884 }885 ++dimension;886 }887 if (shape.empty()) {888 if (const Component * component{base.UnwrapComponent()}) {889 return (*this)(component->base());890 }891 }892 return shape;893}894 895auto GetShapeHelper::operator()(const CoarrayRef &coarrayRef) const -> Result {896 return (*this)(coarrayRef.base());897}898 899auto GetShapeHelper::operator()(const Substring &substring) const -> Result {900 return (*this)(substring.parent());901}902 903auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {904 if (call.Rank() == 0) {905 return ScalarShape();906 } else if (call.IsElemental()) {907 // Use the shape of an actual array argument associated with a908 // non-OPTIONAL dummy object argument.909 if (context_) {910 if (auto chars{characteristics::Procedure::FromActuals(911 call.proc(), call.arguments(), *context_)}) {912 std::size_t j{0};913 const ActualArgument *nonOptionalArrayArg{nullptr};914 int anyArrayArgRank{0};915 for (const auto &arg : call.arguments()) {916 if (arg && arg->Rank() > 0 && j < chars->dummyArguments.size()) {917 if (!anyArrayArgRank) {918 anyArrayArgRank = arg->Rank();919 } else if (arg->Rank() != anyArrayArgRank) {920 return std::nullopt; // error recovery921 }922 if (!nonOptionalArrayArg &&923 !chars->dummyArguments[j].IsOptional()) {924 nonOptionalArrayArg = &*arg;925 }926 }927 ++j;928 }929 if (anyArrayArgRank) {930 if (nonOptionalArrayArg) {931 return (*this)(*nonOptionalArrayArg);932 } else {933 // All dummy array arguments of the procedure are OPTIONAL.934 // We cannot take the shape from just any array argument,935 // because all of them might be OPTIONAL dummy arguments936 // of the caller. Return unknown shape ranked according937 // to the last actual array argument.938 return Shape(anyArrayArgRank, MaybeExtentExpr{});939 }940 }941 }942 }943 return ScalarShape();944 } else if (const Symbol * symbol{call.proc().GetSymbol()}) {945 auto restorer{common::ScopedSet(useResultSymbolShape_, false)};946 return (*this)(*symbol);947 } else if (const auto *intrinsic{call.proc().GetSpecificIntrinsic()}) {948 if (intrinsic->name == "shape" || intrinsic->name == "lbound" ||949 intrinsic->name == "ubound") {950 // For LBOUND/UBOUND, these are the array-valued cases (no DIM=)951 if (!call.arguments().empty() && call.arguments().front()) {952 if (semantics::IsAssumedRank(*call.arguments().front())) {953 return Shape{MaybeExtentExpr{}};954 } else {955 return Shape{956 MaybeExtentExpr{ExtentExpr{call.arguments().front()->Rank()}}};957 }958 }959 } else if (intrinsic->name == "all" || intrinsic->name == "any" ||960 intrinsic->name == "count" || intrinsic->name == "iall" ||961 intrinsic->name == "iany" || intrinsic->name == "iparity" ||962 intrinsic->name == "maxval" || intrinsic->name == "minval" ||963 intrinsic->name == "norm2" || intrinsic->name == "parity" ||964 intrinsic->name == "product" || intrinsic->name == "sum") {965 // Reduction with DIM=966 if (call.arguments().size() >= 2) {967 auto arrayShape{968 (*this)(UnwrapExpr<Expr<SomeType>>(call.arguments().at(0)))};969 const auto *dimArg{UnwrapExpr<Expr<SomeType>>(call.arguments().at(1))};970 if (arrayShape && dimArg) {971 if (auto dim{ToInt64(*dimArg)}) {972 if (*dim >= 1 &&973 static_cast<std::size_t>(*dim) <= arrayShape->size()) {974 arrayShape->erase(arrayShape->begin() + (*dim - 1));975 return std::move(*arrayShape);976 }977 }978 }979 }980 } else if (intrinsic->name == "findloc" || intrinsic->name == "maxloc" ||981 intrinsic->name == "minloc") {982 std::size_t dimIndex{intrinsic->name == "findloc" ? 2u : 1u};983 if (call.arguments().size() > dimIndex) {984 if (auto arrayShape{985 (*this)(UnwrapExpr<Expr<SomeType>>(call.arguments().at(0)))}) {986 auto rank{static_cast<int>(arrayShape->size())};987 if (const auto *dimArg{988 UnwrapExpr<Expr<SomeType>>(call.arguments()[dimIndex])}) {989 auto dim{ToInt64(*dimArg)};990 if (dim && *dim >= 1 && *dim <= rank) {991 arrayShape->erase(arrayShape->begin() + (*dim - 1));992 return std::move(*arrayShape);993 }994 } else {995 // xxxLOC(no DIM=) result is vector(1:RANK(ARRAY=))996 return Shape{ExtentExpr{rank}};997 }998 }999 }1000 } else if (intrinsic->name == "cshift" || intrinsic->name == "eoshift") {1001 if (!call.arguments().empty()) {1002 return (*this)(call.arguments()[0]);1003 }1004 } else if (intrinsic->name == "lcobound" || intrinsic->name == "ucobound") {1005 if (call.arguments().size() == 3 && !call.arguments().at(1).has_value()) {1006 return Shape(1, ExtentExpr{GetCorank(call.arguments().at(0))});1007 }1008 } else if (intrinsic->name == "matmul") {1009 if (call.arguments().size() == 2) {1010 if (auto ashape{(*this)(call.arguments()[0])}) {1011 if (auto bshape{(*this)(call.arguments()[1])}) {1012 if (ashape->size() == 1 && bshape->size() == 2) {1013 bshape->erase(bshape->begin());1014 return std::move(*bshape); // matmul(vector, matrix)1015 } else if (ashape->size() == 2 && bshape->size() == 1) {1016 ashape->pop_back();1017 return std::move(*ashape); // matmul(matrix, vector)1018 } else if (ashape->size() == 2 && bshape->size() == 2) {1019 (*ashape)[1] = std::move((*bshape)[1]);1020 return std::move(*ashape); // matmul(matrix, matrix)1021 }1022 }1023 }1024 }1025 } else if (intrinsic->name == "pack") {1026 if (call.arguments().size() >= 3 && call.arguments().at(2)) {1027 // SHAPE(PACK(,,VECTOR=v)) -> SHAPE(v)1028 return (*this)(call.arguments().at(2));1029 } else if (call.arguments().size() >= 2 && context_) {1030 if (auto maskShape{(*this)(call.arguments().at(1))}) {1031 if (maskShape->size() == 0) {1032 // Scalar MASK= -> [MERGE(SIZE(ARRAY=), 0, mask)]1033 if (auto arrayShape{(*this)(call.arguments().at(0))}) {1034 if (auto arraySize{GetSize(std::move(*arrayShape))}) {1035 ActualArguments toMerge{1036 ActualArgument{AsGenericExpr(std::move(*arraySize))},1037 ActualArgument{AsGenericExpr(ExtentExpr{0})},1038 common::Clone(call.arguments().at(1))};1039 auto specific{context_->intrinsics().Probe(1040 CallCharacteristics{"merge"}, toMerge, *context_)};1041 CHECK(specific);1042 return Shape{ExtentExpr{FunctionRef<ExtentType>{1043 ProcedureDesignator{std::move(specific->specificIntrinsic)},1044 std::move(specific->arguments)}}};1045 }1046 }1047 } else {1048 // Non-scalar MASK= -> [COUNT(mask, KIND=extent_kind)]1049 ActualArgument kindArg{1050 AsGenericExpr(Constant<ExtentType>{ExtentType::kind})};1051 kindArg.set_keyword(context_->SaveTempName("kind"));1052 ActualArguments toCount{1053 ActualArgument{common::Clone(1054 DEREF(call.arguments().at(1).value().UnwrapExpr()))},1055 std::move(kindArg)};1056 auto specific{context_->intrinsics().Probe(1057 CallCharacteristics{"count"}, toCount, *context_)};1058 CHECK(specific);1059 return Shape{ExtentExpr{FunctionRef<ExtentType>{1060 ProcedureDesignator{std::move(specific->specificIntrinsic)},1061 std::move(specific->arguments)}}};1062 }1063 }1064 }1065 } else if (intrinsic->name == "reshape") {1066 if (call.arguments().size() >= 2 && call.arguments().at(1)) {1067 // SHAPE(RESHAPE(array,shape)) -> shape1068 if (const auto *shapeExpr{1069 call.arguments().at(1).value().UnwrapExpr()}) {1070 auto shapeArg{std::get<Expr<SomeInteger>>(shapeExpr->u)};1071 if (auto result{AsShapeResult(1072 ConvertToType<ExtentType>(std::move(shapeArg)))}) {1073 return result;1074 }1075 }1076 }1077 } else if (intrinsic->name == "spread") {1078 // SHAPE(SPREAD(ARRAY,DIM,NCOPIES)) = SHAPE(ARRAY) with MAX(0,NCOPIES)1079 // inserted at position DIM.1080 if (call.arguments().size() == 3) {1081 auto arrayShape{1082 (*this)(UnwrapExpr<Expr<SomeType>>(call.arguments().at(0)))};1083 const auto *dimArg{UnwrapExpr<Expr<SomeType>>(call.arguments().at(1))};1084 const auto *nCopies{1085 UnwrapExpr<Expr<SomeInteger>>(call.arguments().at(2))};1086 if (arrayShape && dimArg && nCopies) {1087 if (auto dim{ToInt64(*dimArg)}) {1088 if (*dim >= 1 &&1089 static_cast<std::size_t>(*dim) <= arrayShape->size() + 1) {1090 arrayShape->emplace(arrayShape->begin() + *dim - 1,1091 Extremum<SubscriptInteger>{Ordering::Greater, ExtentExpr{0},1092 ConvertToType<ExtentType>(common::Clone(*nCopies))});1093 return std::move(*arrayShape);1094 }1095 }1096 }1097 }1098 } else if (intrinsic->name == "transfer") {1099 if (call.arguments().size() == 3 && call.arguments().at(2)) {1100 // SIZE= is present; shape is vector [SIZE=]1101 if (const auto *size{1102 UnwrapExpr<Expr<SomeInteger>>(call.arguments().at(2))}) {1103 return Shape{1104 MaybeExtentExpr{ConvertToType<ExtentType>(common::Clone(*size))}};1105 }1106 } else if (context_) {1107 if (auto moldTypeAndShape{characteristics::TypeAndShape::Characterize(1108 call.arguments().at(1), *context_)}) {1109 if (moldTypeAndShape->Rank() == 0) {1110 // SIZE= is absent and MOLD= is scalar: result is scalar1111 return ScalarShape();1112 } else {1113 // SIZE= is absent and MOLD= is array: result is vector whose1114 // length is determined by sizes of types. See 16.9.193p4 case(ii).1115 // Note that if sourceBytes is not known to be empty, we1116 // can fold only when moldElementBytes is known to not be zero;1117 // the most general case risks a division by zero otherwise.1118 if (auto sourceTypeAndShape{1119 characteristics::TypeAndShape::Characterize(1120 call.arguments().at(0), *context_)}) {1121 if (auto sourceBytes{1122 sourceTypeAndShape->MeasureSizeInBytes(*context_)}) {1123 *sourceBytes = Fold(*context_, std::move(*sourceBytes));1124 if (auto sourceBytesConst{ToInt64(*sourceBytes)}) {1125 if (*sourceBytesConst == 0) {1126 return Shape{ExtentExpr{0}};1127 }1128 }1129 if (auto moldElementBytes{1130 moldTypeAndShape->MeasureElementSizeInBytes(1131 *context_, true)}) {1132 *moldElementBytes =1133 Fold(*context_, std::move(*moldElementBytes));1134 auto moldElementBytesConst{ToInt64(*moldElementBytes)};1135 if (moldElementBytesConst && *moldElementBytesConst != 0) {1136 ExtentExpr extent{Fold(*context_,1137 (std::move(*sourceBytes) +1138 common::Clone(*moldElementBytes) - ExtentExpr{1}) /1139 common::Clone(*moldElementBytes))};1140 return Shape{MaybeExtentExpr{std::move(extent)}};1141 }1142 }1143 }1144 }1145 }1146 }1147 }1148 } else if (intrinsic->name == "this_image") {1149 if (call.arguments().size() == 2) {1150 // THIS_IMAGE(coarray, no DIM, [TEAM])1151 return Shape(1, ExtentExpr{GetCorank(call.arguments().at(0))});1152 }1153 } else if (intrinsic->name == "transpose") {1154 if (call.arguments().size() >= 1) {1155 if (auto shape{(*this)(call.arguments().at(0))}) {1156 if (shape->size() == 2) {1157 std::swap((*shape)[0], (*shape)[1]);1158 return shape;1159 }1160 }1161 }1162 } else if (intrinsic->name == "unpack") {1163 if (call.arguments().size() >= 2) {1164 return (*this)(call.arguments()[1]); // MASK=1165 }1166 } else if (intrinsic->characteristics.value().attrs.test(1167 characteristics::Procedure::Attr::NullPointer) ||1168 intrinsic->characteristics.value().attrs.test(1169 characteristics::Procedure::Attr::NullAllocatable)) { // NULL(MOLD=)1170 return (*this)(call.arguments());1171 } else {1172 // TODO: shapes of other non-elemental intrinsic results1173 }1174 }1175 // The rank is always known even if the extents are not.1176 return Shape(static_cast<std::size_t>(call.Rank()), MaybeExtentExpr{});1177}1178 1179void GetShapeHelper::AccumulateExtent(1180 ExtentExpr &result, ExtentExpr &&n) const {1181 result = std::move(result) + std::move(n);1182 if (context_) {1183 // Fold during expression creation to avoid creating an expression so1184 // large we can't evaluate it without overflowing the stack.1185 result = Fold(*context_, std::move(result));1186 }1187}1188 1189// Check conformance of the passed shapes.1190std::optional<bool> CheckConformance(parser::ContextualMessages &messages,1191 const Shape &left, const Shape &right, CheckConformanceFlags::Flags flags,1192 const char *leftIs, const char *rightIs) {1193 int n{GetRank(left)};1194 if (n == 0 && (flags & CheckConformanceFlags::LeftScalarExpandable)) {1195 return true;1196 }1197 int rn{GetRank(right)};1198 if (rn == 0 && (flags & CheckConformanceFlags::RightScalarExpandable)) {1199 return true;1200 }1201 if (n != rn) {1202 messages.Say("Rank of %1$s is %2$d, but %3$s has rank %4$d"_err_en_US,1203 leftIs, n, rightIs, rn);1204 return false;1205 }1206 for (int j{0}; j < n; ++j) {1207 if (auto leftDim{ToInt64(left[j])}) {1208 if (auto rightDim{ToInt64(right[j])}) {1209 if (*leftDim != *rightDim) {1210 messages.Say("Dimension %1$d of %2$s has extent %3$jd, "1211 "but %4$s has extent %5$jd"_err_en_US,1212 j + 1, leftIs, *leftDim, rightIs, *rightDim);1213 return false;1214 }1215 } else if (!(flags & CheckConformanceFlags::RightIsDeferredShape)) {1216 return std::nullopt;1217 }1218 } else if (!(flags & CheckConformanceFlags::LeftIsDeferredShape)) {1219 return std::nullopt;1220 }1221 }1222 return true;1223}1224 1225bool IncrementSubscripts(1226 ConstantSubscripts &indices, const ConstantSubscripts &extents) {1227 std::size_t rank(indices.size());1228 CHECK(rank <= extents.size());1229 for (std::size_t j{0}; j < rank; ++j) {1230 if (extents[j] < 1) {1231 return false;1232 }1233 }1234 for (std::size_t j{0}; j < rank; ++j) {1235 if (indices[j]++ < extents[j]) {1236 return true;1237 }1238 indices[j] = 1;1239 }1240 return false;1241}1242 1243} // namespace Fortran::evaluate1244