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().IsImpliedShape();
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) {
560             if (subp.isFunction()) {
561               return (*this)(subp.result());
562             } else {
563               return Result{};
564             }
565           },
566           [&](const semantics::ProcBindingDetails &binding) {
567             return (*this)(binding.symbol());
568           },
569           [](const semantics::TypeParamDetails &) { return ScalarShape(); },
570           [](const auto &) { return Result{}; },
571       },
572       symbol.GetUltimate().details());
573 }
574 
575 auto GetShapeHelper::operator()(const Component &component) const -> Result {
576   const Symbol &symbol{component.GetLastSymbol()};
577   int rank{symbol.Rank()};
578   if (rank == 0) {
579     return (*this)(component.base());
580   } else if (symbol.has<semantics::ObjectEntityDetails>()) {
581     NamedEntity base{Component{component}};
582     return CreateShape(rank, base);
583   } else if (symbol.has<semantics::AssocEntityDetails>()) {
584     NamedEntity base{Component{component}};
585     return Result{CreateShape(rank, base)};
586   } else {
587     return (*this)(symbol);
588   }
589 }
590 
591 auto GetShapeHelper::operator()(const ArrayRef &arrayRef) const -> Result {
592   Shape shape;
593   int dimension{0};
594   const NamedEntity &base{arrayRef.base()};
595   for (const Subscript &ss : arrayRef.subscript()) {
596     if (ss.Rank() > 0) {
597       shape.emplace_back(GetExtent(ss, base, dimension));
598     }
599     ++dimension;
600   }
601   if (shape.empty()) {
602     if (const Component * component{base.UnwrapComponent()}) {
603       return (*this)(component->base());
604     }
605   }
606   return shape;
607 }
608 
609 auto GetShapeHelper::operator()(const CoarrayRef &coarrayRef) const -> Result {
610   NamedEntity base{coarrayRef.GetBase()};
611   if (coarrayRef.subscript().empty()) {
612     return (*this)(base);
613   } else {
614     Shape shape;
615     int dimension{0};
616     for (const Subscript &ss : coarrayRef.subscript()) {
617       if (ss.Rank() > 0) {
618         shape.emplace_back(GetExtent(ss, base, dimension));
619       }
620       ++dimension;
621     }
622     return shape;
623   }
624 }
625 
626 auto GetShapeHelper::operator()(const Substring &substring) const -> Result {
627   return (*this)(substring.parent());
628 }
629 
630 auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {
631   if (call.Rank() == 0) {
632     return ScalarShape();
633   } else if (call.IsElemental()) {
634     for (const auto &arg : call.arguments()) {
635       if (arg && arg->Rank() > 0) {
636         return (*this)(*arg);
637       }
638     }
639     return ScalarShape();
640   } else if (const Symbol * symbol{call.proc().GetSymbol()}) {
641     return (*this)(*symbol);
642   } else if (const auto *intrinsic{call.proc().GetSpecificIntrinsic()}) {
643     if (intrinsic->name == "shape" || intrinsic->name == "lbound" ||
644         intrinsic->name == "ubound") {
645       // These are the array-valued cases for LBOUND and UBOUND (no DIM=).
646       const auto *expr{call.arguments().front().value().UnwrapExpr()};
647       CHECK(expr);
648       return Shape{MaybeExtentExpr{ExtentExpr{expr->Rank()}}};
649     } else if (intrinsic->name == "all" || intrinsic->name == "any" ||
650         intrinsic->name == "count" || intrinsic->name == "iall" ||
651         intrinsic->name == "iany" || intrinsic->name == "iparity" ||
652         intrinsic->name == "maxval" || intrinsic->name == "minval" ||
653         intrinsic->name == "norm2" || intrinsic->name == "parity" ||
654         intrinsic->name == "product" || intrinsic->name == "sum") {
655       // Reduction with DIM=
656       if (call.arguments().size() >= 2) {
657         auto arrayShape{
658             (*this)(UnwrapExpr<Expr<SomeType>>(call.arguments().at(0)))};
659         const auto *dimArg{UnwrapExpr<Expr<SomeType>>(call.arguments().at(1))};
660         if (arrayShape && dimArg) {
661           if (auto dim{ToInt64(*dimArg)}) {
662             if (*dim >= 1 &&
663                 static_cast<std::size_t>(*dim) <= arrayShape->size()) {
664               arrayShape->erase(arrayShape->begin() + (*dim - 1));
665               return std::move(*arrayShape);
666             }
667           }
668         }
669       }
670     } else if (intrinsic->name == "findloc" || intrinsic->name == "maxloc" ||
671         intrinsic->name == "minloc") {
672       std::size_t dimIndex{intrinsic->name == "findloc" ? 2u : 1u};
673       if (call.arguments().size() > dimIndex) {
674         if (auto arrayShape{
675                 (*this)(UnwrapExpr<Expr<SomeType>>(call.arguments().at(0)))}) {
676           auto rank{static_cast<int>(arrayShape->size())};
677           if (const auto *dimArg{
678                   UnwrapExpr<Expr<SomeType>>(call.arguments()[dimIndex])}) {
679             auto dim{ToInt64(*dimArg)};
680             if (dim && *dim >= 1 && *dim <= rank) {
681               arrayShape->erase(arrayShape->begin() + (*dim - 1));
682               return std::move(*arrayShape);
683             }
684           } else {
685             // xxxLOC(no DIM=) result is vector(1:RANK(ARRAY=))
686             return Shape{ExtentExpr{rank}};
687           }
688         }
689       }
690     } else if (intrinsic->name == "cshift" || intrinsic->name == "eoshift") {
691       if (!call.arguments().empty()) {
692         return (*this)(call.arguments()[0]);
693       }
694     } else if (intrinsic->name == "matmul") {
695       if (call.arguments().size() == 2) {
696         if (auto ashape{(*this)(call.arguments()[0])}) {
697           if (auto bshape{(*this)(call.arguments()[1])}) {
698             if (ashape->size() == 1 && bshape->size() == 2) {
699               bshape->erase(bshape->begin());
700               return std::move(*bshape); // matmul(vector, matrix)
701             } else if (ashape->size() == 2 && bshape->size() == 1) {
702               ashape->pop_back();
703               return std::move(*ashape); // matmul(matrix, vector)
704             } else if (ashape->size() == 2 && bshape->size() == 2) {
705               (*ashape)[1] = std::move((*bshape)[1]);
706               return std::move(*ashape); // matmul(matrix, matrix)
707             }
708           }
709         }
710       }
711     } else if (intrinsic->name == "reshape") {
712       if (call.arguments().size() >= 2 && call.arguments().at(1)) {
713         // SHAPE(RESHAPE(array,shape)) -> shape
714         if (const auto *shapeExpr{
715                 call.arguments().at(1).value().UnwrapExpr()}) {
716           auto shape{std::get<Expr<SomeInteger>>(shapeExpr->u)};
717           return AsShape(ConvertToType<ExtentType>(std::move(shape)));
718         }
719       }
720     } else if (intrinsic->name == "pack") {
721       if (call.arguments().size() >= 3 && call.arguments().at(2)) {
722         // SHAPE(PACK(,,VECTOR=v)) -> SHAPE(v)
723         return (*this)(call.arguments().at(2));
724       } else if (call.arguments().size() >= 2 && context_) {
725         if (auto maskShape{(*this)(call.arguments().at(1))}) {
726           if (maskShape->size() == 0) {
727             // Scalar MASK= -> [MERGE(SIZE(ARRAY=), 0, mask)]
728             if (auto arrayShape{(*this)(call.arguments().at(0))}) {
729               auto arraySize{GetSize(std::move(*arrayShape))};
730               CHECK(arraySize);
731               ActualArguments toMerge{
732                   ActualArgument{AsGenericExpr(std::move(*arraySize))},
733                   ActualArgument{AsGenericExpr(ExtentExpr{0})},
734                   common::Clone(call.arguments().at(1))};
735               auto specific{context_->intrinsics().Probe(
736                   CallCharacteristics{"merge"}, toMerge, *context_)};
737               CHECK(specific);
738               return Shape{ExtentExpr{FunctionRef<ExtentType>{
739                   ProcedureDesignator{std::move(specific->specificIntrinsic)},
740                   std::move(specific->arguments)}}};
741             }
742           } else {
743             // Non-scalar MASK= -> [COUNT(mask)]
744             ActualArguments toCount{ActualArgument{common::Clone(
745                 DEREF(call.arguments().at(1).value().UnwrapExpr()))}};
746             auto specific{context_->intrinsics().Probe(
747                 CallCharacteristics{"count"}, toCount, *context_)};
748             CHECK(specific);
749             return Shape{ExtentExpr{FunctionRef<ExtentType>{
750                 ProcedureDesignator{std::move(specific->specificIntrinsic)},
751                 std::move(specific->arguments)}}};
752           }
753         }
754       }
755     } else if (intrinsic->name == "spread") {
756       // SHAPE(SPREAD(ARRAY,DIM,NCOPIES)) = SHAPE(ARRAY) with NCOPIES inserted
757       // at position DIM.
758       if (call.arguments().size() == 3) {
759         auto arrayShape{
760             (*this)(UnwrapExpr<Expr<SomeType>>(call.arguments().at(0)))};
761         const auto *dimArg{UnwrapExpr<Expr<SomeType>>(call.arguments().at(1))};
762         const auto *nCopies{
763             UnwrapExpr<Expr<SomeInteger>>(call.arguments().at(2))};
764         if (arrayShape && dimArg && nCopies) {
765           if (auto dim{ToInt64(*dimArg)}) {
766             if (*dim >= 1 &&
767                 static_cast<std::size_t>(*dim) <= arrayShape->size() + 1) {
768               arrayShape->emplace(arrayShape->begin() + *dim - 1,
769                   ConvertToType<ExtentType>(common::Clone(*nCopies)));
770               return std::move(*arrayShape);
771             }
772           }
773         }
774       }
775     } else if (intrinsic->name == "transfer") {
776       if (call.arguments().size() == 3 && call.arguments().at(2)) {
777         // SIZE= is present; shape is vector [SIZE=]
778         if (const auto *size{
779                 UnwrapExpr<Expr<SomeInteger>>(call.arguments().at(2))}) {
780           return Shape{
781               MaybeExtentExpr{ConvertToType<ExtentType>(common::Clone(*size))}};
782         }
783       } else if (context_) {
784         if (auto moldTypeAndShape{characteristics::TypeAndShape::Characterize(
785                 call.arguments().at(1), *context_)}) {
786           if (GetRank(moldTypeAndShape->shape()) == 0) {
787             // SIZE= is absent and MOLD= is scalar: result is scalar
788             return ScalarShape();
789           } else {
790             // SIZE= is absent and MOLD= is array: result is vector whose
791             // length is determined by sizes of types.  See 16.9.193p4 case(ii).
792             if (auto sourceTypeAndShape{
793                     characteristics::TypeAndShape::Characterize(
794                         call.arguments().at(0), *context_)}) {
795               auto sourceBytes{
796                   sourceTypeAndShape->MeasureSizeInBytes(*context_)};
797               auto moldElementBytes{
798                   moldTypeAndShape->MeasureElementSizeInBytes(*context_, true)};
799               if (sourceBytes && moldElementBytes) {
800                 ExtentExpr extent{Fold(*context_,
801                     (std::move(*sourceBytes) +
802                         common::Clone(*moldElementBytes) - ExtentExpr{1}) /
803                         common::Clone(*moldElementBytes))};
804                 return Shape{MaybeExtentExpr{std::move(extent)}};
805               }
806             }
807           }
808         }
809       }
810     } else if (intrinsic->name == "transpose") {
811       if (call.arguments().size() >= 1) {
812         if (auto shape{(*this)(call.arguments().at(0))}) {
813           if (shape->size() == 2) {
814             std::swap((*shape)[0], (*shape)[1]);
815             return shape;
816           }
817         }
818       }
819     } else if (intrinsic->name == "unpack") {
820       if (call.arguments().size() >= 2) {
821         return (*this)(call.arguments()[1]); // MASK=
822       }
823     } else if (intrinsic->characteristics.value().attrs.test(characteristics::
824                        Procedure::Attr::NullPointer)) { // NULL(MOLD=)
825       return (*this)(call.arguments());
826     } else {
827       // TODO: shapes of other non-elemental intrinsic results
828     }
829   }
830   return std::nullopt;
831 }
832 
833 // Check conformance of the passed shapes.
834 std::optional<bool> CheckConformance(parser::ContextualMessages &messages,
835     const Shape &left, const Shape &right, CheckConformanceFlags::Flags flags,
836     const char *leftIs, const char *rightIs) {
837   int n{GetRank(left)};
838   if (n == 0 && (flags & CheckConformanceFlags::LeftScalarExpandable)) {
839     return true;
840   }
841   int rn{GetRank(right)};
842   if (rn == 0 && (flags & CheckConformanceFlags::RightScalarExpandable)) {
843     return true;
844   }
845   if (n != rn) {
846     messages.Say("Rank of %1$s is %2$d, but %3$s has rank %4$d"_err_en_US,
847         leftIs, n, rightIs, rn);
848     return false;
849   }
850   for (int j{0}; j < n; ++j) {
851     if (auto leftDim{ToInt64(left[j])}) {
852       if (auto rightDim{ToInt64(right[j])}) {
853         if (*leftDim != *rightDim) {
854           messages.Say("Dimension %1$d of %2$s has extent %3$jd, "
855                        "but %4$s has extent %5$jd"_err_en_US,
856               j + 1, leftIs, *leftDim, rightIs, *rightDim);
857           return false;
858         }
859       } else if (!(flags & CheckConformanceFlags::RightIsDeferredShape)) {
860         return std::nullopt;
861       }
862     } else if (!(flags & CheckConformanceFlags::LeftIsDeferredShape)) {
863       return std::nullopt;
864     }
865   }
866   return true;
867 }
868 
869 bool IncrementSubscripts(
870     ConstantSubscripts &indices, const ConstantSubscripts &extents) {
871   std::size_t rank(indices.size());
872   CHECK(rank <= extents.size());
873   for (std::size_t j{0}; j < rank; ++j) {
874     if (extents[j] < 1) {
875       return false;
876     }
877   }
878   for (std::size_t j{0}; j < rank; ++j) {
879     if (indices[j]++ < extents[j]) {
880       return true;
881     }
882     indices[j] = 1;
883   }
884   return false;
885 }
886 
887 } // namespace Fortran::evaluate
888