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