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