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