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::AsShape(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       if (auto *expr{std::get_if<ExtentExpr>(&value.u)}) {
67         if (expr->Rank() == 0) {
68           result.emplace_back(std::move(*expr));
69           continue;
70         }
71       }
72       return std::nullopt;
73     }
74     return result;
75   }
76   return std::nullopt;
77 }
78 
79 Shape GetShapeHelper::CreateShape(int rank, NamedEntity &base) {
80   Shape shape;
81   for (int dimension{0}; dimension < rank; ++dimension) {
82     shape.emplace_back(GetExtent(base, dimension));
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(int d, FoldingContext *context)
240       : Base{*this}, dimension_{d}, context_{context} {}
241   static Result Default() { return Result{1}; }
242   static Result Combine(Result &&, Result &&) {
243     // Operator results and array references always have lower bounds == 1
244     return Result{1};
245   }
246 
247   Result operator()(const Symbol &symbol0) const {
248     const Symbol &symbol{symbol0.GetUltimate()};
249     if (const auto *details{
250             symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
251       int rank{details->shape().Rank()};
252       if (dimension_ < rank) {
253         const semantics::ShapeSpec &shapeSpec{details->shape()[dimension_]};
254         if (shapeSpec.lbound().isExplicit()) {
255           if (const auto &lbound{shapeSpec.lbound().GetExplicit()}) {
256             if constexpr (LBOUND_SEMANTICS) {
257               bool ok{false};
258               auto lbValue{ToInt64(*lbound)};
259               if (dimension_ == rank - 1 && details->IsAssumedSize()) {
260                 // last dimension of assumed-size dummy array: don't worry
261                 // about handling an empty dimension
262                 ok = IsScopeInvariantExpr(*lbound);
263               } else if (lbValue.value_or(0) == 1) {
264                 // Lower bound is 1, regardless of extent
265                 ok = true;
266               } else if (const auto &ubound{shapeSpec.ubound().GetExplicit()}) {
267                 // If we can't prove that the dimension is nonempty,
268                 // we must be conservative.
269                 // TODO: simple symbolic math in expression rewriting to
270                 // cope with cases like A(J:J)
271                 if (context_) {
272                   auto extent{ToInt64(Fold(*context_,
273                       ExtentExpr{*ubound} - ExtentExpr{*lbound} +
274                           ExtentExpr{1}))};
275                   ok = extent && *extent > 0;
276                 } else {
277                   auto ubValue{ToInt64(*ubound)};
278                   ok = lbValue && ubValue && *lbValue <= *ubValue;
279                 }
280               }
281               return ok ? *lbound : Result{};
282             } else {
283               return *lbound;
284             }
285           } else {
286             return Result{1};
287           }
288         }
289         if (IsDescriptor(symbol)) {
290           return ExtentExpr{DescriptorInquiry{NamedEntity{symbol0},
291               DescriptorInquiry::Field::LowerBound, dimension_}};
292         }
293       }
294     } else if (const auto *assoc{
295                    symbol.detailsIf<semantics::AssocEntityDetails>()}) {
296       if (assoc->rank()) { // SELECT RANK case
297         const Symbol &resolved{ResolveAssociations(symbol)};
298         if (IsDescriptor(resolved) && dimension_ < *assoc->rank()) {
299           return ExtentExpr{DescriptorInquiry{NamedEntity{symbol0},
300               DescriptorInquiry::Field::LowerBound, dimension_}};
301         }
302       } else {
303         return (*this)(assoc->expr());
304       }
305     }
306     if constexpr (LBOUND_SEMANTICS) {
307       return Result{};
308     } else {
309       return Result{1};
310     }
311   }
312 
313   Result operator()(const Component &component) const {
314     if (component.base().Rank() == 0) {
315       return (*this)(component.GetLastSymbol());
316     }
317     return Result{1};
318   }
319 
320 private:
321   int dimension_;
322   FoldingContext *context_{nullptr};
323 };
324 
325 ExtentExpr GetRawLowerBound(const NamedEntity &base, int dimension) {
326   return GetLowerBoundHelper<ExtentExpr, false>{dimension, nullptr}(base);
327 }
328 
329 ExtentExpr GetRawLowerBound(
330     FoldingContext &context, const NamedEntity &base, int dimension) {
331   return Fold(context,
332       GetLowerBoundHelper<ExtentExpr, false>{dimension, &context}(base));
333 }
334 
335 MaybeExtentExpr GetLBOUND(const NamedEntity &base, int dimension) {
336   return GetLowerBoundHelper<MaybeExtentExpr, true>{dimension, nullptr}(base);
337 }
338 
339 MaybeExtentExpr GetLBOUND(
340     FoldingContext &context, const NamedEntity &base, int dimension) {
341   return Fold(context,
342       GetLowerBoundHelper<MaybeExtentExpr, true>{dimension, &context}(base));
343 }
344 
345 Shape GetRawLowerBounds(const NamedEntity &base) {
346   Shape result;
347   int rank{base.Rank()};
348   for (int dim{0}; dim < rank; ++dim) {
349     result.emplace_back(GetRawLowerBound(base, dim));
350   }
351   return result;
352 }
353 
354 Shape GetRawLowerBounds(FoldingContext &context, const NamedEntity &base) {
355   Shape result;
356   int rank{base.Rank()};
357   for (int dim{0}; dim < rank; ++dim) {
358     result.emplace_back(GetRawLowerBound(context, base, dim));
359   }
360   return result;
361 }
362 
363 Shape GetLBOUNDs(const NamedEntity &base) {
364   Shape result;
365   int rank{base.Rank()};
366   for (int dim{0}; dim < rank; ++dim) {
367     result.emplace_back(GetLBOUND(base, dim));
368   }
369   return result;
370 }
371 
372 Shape GetLBOUNDs(FoldingContext &context, const NamedEntity &base) {
373   Shape result;
374   int rank{base.Rank()};
375   for (int dim{0}; dim < rank; ++dim) {
376     result.emplace_back(GetLBOUND(context, base, dim));
377   }
378   return result;
379 }
380 
381 // If the upper and lower bounds are constant, return a constant expression for
382 // the extent.  In particular, if the upper bound is less than the lower bound,
383 // return zero.
384 static MaybeExtentExpr GetNonNegativeExtent(
385     const semantics::ShapeSpec &shapeSpec) {
386   const auto &ubound{shapeSpec.ubound().GetExplicit()};
387   const auto &lbound{shapeSpec.lbound().GetExplicit()};
388   std::optional<ConstantSubscript> uval{ToInt64(ubound)};
389   std::optional<ConstantSubscript> lval{ToInt64(lbound)};
390   if (uval && lval) {
391     if (*uval < *lval) {
392       return ExtentExpr{0};
393     } else {
394       return ExtentExpr{*uval - *lval + 1};
395     }
396   } else if (lbound && ubound && IsScopeInvariantExpr(*lbound) &&
397       IsScopeInvariantExpr(*ubound)) {
398     // Apply effective IDIM (MAX calculation with 0) so thet the
399     // result is never negative
400     if (lval.value_or(0) == 1) {
401       return ExtentExpr{Extremum<SubscriptInteger>{
402           Ordering::Greater, ExtentExpr{0}, common::Clone(*ubound)}};
403     } else {
404       return ExtentExpr{
405           Extremum<SubscriptInteger>{Ordering::Greater, ExtentExpr{0},
406               common::Clone(*ubound) - common::Clone(*lbound) + ExtentExpr{1}}};
407     }
408   } else {
409     return std::nullopt;
410   }
411 }
412 
413 MaybeExtentExpr GetExtent(const NamedEntity &base, int dimension) {
414   CHECK(dimension >= 0);
415   const Symbol &last{base.GetLastSymbol()};
416   const Symbol &symbol{ResolveAssociations(last)};
417   if (const auto *assoc{last.detailsIf<semantics::AssocEntityDetails>()}) {
418     if (assoc->rank()) { // SELECT RANK case
419       if (semantics::IsDescriptor(symbol) && dimension < *assoc->rank()) {
420         return ExtentExpr{DescriptorInquiry{
421             NamedEntity{base}, DescriptorInquiry::Field::Extent, dimension}};
422       }
423     } else if (auto shape{GetShape(assoc->expr())}) {
424       if (dimension < static_cast<int>(shape->size())) {
425         return std::move(shape->at(dimension));
426       }
427     }
428   }
429   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
430     if (IsImpliedShape(symbol) && details->init()) {
431       if (auto shape{GetShape(symbol)}) {
432         if (dimension < static_cast<int>(shape->size())) {
433           return std::move(shape->at(dimension));
434         }
435       }
436     } else {
437       int j{0};
438       for (const auto &shapeSpec : details->shape()) {
439         if (j++ == dimension) {
440           if (auto extent{GetNonNegativeExtent(shapeSpec)}) {
441             return extent;
442           } else if (details->IsAssumedSize() && j == symbol.Rank()) {
443             return std::nullopt;
444           } else if (semantics::IsDescriptor(symbol)) {
445             return ExtentExpr{DescriptorInquiry{NamedEntity{base},
446                 DescriptorInquiry::Field::Extent, dimension}};
447           } else {
448             break;
449           }
450         }
451       }
452     }
453   }
454   return std::nullopt;
455 }
456 
457 MaybeExtentExpr GetExtent(
458     FoldingContext &context, const NamedEntity &base, int dimension) {
459   return Fold(context, GetExtent(base, dimension));
460 }
461 
462 MaybeExtentExpr GetExtent(
463     const Subscript &subscript, const NamedEntity &base, int dimension) {
464   return std::visit(
465       common::visitors{
466           [&](const Triplet &triplet) -> MaybeExtentExpr {
467             MaybeExtentExpr upper{triplet.upper()};
468             if (!upper) {
469               upper = GetUpperBound(base, dimension);
470             }
471             MaybeExtentExpr lower{triplet.lower()};
472             if (!lower) {
473               lower = GetLBOUND(base, dimension);
474             }
475             return CountTrips(std::move(lower), std::move(upper),
476                 MaybeExtentExpr{triplet.stride()});
477           },
478           [&](const IndirectSubscriptIntegerExpr &subs) -> MaybeExtentExpr {
479             if (auto shape{GetShape(subs.value())}) {
480               if (GetRank(*shape) > 0) {
481                 CHECK(GetRank(*shape) == 1); // vector-valued subscript
482                 return std::move(shape->at(0));
483               }
484             }
485             return std::nullopt;
486           },
487       },
488       subscript.u);
489 }
490 
491 MaybeExtentExpr GetExtent(FoldingContext &context, const Subscript &subscript,
492     const NamedEntity &base, int dimension) {
493   return Fold(context, GetExtent(subscript, base, dimension));
494 }
495 
496 MaybeExtentExpr ComputeUpperBound(
497     ExtentExpr &&lower, MaybeExtentExpr &&extent) {
498   if (extent) {
499     if (ToInt64(lower).value_or(0) == 1) {
500       return std::move(*extent);
501     } else {
502       return std::move(*extent) + std::move(lower) - ExtentExpr{1};
503     }
504   } else {
505     return std::nullopt;
506   }
507 }
508 
509 MaybeExtentExpr ComputeUpperBound(
510     FoldingContext &context, ExtentExpr &&lower, MaybeExtentExpr &&extent) {
511   return Fold(context, ComputeUpperBound(std::move(lower), std::move(extent)));
512 }
513 
514 MaybeExtentExpr GetUpperBound(const NamedEntity &base, int dimension) {
515   const Symbol &symbol{ResolveAssociations(base.GetLastSymbol())};
516   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
517     int j{0};
518     for (const auto &shapeSpec : details->shape()) {
519       if (j++ == dimension) {
520         const auto &bound{shapeSpec.ubound().GetExplicit()};
521         if (bound && IsScopeInvariantExpr(*bound)) {
522           return *bound;
523         } else if (details->IsAssumedSize() && dimension + 1 == symbol.Rank()) {
524           break;
525         } else if (auto lb{GetLBOUND(base, dimension)}) {
526           return ComputeUpperBound(std::move(*lb), GetExtent(base, dimension));
527         }
528       }
529     }
530   } else if (const auto *assoc{
531                  symbol.detailsIf<semantics::AssocEntityDetails>()}) {
532     if (auto shape{GetShape(assoc->expr())}) {
533       if (dimension < static_cast<int>(shape->size())) {
534         if (auto lb{GetLBOUND(base, dimension)}) {
535           return ComputeUpperBound(
536               std::move(*lb), std::move(shape->at(dimension)));
537         }
538       }
539     }
540   }
541   return std::nullopt;
542 }
543 
544 MaybeExtentExpr GetUpperBound(
545     FoldingContext &context, const NamedEntity &base, int dimension) {
546   return Fold(context, GetUpperBound(base, dimension));
547 }
548 
549 Shape GetUpperBounds(const NamedEntity &base) {
550   const Symbol &symbol{ResolveAssociations(base.GetLastSymbol())};
551   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
552     Shape result;
553     int dim{0};
554     for (const auto &shapeSpec : details->shape()) {
555       const auto &bound{shapeSpec.ubound().GetExplicit()};
556       if (bound && IsScopeInvariantExpr(*bound)) {
557         result.push_back(*bound);
558       } else if (details->IsAssumedSize() && dim + 1 == base.Rank()) {
559         result.emplace_back(std::nullopt); // UBOUND folding replaces with -1
560       } else if (auto lb{GetLBOUND(base, dim)}) {
561         result.emplace_back(
562             ComputeUpperBound(std::move(*lb), GetExtent(base, dim)));
563       } else {
564         result.emplace_back(); // unknown
565       }
566       ++dim;
567     }
568     CHECK(GetRank(result) == symbol.Rank());
569     return result;
570   } else {
571     return std::move(GetShape(symbol).value());
572   }
573 }
574 
575 Shape GetUpperBounds(FoldingContext &context, const NamedEntity &base) {
576   return Fold(context, GetUpperBounds(base));
577 }
578 
579 auto GetShapeHelper::operator()(const Symbol &symbol) const -> Result {
580   return std::visit(
581       common::visitors{
582           [&](const semantics::ObjectEntityDetails &object) {
583             if (IsImpliedShape(symbol) && object.init()) {
584               return (*this)(object.init());
585             } else if (IsAssumedRank(symbol)) {
586               return Result{};
587             } else {
588               int n{object.shape().Rank()};
589               NamedEntity base{symbol};
590               return Result{CreateShape(n, base)};
591             }
592           },
593           [](const semantics::EntityDetails &) {
594             return ScalarShape(); // no dimensions seen
595           },
596           [&](const semantics::ProcEntityDetails &proc) {
597             if (const Symbol * interface{proc.interface().symbol()}) {
598               return (*this)(*interface);
599             } else {
600               return ScalarShape();
601             }
602           },
603           [&](const semantics::AssocEntityDetails &assoc) {
604             if (assoc.rank()) { // SELECT RANK case
605               int n{assoc.rank().value()};
606               NamedEntity base{symbol};
607               return Result{CreateShape(n, base)};
608             } else {
609               return (*this)(assoc.expr());
610             }
611           },
612           [&](const semantics::SubprogramDetails &subp) -> Result {
613             if (subp.isFunction()) {
614               auto resultShape{(*this)(subp.result())};
615               if (resultShape && !useResultSymbolShape_) {
616                 // Ensure the shape is constant. Otherwise, it may be referring
617                 // to symbols that belong to the subroutine scope and are
618                 // meaningless on the caller side without the related call
619                 // expression.
620                 for (auto extent : *resultShape) {
621                   if (extent && !IsConstantExpr(*extent)) {
622                     return std::nullopt;
623                   }
624                 }
625               }
626               return resultShape;
627             } else {
628               return Result{};
629             }
630           },
631           [&](const semantics::ProcBindingDetails &binding) {
632             return (*this)(binding.symbol());
633           },
634           [](const semantics::TypeParamDetails &) { return ScalarShape(); },
635           [](const auto &) { return Result{}; },
636       },
637       symbol.GetUltimate().details());
638 }
639 
640 auto GetShapeHelper::operator()(const Component &component) const -> Result {
641   const Symbol &symbol{component.GetLastSymbol()};
642   int rank{symbol.Rank()};
643   if (rank == 0) {
644     return (*this)(component.base());
645   } else if (symbol.has<semantics::ObjectEntityDetails>()) {
646     NamedEntity base{Component{component}};
647     return CreateShape(rank, base);
648   } else if (symbol.has<semantics::AssocEntityDetails>()) {
649     NamedEntity base{Component{component}};
650     return Result{CreateShape(rank, base)};
651   } else {
652     return (*this)(symbol);
653   }
654 }
655 
656 auto GetShapeHelper::operator()(const ArrayRef &arrayRef) const -> Result {
657   Shape shape;
658   int dimension{0};
659   const NamedEntity &base{arrayRef.base()};
660   for (const Subscript &ss : arrayRef.subscript()) {
661     if (ss.Rank() > 0) {
662       shape.emplace_back(GetExtent(ss, base, dimension));
663     }
664     ++dimension;
665   }
666   if (shape.empty()) {
667     if (const Component * component{base.UnwrapComponent()}) {
668       return (*this)(component->base());
669     }
670   }
671   return shape;
672 }
673 
674 auto GetShapeHelper::operator()(const CoarrayRef &coarrayRef) const -> Result {
675   NamedEntity base{coarrayRef.GetBase()};
676   if (coarrayRef.subscript().empty()) {
677     return (*this)(base);
678   } else {
679     Shape shape;
680     int dimension{0};
681     for (const Subscript &ss : coarrayRef.subscript()) {
682       if (ss.Rank() > 0) {
683         shape.emplace_back(GetExtent(ss, base, dimension));
684       }
685       ++dimension;
686     }
687     return shape;
688   }
689 }
690 
691 auto GetShapeHelper::operator()(const Substring &substring) const -> Result {
692   return (*this)(substring.parent());
693 }
694 
695 auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {
696   if (call.Rank() == 0) {
697     return ScalarShape();
698   } else if (call.IsElemental()) {
699     for (const auto &arg : call.arguments()) {
700       if (arg && arg->Rank() > 0) {
701         return (*this)(*arg);
702       }
703     }
704     return ScalarShape();
705   } else if (const Symbol * symbol{call.proc().GetSymbol()}) {
706     return (*this)(*symbol);
707   } else if (const auto *intrinsic{call.proc().GetSpecificIntrinsic()}) {
708     if (intrinsic->name == "shape" || intrinsic->name == "lbound" ||
709         intrinsic->name == "ubound") {
710       // For LBOUND/UBOUND, these are the array-valued cases (no DIM=)
711       if (!call.arguments().empty() && call.arguments().front()) {
712         return Shape{
713             MaybeExtentExpr{ExtentExpr{call.arguments().front()->Rank()}}};
714       }
715     } else if (intrinsic->name == "all" || intrinsic->name == "any" ||
716         intrinsic->name == "count" || intrinsic->name == "iall" ||
717         intrinsic->name == "iany" || intrinsic->name == "iparity" ||
718         intrinsic->name == "maxval" || intrinsic->name == "minval" ||
719         intrinsic->name == "norm2" || intrinsic->name == "parity" ||
720         intrinsic->name == "product" || intrinsic->name == "sum") {
721       // Reduction with DIM=
722       if (call.arguments().size() >= 2) {
723         auto arrayShape{
724             (*this)(UnwrapExpr<Expr<SomeType>>(call.arguments().at(0)))};
725         const auto *dimArg{UnwrapExpr<Expr<SomeType>>(call.arguments().at(1))};
726         if (arrayShape && dimArg) {
727           if (auto dim{ToInt64(*dimArg)}) {
728             if (*dim >= 1 &&
729                 static_cast<std::size_t>(*dim) <= arrayShape->size()) {
730               arrayShape->erase(arrayShape->begin() + (*dim - 1));
731               return std::move(*arrayShape);
732             }
733           }
734         }
735       }
736     } else if (intrinsic->name == "findloc" || intrinsic->name == "maxloc" ||
737         intrinsic->name == "minloc") {
738       std::size_t dimIndex{intrinsic->name == "findloc" ? 2u : 1u};
739       if (call.arguments().size() > dimIndex) {
740         if (auto arrayShape{
741                 (*this)(UnwrapExpr<Expr<SomeType>>(call.arguments().at(0)))}) {
742           auto rank{static_cast<int>(arrayShape->size())};
743           if (const auto *dimArg{
744                   UnwrapExpr<Expr<SomeType>>(call.arguments()[dimIndex])}) {
745             auto dim{ToInt64(*dimArg)};
746             if (dim && *dim >= 1 && *dim <= rank) {
747               arrayShape->erase(arrayShape->begin() + (*dim - 1));
748               return std::move(*arrayShape);
749             }
750           } else {
751             // xxxLOC(no DIM=) result is vector(1:RANK(ARRAY=))
752             return Shape{ExtentExpr{rank}};
753           }
754         }
755       }
756     } else if (intrinsic->name == "cshift" || intrinsic->name == "eoshift") {
757       if (!call.arguments().empty()) {
758         return (*this)(call.arguments()[0]);
759       }
760     } else if (intrinsic->name == "matmul") {
761       if (call.arguments().size() == 2) {
762         if (auto ashape{(*this)(call.arguments()[0])}) {
763           if (auto bshape{(*this)(call.arguments()[1])}) {
764             if (ashape->size() == 1 && bshape->size() == 2) {
765               bshape->erase(bshape->begin());
766               return std::move(*bshape); // matmul(vector, matrix)
767             } else if (ashape->size() == 2 && bshape->size() == 1) {
768               ashape->pop_back();
769               return std::move(*ashape); // matmul(matrix, vector)
770             } else if (ashape->size() == 2 && bshape->size() == 2) {
771               (*ashape)[1] = std::move((*bshape)[1]);
772               return std::move(*ashape); // matmul(matrix, matrix)
773             }
774           }
775         }
776       }
777     } else if (intrinsic->name == "reshape") {
778       if (call.arguments().size() >= 2 && call.arguments().at(1)) {
779         // SHAPE(RESHAPE(array,shape)) -> shape
780         if (const auto *shapeExpr{
781                 call.arguments().at(1).value().UnwrapExpr()}) {
782           auto shape{std::get<Expr<SomeInteger>>(shapeExpr->u)};
783           return AsShape(ConvertToType<ExtentType>(std::move(shape)));
784         }
785       }
786     } else if (intrinsic->name == "pack") {
787       if (call.arguments().size() >= 3 && call.arguments().at(2)) {
788         // SHAPE(PACK(,,VECTOR=v)) -> SHAPE(v)
789         return (*this)(call.arguments().at(2));
790       } else if (call.arguments().size() >= 2 && context_) {
791         if (auto maskShape{(*this)(call.arguments().at(1))}) {
792           if (maskShape->size() == 0) {
793             // Scalar MASK= -> [MERGE(SIZE(ARRAY=), 0, mask)]
794             if (auto arrayShape{(*this)(call.arguments().at(0))}) {
795               auto arraySize{GetSize(std::move(*arrayShape))};
796               CHECK(arraySize);
797               ActualArguments toMerge{
798                   ActualArgument{AsGenericExpr(std::move(*arraySize))},
799                   ActualArgument{AsGenericExpr(ExtentExpr{0})},
800                   common::Clone(call.arguments().at(1))};
801               auto specific{context_->intrinsics().Probe(
802                   CallCharacteristics{"merge"}, toMerge, *context_)};
803               CHECK(specific);
804               return Shape{ExtentExpr{FunctionRef<ExtentType>{
805                   ProcedureDesignator{std::move(specific->specificIntrinsic)},
806                   std::move(specific->arguments)}}};
807             }
808           } else {
809             // Non-scalar MASK= -> [COUNT(mask)]
810             ActualArguments toCount{ActualArgument{common::Clone(
811                 DEREF(call.arguments().at(1).value().UnwrapExpr()))}};
812             auto specific{context_->intrinsics().Probe(
813                 CallCharacteristics{"count"}, toCount, *context_)};
814             CHECK(specific);
815             return Shape{ExtentExpr{FunctionRef<ExtentType>{
816                 ProcedureDesignator{std::move(specific->specificIntrinsic)},
817                 std::move(specific->arguments)}}};
818           }
819         }
820       }
821     } else if (intrinsic->name == "spread") {
822       // SHAPE(SPREAD(ARRAY,DIM,NCOPIES)) = SHAPE(ARRAY) with NCOPIES inserted
823       // at position DIM.
824       if (call.arguments().size() == 3) {
825         auto arrayShape{
826             (*this)(UnwrapExpr<Expr<SomeType>>(call.arguments().at(0)))};
827         const auto *dimArg{UnwrapExpr<Expr<SomeType>>(call.arguments().at(1))};
828         const auto *nCopies{
829             UnwrapExpr<Expr<SomeInteger>>(call.arguments().at(2))};
830         if (arrayShape && dimArg && nCopies) {
831           if (auto dim{ToInt64(*dimArg)}) {
832             if (*dim >= 1 &&
833                 static_cast<std::size_t>(*dim) <= arrayShape->size() + 1) {
834               arrayShape->emplace(arrayShape->begin() + *dim - 1,
835                   ConvertToType<ExtentType>(common::Clone(*nCopies)));
836               return std::move(*arrayShape);
837             }
838           }
839         }
840       }
841     } else if (intrinsic->name == "transfer") {
842       if (call.arguments().size() == 3 && call.arguments().at(2)) {
843         // SIZE= is present; shape is vector [SIZE=]
844         if (const auto *size{
845                 UnwrapExpr<Expr<SomeInteger>>(call.arguments().at(2))}) {
846           return Shape{
847               MaybeExtentExpr{ConvertToType<ExtentType>(common::Clone(*size))}};
848         }
849       } else if (context_) {
850         if (auto moldTypeAndShape{characteristics::TypeAndShape::Characterize(
851                 call.arguments().at(1), *context_)}) {
852           if (GetRank(moldTypeAndShape->shape()) == 0) {
853             // SIZE= is absent and MOLD= is scalar: result is scalar
854             return ScalarShape();
855           } else {
856             // SIZE= is absent and MOLD= is array: result is vector whose
857             // length is determined by sizes of types.  See 16.9.193p4 case(ii).
858             if (auto sourceTypeAndShape{
859                     characteristics::TypeAndShape::Characterize(
860                         call.arguments().at(0), *context_)}) {
861               auto sourceBytes{
862                   sourceTypeAndShape->MeasureSizeInBytes(*context_)};
863               auto moldElementBytes{
864                   moldTypeAndShape->MeasureElementSizeInBytes(*context_, true)};
865               if (sourceBytes && moldElementBytes) {
866                 ExtentExpr extent{Fold(*context_,
867                     (std::move(*sourceBytes) +
868                         common::Clone(*moldElementBytes) - ExtentExpr{1}) /
869                         common::Clone(*moldElementBytes))};
870                 return Shape{MaybeExtentExpr{std::move(extent)}};
871               }
872             }
873           }
874         }
875       }
876     } else if (intrinsic->name == "transpose") {
877       if (call.arguments().size() >= 1) {
878         if (auto shape{(*this)(call.arguments().at(0))}) {
879           if (shape->size() == 2) {
880             std::swap((*shape)[0], (*shape)[1]);
881             return shape;
882           }
883         }
884       }
885     } else if (intrinsic->name == "unpack") {
886       if (call.arguments().size() >= 2) {
887         return (*this)(call.arguments()[1]); // MASK=
888       }
889     } else if (intrinsic->characteristics.value().attrs.test(characteristics::
890                        Procedure::Attr::NullPointer)) { // NULL(MOLD=)
891       return (*this)(call.arguments());
892     } else {
893       // TODO: shapes of other non-elemental intrinsic results
894     }
895   }
896   return std::nullopt;
897 }
898 
899 // Check conformance of the passed shapes.
900 std::optional<bool> CheckConformance(parser::ContextualMessages &messages,
901     const Shape &left, const Shape &right, CheckConformanceFlags::Flags flags,
902     const char *leftIs, const char *rightIs) {
903   int n{GetRank(left)};
904   if (n == 0 && (flags & CheckConformanceFlags::LeftScalarExpandable)) {
905     return true;
906   }
907   int rn{GetRank(right)};
908   if (rn == 0 && (flags & CheckConformanceFlags::RightScalarExpandable)) {
909     return true;
910   }
911   if (n != rn) {
912     messages.Say("Rank of %1$s is %2$d, but %3$s has rank %4$d"_err_en_US,
913         leftIs, n, rightIs, rn);
914     return false;
915   }
916   for (int j{0}; j < n; ++j) {
917     if (auto leftDim{ToInt64(left[j])}) {
918       if (auto rightDim{ToInt64(right[j])}) {
919         if (*leftDim != *rightDim) {
920           messages.Say("Dimension %1$d of %2$s has extent %3$jd, "
921                        "but %4$s has extent %5$jd"_err_en_US,
922               j + 1, leftIs, *leftDim, rightIs, *rightDim);
923           return false;
924         }
925       } else if (!(flags & CheckConformanceFlags::RightIsDeferredShape)) {
926         return std::nullopt;
927       }
928     } else if (!(flags & CheckConformanceFlags::LeftIsDeferredShape)) {
929       return std::nullopt;
930     }
931   }
932   return true;
933 }
934 
935 bool IncrementSubscripts(
936     ConstantSubscripts &indices, const ConstantSubscripts &extents) {
937   std::size_t rank(indices.size());
938   CHECK(rank <= extents.size());
939   for (std::size_t j{0}; j < rank; ++j) {
940     if (extents[j] < 1) {
941       return false;
942     }
943   }
944   for (std::size_t j{0}; j < rank; ++j) {
945     if (indices[j]++ < extents[j]) {
946       return true;
947     }
948     indices[j] = 1;
949   }
950   return false;
951 }
952 
953 } // namespace Fortran::evaluate
954