flang/lib/Evaluate/shape.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-exception
   6 //
   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
  23 using namespace std::placeholders; // _1, _2, &c. for std::bind()
  24
  25 namespace Fortran::evaluate {
  26
  27 FoldingContext &GetFoldingContextFrom(const Symbol &symbol) {
  28   return symbol.owner().context().foldingContext();
  29 }
  30
  31 bool 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
  38 bool 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, too
  44   } else {
  45     return symbol
  46         .has<semantics::AssocEntityDetails>(); // exprs have explicit shape
  47   }
  48 }
  49
  50 Shape 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
  61 auto 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
  84 Shape 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
  92 std::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
 104 std::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
 115 Constant<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
 124 ConstantSubscripts 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
 132 std::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
 141 Shape 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
 149 std::optional<Shape> AsShape(const std::optional<ConstantSubscripts> &shape) {
 150   if (shape) {
 151     return AsShape(*shape);
 152   } else {
 153     return std::nullopt;
 154   }
 155 }
 156
 157 Shape 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
 164 std::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
 173 static 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
 183 ExtentExpr CountTrips(
 184     ExtentExpr &&lower, ExtentExpr &&upper, ExtentExpr &&stride) {
 185   return ComputeTripCount(
 186       std::move(lower), std::move(upper), std::move(stride));
 187 }
 188
 189 ExtentExpr 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
 195 MaybeExtentExpr 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
 203 MaybeExtentExpr 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
 215 ConstantSubscript 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
 224 bool 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 only
 235 // 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.
 237 template <typename RESULT, bool LBOUND_SEMANTICS>
 238 class GetLowerBoundHelper
 239     : public Traverse<GetLowerBoundHelper<RESULT, LBOUND_SEMANTICS>, RESULT> {
 240 public:
 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 == 1
 251     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 worry
 270                 // about handling an empty dimension
 271                 ok = !invariantOnly_ || IsScopeInvariantExpr(*lbound);
 272               } else if (lbValue.value_or(0) == 1) {
 273                 // Lower bound is 1, regardless of extent
 274                 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 to
 280                 // 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 DEFAULT
 323       } 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 a
 335           // constant expression at the time of the association, it is unsafe
 336           // to re-evaluate it later in the associate construct. Statements
 337           // 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 { // operation
 372         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
 384 private:
 385   int dimension_; // zero-based
 386   FoldingContext *context_{nullptr};
 387   bool invariantOnly_{false};
 388 };
 389
 390 ExtentExpr GetRawLowerBound(
 391     const NamedEntity &base, int dimension, bool invariantOnly) {
 392   return GetLowerBoundHelper<ExtentExpr, false>{
 393       dimension, nullptr, invariantOnly}(base);
 394 }
 395
 396 ExtentExpr 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
 403 MaybeExtentExpr GetLBOUND(
 404     const NamedEntity &base, int dimension, bool invariantOnly) {
 405   return GetLowerBoundHelper<MaybeExtentExpr, true>{
 406       dimension, nullptr, invariantOnly}(base);
 407 }
 408
 409 MaybeExtentExpr 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
 416 Shape 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
 425 Shape 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
 435 Shape 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
 444 Shape 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 for
 455 // the extent.  In particular, if the upper bound is less than the lower bound,
 456 // return zero.
 457 static 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 the
 473     // result is never negative
 474     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
 487 static MaybeExtentExpr GetAssociatedExtent(
 488     const Symbol &symbol, int dimension) {
 489   if (const auto *assoc{symbol.detailsIf<semantics::AssocEntityDetails>()};
 490       assoc && !assoc->rank()) { // not SELECT RANK case
 491     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 that
 495           // determine the shape of the selector's expression may change
 496           // 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
 506 MaybeExtentExpr 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(*)/DEFAULT
 513       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
 555 MaybeExtentExpr GetExtent(FoldingContext &context, const NamedEntity &base,
 556     int dimension, bool invariantOnly) {
 557   return Fold(context, GetExtent(base, dimension, invariantOnly));
 558 }
 559
 560 MaybeExtentExpr 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 subscript
 581               return std::move(shape->at(0));
 582             } else {
 583               return std::nullopt;
 584             }
 585           },
 586       },
 587       subscript.u);
 588 }
 589
 590 MaybeExtentExpr 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
 595 MaybeExtentExpr 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
 608 MaybeExtentExpr ComputeUpperBound(
 609     FoldingContext &context, ExtentExpr &&lower, MaybeExtentExpr &&extent) {
 610   return Fold(context, ComputeUpperBound(std::move(lower), std::move(extent)));
 611 }
 612
 613 MaybeExtentExpr 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 {
 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
 645 MaybeExtentExpr GetRawUpperBound(FoldingContext &context,
 646     const NamedEntity &base, int dimension, bool invariantOnly) {
 647   return Fold(context, GetRawUpperBound(base, dimension, invariantOnly));
 648 }
 649
 650 static 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
 669 static 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 -1
 681       } else if (auto lb{GetLBOUND(base, dimension, invariantOnly)}) {
 682         return ComputeUpperBound(
 683             std::move(*lb), GetExtent(base, dimension, invariantOnly));
 684       }
 685     }
 686   } else if (const auto *assoc{
 687                  symbol.detailsIf<semantics::AssocEntityDetails>()}) {
 688     if (assoc->IsAssumedSize() || assoc->IsAssumedRank()) {
 689       return std::nullopt;
 690     } else if (assoc->rank()) { // RANK (n)
 691       const Symbol &resolved{ResolveAssociations(symbol)};
 692       if (IsDescriptor(resolved) && dimension < *assoc->rank()) {
 693         ExtentExpr lb{DescriptorInquiry{NamedEntity{base},
 694             DescriptorInquiry::Field::LowerBound, dimension}};
 695         ExtentExpr extent{DescriptorInquiry{
 696             std::move(base), DescriptorInquiry::Field::Extent, dimension}};
 697         return ComputeUpperBound(std::move(lb), std::move(extent));
 698       }
 699     } else if (auto extent{GetAssociatedExtent(symbol, dimension)}) {
 700       if (auto lb{GetLBOUND(base, dimension, invariantOnly)}) {
 701         return ComputeUpperBound(std::move(*lb), std::move(extent));
 702       }
 703     }
 704   }
 705   return std::nullopt;
 706 }
 707
 708 MaybeExtentExpr GetUBOUND(
 709     const NamedEntity &base, int dimension, bool invariantOnly) {
 710   return GetUBOUND(nullptr, base, dimension, invariantOnly);
 711 }
 712
 713 MaybeExtentExpr GetUBOUND(FoldingContext &context, const NamedEntity &base,
 714     int dimension, bool invariantOnly) {
 715   return Fold(context, GetUBOUND(&context, base, dimension, invariantOnly));
 716 }
 717
 718 static Shape GetUBOUNDs(
 719     FoldingContext *context, const NamedEntity &base, bool invariantOnly) {
 720   Shape result;
 721   int rank{base.Rank()};
 722   for (int dim{0}; dim < rank; ++dim) {
 723     result.emplace_back(GetUBOUND(context, base, dim, invariantOnly));
 724   }
 725   return result;
 726 }
 727
 728 Shape GetUBOUNDs(
 729     FoldingContext &context, const NamedEntity &base, bool invariantOnly) {
 730   return Fold(context, GetUBOUNDs(&context, base, invariantOnly));
 731 }
 732
 733 Shape GetUBOUNDs(const NamedEntity &base, bool invariantOnly) {
 734   return GetUBOUNDs(nullptr, base, invariantOnly);
 735 }
 736
 737 MaybeExtentExpr GetLCOBOUND(
 738     const Symbol &symbol0, int dimension, bool invariantOnly) {
 739   const Symbol &symbol{ResolveAssociations(symbol0)};
 740   if (const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
 741     int corank{object->coshape().Rank()};
 742     if (dimension < corank) {
 743       const semantics::ShapeSpec &shapeSpec{object->coshape()[dimension]};
 744       if (const auto &lcobound{shapeSpec.lbound().GetExplicit()}) {
 745         if (lcobound->Rank() == 0 &&
 746             (!invariantOnly || IsScopeInvariantExpr(*lcobound))) {
 747           return *lcobound;
 748         }
 749       }
 750     }
 751   }
 752   return std::nullopt;
 753 }
 754
 755 MaybeExtentExpr GetUCOBOUND(
 756     const Symbol &symbol0, int dimension, bool invariantOnly) {
 757   const Symbol &symbol{ResolveAssociations(symbol0)};
 758   if (const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
 759     int corank{object->coshape().Rank()};
 760     if (dimension < corank - 1) {
 761       const semantics::ShapeSpec &shapeSpec{object->coshape()[dimension]};
 762       if (const auto ucobound{shapeSpec.ubound().GetExplicit()}) {
 763         if (ucobound->Rank() == 0 &&
 764             (!invariantOnly || IsScopeInvariantExpr(*ucobound))) {
 765           return *ucobound;
 766         }
 767       }
 768     }
 769   }
 770   return std::nullopt;
 771 }
 772
 773 Shape GetLCOBOUNDs(const Symbol &symbol, bool invariantOnly) {
 774   Shape result;
 775   int corank{symbol.Corank()};
 776   for (int dim{0}; dim < corank; ++dim) {
 777     result.emplace_back(GetLCOBOUND(symbol, dim, invariantOnly));
 778   }
 779   return result;
 780 }
 781
 782 Shape GetUCOBOUNDs(const Symbol &symbol, bool invariantOnly) {
 783   Shape result;
 784   int corank{symbol.Corank()};
 785   for (int dim{0}; dim < corank; ++dim) {
 786     result.emplace_back(GetUCOBOUND(symbol, dim, invariantOnly));
 787   }
 788   return result;
 789 }
 790
 791 auto GetShapeHelper::operator()(const Symbol &symbol) const -> Result {
 792   return common::visit(
 793       common::visitors{
 794           [&](const semantics::ObjectEntityDetails &object) {
 795             if (IsImpliedShape(symbol) && object.init()) {
 796               return (*this)(object.init());
 797             } else if (IsAssumedRank(symbol)) {
 798               return Result{};
 799             } else {
 800               int n{object.shape().Rank()};
 801               NamedEntity base{symbol};
 802               return Result{CreateShape(n, base)};
 803             }
 804           },
 805           [](const semantics::EntityDetails &) {
 806             return ScalarShape(); // no dimensions seen
 807           },
 808           [&](const semantics::ProcEntityDetails &proc) {
 809             if (const Symbol * interface{proc.procInterface()}) {
 810               return (*this)(*interface);
 811             } else {
 812               return ScalarShape();
 813             }
 814           },
 815           [&](const semantics::AssocEntityDetails &assoc) {
 816             NamedEntity base{symbol};
 817             if (assoc.rank()) { // SELECT RANK case
 818               int n{assoc.rank().value()};
 819               return Result{CreateShape(n, base)};
 820             } else {
 821               auto exprShape{((*this)(assoc.expr()))};
 822               if (exprShape) {
 823                 int rank{static_cast<int>(exprShape->size())};
 824                 for (int dimension{0}; dimension < rank; ++dimension) {
 825                   auto &extent{(*exprShape)[dimension]};
 826                   if (extent && !IsActuallyConstant(*extent)) {
 827                     extent = GetExtent(base, dimension);
 828                   }
 829                 }
 830               }
 831               return exprShape;
 832             }
 833           },
 834           [&](const semantics::SubprogramDetails &subp) -> Result {
 835             if (subp.isFunction()) {
 836               auto resultShape{(*this)(subp.result())};
 837               if (resultShape && !useResultSymbolShape_) {
 838                 // Ensure the shape is constant. Otherwise, it may be reerring
 839                 // to symbols that belong to the function's scope and are
 840                 // meaningless on the caller side without the related call
 841                 // expression.
 842                 for (auto &extent : *resultShape) {
 843                   if (extent && !IsActuallyConstant(*extent)) {
 844                     extent.reset();
 845                   }
 846                 }
 847               }
 848               return resultShape;
 849             } else {
 850               return Result{};
 851             }
 852           },
 853           [&](const semantics::ProcBindingDetails &binding) {
 854             return (*this)(binding.symbol());
 855           },
 856           [](const semantics::TypeParamDetails &) { return ScalarShape(); },
 857           [](const auto &) { return Result{}; },
 858       },
 859       symbol.GetUltimate().details());
 860 }
 861
 862 auto GetShapeHelper::operator()(const Component &component) const -> Result {
 863   const Symbol &symbol{component.GetLastSymbol()};
 864   int rank{symbol.Rank()};
 865   if (rank == 0) {
 866     return (*this)(component.base());
 867   } else if (symbol.has<semantics::ObjectEntityDetails>()) {
 868     NamedEntity base{Component{component}};
 869     return CreateShape(rank, base);
 870   } else {
 871     return (*this)(symbol);
 872   }
 873 }
 874
 875 auto GetShapeHelper::operator()(const ArrayRef &arrayRef) const -> Result {
 876   Shape shape;
 877   int dimension{0};
 878   const NamedEntity &base{arrayRef.base()};
 879   for (const Subscript &ss : arrayRef.subscript()) {
 880     if (ss.Rank() > 0) {
 881       shape.emplace_back(GetExtent(ss, base, dimension));
 882     }
 883     ++dimension;
 884   }
 885   if (shape.empty()) {
 886     if (const Component * component{base.UnwrapComponent()}) {
 887       return (*this)(component->base());
 888     }
 889   }
 890   return shape;
 891 }
 892
 893 auto GetShapeHelper::operator()(const CoarrayRef &coarrayRef) const -> Result {
 894   NamedEntity base{coarrayRef.GetBase()};
 895   if (coarrayRef.subscript().empty()) {
 896     return (*this)(base);
 897   } else {
 898     Shape shape;
 899     int dimension{0};
 900     for (const Subscript &ss : coarrayRef.subscript()) {
 901       if (ss.Rank() > 0) {
 902         shape.emplace_back(GetExtent(ss, base, dimension));
 903       }
 904       ++dimension;
 905     }
 906     return shape;
 907   }
 908 }
 909
 910 auto GetShapeHelper::operator()(const Substring &substring) const -> Result {
 911   return (*this)(substring.parent());
 912 }
 913
 914 auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {
 915   if (call.Rank() == 0) {
 916     return ScalarShape();
 917   } else if (call.IsElemental()) {
 918     // Use the shape of an actual array argument associated with a
 919     // non-OPTIONAL dummy object argument.
 920     if (context_) {
 921       if (auto chars{characteristics::Procedure::FromActuals(
 922               call.proc(), call.arguments(), *context_)}) {
 923         std::size_t j{0};
 924         const ActualArgument *nonOptionalArrayArg{nullptr};
 925         int anyArrayArgRank{0};
 926         for (const auto &arg : call.arguments()) {
 927           if (arg && arg->Rank() > 0 && j < chars->dummyArguments.size()) {
 928             if (!anyArrayArgRank) {
 929               anyArrayArgRank = arg->Rank();
 930             } else if (arg->Rank() != anyArrayArgRank) {
 931               return std::nullopt; // error recovery
 932             }
 933             if (!nonOptionalArrayArg &&
 934                 !chars->dummyArguments[j].IsOptional()) {
 935               nonOptionalArrayArg = &*arg;
 936             }
 937           }
 938           ++j;
 939         }
 940         if (anyArrayArgRank) {
 941           if (nonOptionalArrayArg) {
 942             return (*this)(*nonOptionalArrayArg);
 943           } else {
 944             // All dummy array arguments of the procedure are OPTIONAL.
 945             // We cannot take the shape from just any array argument,
 946             // because all of them might be OPTIONAL dummy arguments
 947             // of the caller. Return unknown shape ranked according
 948             // to the last actual array argument.
 949             return Shape(anyArrayArgRank, MaybeExtentExpr{});
 950           }
 951         }
 952       }
 953     }
 954     return ScalarShape();
 955   } else if (const Symbol * symbol{call.proc().GetSymbol()}) {
 956     auto restorer{common::ScopedSet(useResultSymbolShape_, false)};
 957     return (*this)(*symbol);
 958   } else if (const auto *intrinsic{call.proc().GetSpecificIntrinsic()}) {
 959     if (intrinsic->name == "shape" || intrinsic->name == "lbound" ||
 960         intrinsic->name == "ubound") {
 961       // For LBOUND/UBOUND, these are the array-valued cases (no DIM=)
 962       if (!call.arguments().empty() && call.arguments().front()) {
 963         if (IsAssumedRank(*call.arguments().front())) {
 964           return Shape{MaybeExtentExpr{}};
 965         } else {
 966           return Shape{
 967               MaybeExtentExpr{ExtentExpr{call.arguments().front()->Rank()}}};
 968         }
 969       }
 970     } else if (intrinsic->name == "all" || intrinsic->name == "any" ||
 971         intrinsic->name == "count" || intrinsic->name == "iall" ||
 972         intrinsic->name == "iany" || intrinsic->name == "iparity" ||
 973         intrinsic->name == "maxval" || intrinsic->name == "minval" ||
 974         intrinsic->name == "norm2" || intrinsic->name == "parity" ||
 975         intrinsic->name == "product" || intrinsic->name == "sum") {
 976       // Reduction with DIM=
 977       if (call.arguments().size() >= 2) {
 978         auto arrayShape{
 979             (*this)(UnwrapExpr<Expr<SomeType>>(call.arguments().at(0)))};
 980         const auto *dimArg{UnwrapExpr<Expr<SomeType>>(call.arguments().at(1))};
 981         if (arrayShape && dimArg) {
 982           if (auto dim{ToInt64(*dimArg)}) {
 983             if (*dim >= 1 &&
 984                 static_cast<std::size_t>(*dim) <= arrayShape->size()) {
 985               arrayShape->erase(arrayShape->begin() + (*dim - 1));
 986               return std::move(*arrayShape);
 987             }
 988           }
 989         }
 990       }
 991     } else if (intrinsic->name == "findloc" || intrinsic->name == "maxloc" ||
 992         intrinsic->name == "minloc") {
 993       std::size_t dimIndex{intrinsic->name == "findloc" ? 2u : 1u};
 994       if (call.arguments().size() > dimIndex) {
 995         if (auto arrayShape{
 996                 (*this)(UnwrapExpr<Expr<SomeType>>(call.arguments().at(0)))}) {
 997           auto rank{static_cast<int>(arrayShape->size())};
 998           if (const auto *dimArg{
 999                   UnwrapExpr<Expr<SomeType>>(call.arguments()[dimIndex])}) {
1000             auto dim{ToInt64(*dimArg)};
1001             if (dim && *dim >= 1 && *dim <= rank) {
1002               arrayShape->erase(arrayShape->begin() + (*dim - 1));
1003               return std::move(*arrayShape);
1004             }
1005           } else {
1006             // xxxLOC(no DIM=) result is vector(1:RANK(ARRAY=))
1007             return Shape{ExtentExpr{rank}};
1008           }
1009         }
1010       }
1011     } else if (intrinsic->name == "cshift" || intrinsic->name == "eoshift") {
1012       if (!call.arguments().empty()) {
1013         return (*this)(call.arguments()[0]);
1014       }
1015     } else if (intrinsic->name == "lcobound" || intrinsic->name == "ucobound") {
1016       if (call.arguments().size() == 3 && !call.arguments().at(1).has_value()) {
1017         return Shape(1, ExtentExpr{GetCorank(call.arguments().at(0))});
1018       }
1019     } else if (intrinsic->name == "matmul") {
1020       if (call.arguments().size() == 2) {
1021         if (auto ashape{(*this)(call.arguments()[0])}) {
1022           if (auto bshape{(*this)(call.arguments()[1])}) {
1023             if (ashape->size() == 1 && bshape->size() == 2) {
1024               bshape->erase(bshape->begin());
1025               return std::move(*bshape); // matmul(vector, matrix)
1026             } else if (ashape->size() == 2 && bshape->size() == 1) {
1027               ashape->pop_back();
1028               return std::move(*ashape); // matmul(matrix, vector)
1029             } else if (ashape->size() == 2 && bshape->size() == 2) {
1030               (*ashape)[1] = std::move((*bshape)[1]);
1031               return std::move(*ashape); // matmul(matrix, matrix)
1032             }
1033           }
1034         }
1035       }
1036     } else if (intrinsic->name == "pack") {
1037       if (call.arguments().size() >= 3 && call.arguments().at(2)) {
1038         // SHAPE(PACK(,,VECTOR=v)) -> SHAPE(v)
1039         return (*this)(call.arguments().at(2));
1040       } else if (call.arguments().size() >= 2 && context_) {
1041         if (auto maskShape{(*this)(call.arguments().at(1))}) {
1042           if (maskShape->size() == 0) {
1043             // Scalar MASK= -> [MERGE(SIZE(ARRAY=), 0, mask)]
1044             if (auto arrayShape{(*this)(call.arguments().at(0))}) {
1045               if (auto arraySize{GetSize(std::move(*arrayShape))}) {
1046                 ActualArguments toMerge{
1047                     ActualArgument{AsGenericExpr(std::move(*arraySize))},
1048                     ActualArgument{AsGenericExpr(ExtentExpr{0})},
1049                     common::Clone(call.arguments().at(1))};
1050                 auto specific{context_->intrinsics().Probe(
1051                     CallCharacteristics{"merge"}, toMerge, *context_)};
1052                 CHECK(specific);
1053                 return Shape{ExtentExpr{FunctionRef<ExtentType>{
1054                     ProcedureDesignator{std::move(specific->specificIntrinsic)},
1055                     std::move(specific->arguments)}}};
1056               }
1057             }
1058           } else {
1059             // Non-scalar MASK= -> [COUNT(mask, KIND=extent_kind)]
1060             ActualArgument kindArg{
1061                 AsGenericExpr(Constant<ExtentType>{ExtentType::kind})};
1062             kindArg.set_keyword(context_->SaveTempName("kind"));
1063             ActualArguments toCount{
1064                 ActualArgument{common::Clone(
1065                     DEREF(call.arguments().at(1).value().UnwrapExpr()))},
1066                 std::move(kindArg)};
1067             auto specific{context_->intrinsics().Probe(
1068                 CallCharacteristics{"count"}, toCount, *context_)};
1069             CHECK(specific);
1070             return Shape{ExtentExpr{FunctionRef<ExtentType>{
1071                 ProcedureDesignator{std::move(specific->specificIntrinsic)},
1072                 std::move(specific->arguments)}}};
1073           }
1074         }
1075       }
1076     } else if (intrinsic->name == "reshape") {
1077       if (call.arguments().size() >= 2 && call.arguments().at(1)) {
1078         // SHAPE(RESHAPE(array,shape)) -> shape
1079         if (const auto *shapeExpr{
1080                 call.arguments().at(1).value().UnwrapExpr()}) {
1081           auto shapeArg{std::get<Expr<SomeInteger>>(shapeExpr->u)};
1082           if (auto result{AsShapeResult(
1083                   ConvertToType<ExtentType>(std::move(shapeArg)))}) {
1084             return result;
1085           }
1086         }
1087       }
1088     } else if (intrinsic->name == "spread") {
1089       // SHAPE(SPREAD(ARRAY,DIM,NCOPIES)) = SHAPE(ARRAY) with NCOPIES inserted
1090       // at position DIM.
1091       if (call.arguments().size() == 3) {
1092         auto arrayShape{
1093             (*this)(UnwrapExpr<Expr<SomeType>>(call.arguments().at(0)))};
1094         const auto *dimArg{UnwrapExpr<Expr<SomeType>>(call.arguments().at(1))};
1095         const auto *nCopies{
1096             UnwrapExpr<Expr<SomeInteger>>(call.arguments().at(2))};
1097         if (arrayShape && dimArg && nCopies) {
1098           if (auto dim{ToInt64(*dimArg)}) {
1099             if (*dim >= 1 &&
1100                 static_cast<std::size_t>(*dim) <= arrayShape->size() + 1) {
1101               arrayShape->emplace(arrayShape->begin() + *dim - 1,
1102                   ConvertToType<ExtentType>(common::Clone(*nCopies)));
1103               return std::move(*arrayShape);
1104             }
1105           }
1106         }
1107       }
1108     } else if (intrinsic->name == "transfer") {
1109       if (call.arguments().size() == 3 && call.arguments().at(2)) {
1110         // SIZE= is present; shape is vector [SIZE=]
1111         if (const auto *size{
1112                 UnwrapExpr<Expr<SomeInteger>>(call.arguments().at(2))}) {
1113           return Shape{
1114               MaybeExtentExpr{ConvertToType<ExtentType>(common::Clone(*size))}};
1115         }
1116       } else if (context_) {
1117         if (auto moldTypeAndShape{characteristics::TypeAndShape::Characterize(
1118                 call.arguments().at(1), *context_)}) {
1119           if (moldTypeAndShape->Rank() == 0) {
1120             // SIZE= is absent and MOLD= is scalar: result is scalar
1121             return ScalarShape();
1122           } else {
1123             // SIZE= is absent and MOLD= is array: result is vector whose
1124             // length is determined by sizes of types.  See 16.9.193p4 case(ii).
1125             // Note that if sourceBytes is not known to be empty, we
1126             // can fold only when moldElementBytes is known to not be zero;
1127             // the most general case risks a division by zero otherwise.
1128             if (auto sourceTypeAndShape{
1129                     characteristics::TypeAndShape::Characterize(
1130                         call.arguments().at(0), *context_)}) {
1131               if (auto sourceBytes{
1132                       sourceTypeAndShape->MeasureSizeInBytes(*context_)}) {
1133                 *sourceBytes = Fold(*context_, std::move(*sourceBytes));
1134                 if (auto sourceBytesConst{ToInt64(*sourceBytes)}) {
1135                   if (*sourceBytesConst == 0) {
1136                     return Shape{ExtentExpr{0}};
1137                   }
1138                 }
1139                 if (auto moldElementBytes{
1140                         moldTypeAndShape->MeasureElementSizeInBytes(
1141                             *context_, true)}) {
1142                   *moldElementBytes =
1143                       Fold(*context_, std::move(*moldElementBytes));
1144                   auto moldElementBytesConst{ToInt64(*moldElementBytes)};
1145                   if (moldElementBytesConst && *moldElementBytesConst != 0) {
1146                     ExtentExpr extent{Fold(*context_,
1147                         (std::move(*sourceBytes) +
1148                             common::Clone(*moldElementBytes) - ExtentExpr{1}) /
1149                             common::Clone(*moldElementBytes))};
1150                     return Shape{MaybeExtentExpr{std::move(extent)}};
1151                   }
1152                 }
1153               }
1154             }
1155           }
1156         }
1157       }
1158     } else if (intrinsic->name == "this_image") {
1159       if (call.arguments().size() == 2) {
1160         // THIS_IMAGE(coarray, no DIM, [TEAM])
1161         return Shape(1, ExtentExpr{GetCorank(call.arguments().at(0))});
1162       }
1163     } else if (intrinsic->name == "transpose") {
1164       if (call.arguments().size() >= 1) {
1165         if (auto shape{(*this)(call.arguments().at(0))}) {
1166           if (shape->size() == 2) {
1167             std::swap((*shape)[0], (*shape)[1]);
1168             return shape;
1169           }
1170         }
1171       }
1172     } else if (intrinsic->name == "unpack") {
1173       if (call.arguments().size() >= 2) {
1174         return (*this)(call.arguments()[1]); // MASK=
1175       }
1176     } else if (intrinsic->characteristics.value().attrs.test(characteristics::
1177                        Procedure::Attr::NullPointer)) { // NULL(MOLD=)
1178       return (*this)(call.arguments());
1179     } else {
1180       // TODO: shapes of other non-elemental intrinsic results
1181     }
1182   }
1183   // The rank is always known even if the extents are not.
1184   return Shape(static_cast<std::size_t>(call.Rank()), MaybeExtentExpr{});
1185 }
1186
1187 void GetShapeHelper::AccumulateExtent(
1188     ExtentExpr &result, ExtentExpr &&n) const {
1189   result = std::move(result) + std::move(n);
1190   if (context_) {
1191     // Fold during expression creation to avoid creating an expression so
1192     // large we can't evaluate it without overflowing the stack.
1193     result = Fold(*context_, std::move(result));
1194   }
1195 }
1196
1197 // Check conformance of the passed shapes.
1198 std::optional<bool> CheckConformance(parser::ContextualMessages &messages,
1199     const Shape &left, const Shape &right, CheckConformanceFlags::Flags flags,
1200     const char *leftIs, const char *rightIs) {
1201   int n{GetRank(left)};
1202   if (n == 0 && (flags & CheckConformanceFlags::LeftScalarExpandable)) {
1203     return true;
1204   }
1205   int rn{GetRank(right)};
1206   if (rn == 0 && (flags & CheckConformanceFlags::RightScalarExpandable)) {
1207     return true;
1208   }
1209   if (n != rn) {
1210     messages.Say("Rank of %1$s is %2$d, but %3$s has rank %4$d"_err_en_US,
1211         leftIs, n, rightIs, rn);
1212     return false;
1213   }
1214   for (int j{0}; j < n; ++j) {
1215     if (auto leftDim{ToInt64(left[j])}) {
1216       if (auto rightDim{ToInt64(right[j])}) {
1217         if (*leftDim != *rightDim) {
1218           messages.Say("Dimension %1$d of %2$s has extent %3$jd, "
1219                        "but %4$s has extent %5$jd"_err_en_US,
1220               j + 1, leftIs, *leftDim, rightIs, *rightDim);
1221           return false;
1222         }
1223       } else if (!(flags & CheckConformanceFlags::RightIsDeferredShape)) {
1224         return std::nullopt;
1225       }
1226     } else if (!(flags & CheckConformanceFlags::LeftIsDeferredShape)) {
1227       return std::nullopt;
1228     }
1229   }
1230   return true;
1231 }
1232
1233 bool IncrementSubscripts(
1234     ConstantSubscripts &indices, const ConstantSubscripts &extents) {
1235   std::size_t rank(indices.size());
1236   CHECK(rank <= extents.size());
1237   for (std::size_t j{0}; j < rank; ++j) {
1238     if (extents[j] < 1) {
1239       return false;
1240     }
1241   }
1242   for (std::size_t j{0}; j < rank; ++j) {
1243     if (indices[j]++ < extents[j]) {
1244       return true;
1245     }
1246     indices[j] = 1;
1247   }
1248   return false;
1249 }
1250
1251 } // namespace Fortran::evaluate