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/fold.h"
14 #include "flang/Evaluate/intrinsics.h"
15 #include "flang/Evaluate/tools.h"
16 #include "flang/Evaluate/type.h"
17 #include "flang/Parser/message.h"
18 #include "flang/Semantics/symbol.h"
19 #include <functional>
20 
21 using namespace std::placeholders; // _1, _2, &c. for std::bind()
22 
23 namespace Fortran::evaluate {
24 
25 bool IsImpliedShape(const Symbol &original) {
26   const Symbol &symbol{ResolveAssociations(original)};
27   const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()};
28   return details && symbol.attrs().test(semantics::Attr::PARAMETER) &&
29       details->shape().IsImpliedShape();
30 }
31 
32 bool IsExplicitShape(const Symbol &original) {
33   const Symbol &symbol{ResolveAssociations(original)};
34   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
35     const auto &shape{details->shape()};
36     return shape.Rank() == 0 ||
37         shape.IsExplicitShape(); // true when scalar, too
38   } else {
39     return symbol
40         .has<semantics::AssocEntityDetails>(); // exprs have explicit shape
41   }
42 }
43 
44 Shape GetShapeHelper::ConstantShape(const Constant<ExtentType> &arrayConstant) {
45   CHECK(arrayConstant.Rank() == 1);
46   Shape result;
47   std::size_t dimensions{arrayConstant.size()};
48   for (std::size_t j{0}; j < dimensions; ++j) {
49     Scalar<ExtentType> extent{arrayConstant.values().at(j)};
50     result.emplace_back(MaybeExtentExpr{ExtentExpr{std::move(extent)}});
51   }
52   return result;
53 }
54 
55 auto GetShapeHelper::AsShape(ExtentExpr &&arrayExpr) const -> Result {
56   if (context_) {
57     arrayExpr = Fold(*context_, std::move(arrayExpr));
58   }
59   if (const auto *constArray{UnwrapConstantValue<ExtentType>(arrayExpr)}) {
60     return ConstantShape(*constArray);
61   }
62   if (auto *constructor{UnwrapExpr<ArrayConstructor<ExtentType>>(arrayExpr)}) {
63     Shape result;
64     for (auto &value : *constructor) {
65       if (auto *expr{std::get_if<ExtentExpr>(&value.u)}) {
66         if (expr->Rank() == 0) {
67           result.emplace_back(std::move(*expr));
68           continue;
69         }
70       }
71       return std::nullopt;
72     }
73     return result;
74   }
75   return std::nullopt;
76 }
77 
78 Shape GetShapeHelper::CreateShape(int rank, NamedEntity &base) {
79   Shape shape;
80   for (int dimension{0}; dimension < rank; ++dimension) {
81     shape.emplace_back(GetExtent(base, dimension));
82   }
83   return shape;
84 }
85 
86 std::optional<ExtentExpr> AsExtentArrayExpr(const Shape &shape) {
87   ArrayConstructorValues<ExtentType> values;
88   for (const auto &dim : shape) {
89     if (dim) {
90       values.Push(common::Clone(*dim));
91     } else {
92       return std::nullopt;
93     }
94   }
95   return ExtentExpr{ArrayConstructor<ExtentType>{std::move(values)}};
96 }
97 
98 std::optional<Constant<ExtentType>> AsConstantShape(
99     FoldingContext &context, const Shape &shape) {
100   if (auto shapeArray{AsExtentArrayExpr(shape)}) {
101     auto folded{Fold(context, std::move(*shapeArray))};
102     if (auto *p{UnwrapConstantValue<ExtentType>(folded)}) {
103       return std::move(*p);
104     }
105   }
106   return std::nullopt;
107 }
108 
109 Constant<SubscriptInteger> AsConstantShape(const ConstantSubscripts &shape) {
110   using IntType = Scalar<SubscriptInteger>;
111   std::vector<IntType> result;
112   for (auto dim : shape) {
113     result.emplace_back(dim);
114   }
115   return {std::move(result), ConstantSubscripts{GetRank(shape)}};
116 }
117 
118 ConstantSubscripts AsConstantExtents(const Constant<ExtentType> &shape) {
119   ConstantSubscripts result;
120   for (const auto &extent : shape.values()) {
121     result.push_back(extent.ToInt64());
122   }
123   return result;
124 }
125 
126 std::optional<ConstantSubscripts> AsConstantExtents(
127     FoldingContext &context, const Shape &shape) {
128   if (auto shapeConstant{AsConstantShape(context, shape)}) {
129     return AsConstantExtents(*shapeConstant);
130   } else {
131     return std::nullopt;
132   }
133 }
134 
135 Shape AsShape(const ConstantSubscripts &shape) {
136   Shape result;
137   for (const auto &extent : shape) {
138     result.emplace_back(ExtentExpr{extent});
139   }
140   return result;
141 }
142 
143 std::optional<Shape> AsShape(const std::optional<ConstantSubscripts> &shape) {
144   if (shape) {
145     return AsShape(*shape);
146   } else {
147     return std::nullopt;
148   }
149 }
150 
151 Shape Fold(FoldingContext &context, Shape &&shape) {
152   for (auto &dim : shape) {
153     dim = Fold(context, std::move(dim));
154   }
155   return std::move(shape);
156 }
157 
158 std::optional<Shape> Fold(
159     FoldingContext &context, std::optional<Shape> &&shape) {
160   if (shape) {
161     return Fold(context, std::move(*shape));
162   } else {
163     return std::nullopt;
164   }
165 }
166 
167 static ExtentExpr ComputeTripCount(
168     ExtentExpr &&lower, ExtentExpr &&upper, ExtentExpr &&stride) {
169   ExtentExpr strideCopy{common::Clone(stride)};
170   ExtentExpr span{
171       (std::move(upper) - std::move(lower) + std::move(strideCopy)) /
172       std::move(stride)};
173   return ExtentExpr{
174       Extremum<ExtentType>{Ordering::Greater, std::move(span), ExtentExpr{0}}};
175 }
176 
177 ExtentExpr CountTrips(
178     ExtentExpr &&lower, ExtentExpr &&upper, ExtentExpr &&stride) {
179   return ComputeTripCount(
180       std::move(lower), std::move(upper), std::move(stride));
181 }
182 
183 ExtentExpr CountTrips(const ExtentExpr &lower, const ExtentExpr &upper,
184     const ExtentExpr &stride) {
185   return ComputeTripCount(
186       common::Clone(lower), common::Clone(upper), common::Clone(stride));
187 }
188 
189 MaybeExtentExpr CountTrips(MaybeExtentExpr &&lower, MaybeExtentExpr &&upper,
190     MaybeExtentExpr &&stride) {
191   std::function<ExtentExpr(ExtentExpr &&, ExtentExpr &&, ExtentExpr &&)> bound{
192       std::bind(ComputeTripCount, _1, _2, _3)};
193   return common::MapOptional(
194       std::move(bound), std::move(lower), std::move(upper), std::move(stride));
195 }
196 
197 MaybeExtentExpr GetSize(Shape &&shape) {
198   ExtentExpr extent{1};
199   for (auto &&dim : std::move(shape)) {
200     if (dim) {
201       extent = std::move(extent) * std::move(*dim);
202     } else {
203       return std::nullopt;
204     }
205   }
206   return extent;
207 }
208 
209 ConstantSubscript GetSize(const ConstantSubscripts &shape) {
210   ConstantSubscript size{1};
211   for (auto dim : std::move(shape)) {
212     size *= dim;
213   }
214   return size;
215 }
216 
217 bool ContainsAnyImpliedDoIndex(const ExtentExpr &expr) {
218   struct MyVisitor : public AnyTraverse<MyVisitor> {
219     using Base = AnyTraverse<MyVisitor>;
220     MyVisitor() : Base{*this} {}
221     using Base::operator();
222     bool operator()(const ImpliedDoIndex &) { return true; }
223   };
224   return MyVisitor{}(expr);
225 }
226 
227 // Determines lower bound on a dimension.  This can be other than 1 only
228 // for a reference to a whole array object or component. (See LBOUND, 16.9.109).
229 // ASSOCIATE construct entities may require traversal of their referents.
230 class GetLowerBoundHelper : public Traverse<GetLowerBoundHelper, ExtentExpr> {
231 public:
232   using Result = ExtentExpr;
233   using Base = Traverse<GetLowerBoundHelper, ExtentExpr>;
234   using Base::operator();
235   explicit GetLowerBoundHelper(int d) : Base{*this}, dimension_{d} {}
236   static ExtentExpr Default() { return ExtentExpr{1}; }
237   static ExtentExpr Combine(Result &&, Result &&) { return Default(); }
238   ExtentExpr operator()(const Symbol &);
239   ExtentExpr operator()(const Component &);
240 
241 private:
242   int dimension_;
243 };
244 
245 auto GetLowerBoundHelper::operator()(const Symbol &symbol0) -> Result {
246   const Symbol &symbol{symbol0.GetUltimate()};
247   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
248     int j{0};
249     for (const auto &shapeSpec : details->shape()) {
250       if (j++ == dimension_) {
251         if (const auto &bound{shapeSpec.lbound().GetExplicit()}) {
252           return *bound;
253         } else if (IsDescriptor(symbol)) {
254           return ExtentExpr{DescriptorInquiry{NamedEntity{symbol0},
255               DescriptorInquiry::Field::LowerBound, dimension_}};
256         } else {
257           break;
258         }
259       }
260     }
261   } else if (const auto *assoc{
262                  symbol.detailsIf<semantics::AssocEntityDetails>()}) {
263     if (assoc->rank()) { // SELECT RANK case
264       const Symbol &resolved{ResolveAssociations(symbol)};
265       if (IsDescriptor(resolved) && dimension_ < *assoc->rank()) {
266         return ExtentExpr{DescriptorInquiry{NamedEntity{symbol0},
267             DescriptorInquiry::Field::LowerBound, dimension_}};
268       }
269     } else {
270       return (*this)(assoc->expr());
271     }
272   }
273   return Default();
274 }
275 
276 auto GetLowerBoundHelper::operator()(const Component &component) -> Result {
277   if (component.base().Rank() == 0) {
278     const Symbol &symbol{component.GetLastSymbol().GetUltimate()};
279     if (const auto *details{
280             symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
281       int j{0};
282       for (const auto &shapeSpec : details->shape()) {
283         if (j++ == dimension_) {
284           if (const auto &bound{shapeSpec.lbound().GetExplicit()}) {
285             return *bound;
286           } else if (IsDescriptor(symbol)) {
287             return ExtentExpr{
288                 DescriptorInquiry{NamedEntity{common::Clone(component)},
289                     DescriptorInquiry::Field::LowerBound, dimension_}};
290           } else {
291             break;
292           }
293         }
294       }
295     }
296   }
297   return Default();
298 }
299 
300 ExtentExpr GetLowerBound(const NamedEntity &base, int dimension) {
301   return GetLowerBoundHelper{dimension}(base);
302 }
303 
304 ExtentExpr GetLowerBound(
305     FoldingContext &context, const NamedEntity &base, int dimension) {
306   return Fold(context, GetLowerBound(base, dimension));
307 }
308 
309 Shape GetLowerBounds(const NamedEntity &base) {
310   Shape result;
311   int rank{base.Rank()};
312   for (int dim{0}; dim < rank; ++dim) {
313     result.emplace_back(GetLowerBound(base, dim));
314   }
315   return result;
316 }
317 
318 Shape GetLowerBounds(FoldingContext &context, const NamedEntity &base) {
319   Shape result;
320   int rank{base.Rank()};
321   for (int dim{0}; dim < rank; ++dim) {
322     result.emplace_back(GetLowerBound(context, base, dim));
323   }
324   return result;
325 }
326 
327 // If the upper and lower bounds are constant, return a constant expression for
328 // the extent.  In particular, if the upper bound is less than the lower bound,
329 // return zero.
330 static MaybeExtentExpr GetNonNegativeExtent(
331     const semantics::ShapeSpec &shapeSpec) {
332   const auto &ubound{shapeSpec.ubound().GetExplicit()};
333   const auto &lbound{shapeSpec.lbound().GetExplicit()};
334   std::optional<ConstantSubscript> uval{ToInt64(ubound)};
335   std::optional<ConstantSubscript> lval{ToInt64(lbound)};
336   if (uval && lval) {
337     if (*uval < *lval) {
338       return ExtentExpr{0};
339     } else {
340       return ExtentExpr{*uval - *lval + 1};
341     }
342   }
343   return common::Clone(ubound.value()) - common::Clone(lbound.value()) +
344       ExtentExpr{1};
345 }
346 
347 MaybeExtentExpr GetExtent(const NamedEntity &base, int dimension) {
348   CHECK(dimension >= 0);
349   const Symbol &last{base.GetLastSymbol()};
350   const Symbol &symbol{ResolveAssociations(last)};
351   if (const auto *assoc{last.detailsIf<semantics::AssocEntityDetails>()}) {
352     if (assoc->rank()) { // SELECT RANK case
353       if (semantics::IsDescriptor(symbol) && dimension < *assoc->rank()) {
354         return ExtentExpr{DescriptorInquiry{
355             NamedEntity{base}, DescriptorInquiry::Field::Extent, dimension}};
356       }
357     } else if (auto shape{GetShape(assoc->expr())}) {
358       if (dimension < static_cast<int>(shape->size())) {
359         return std::move(shape->at(dimension));
360       }
361     }
362   }
363   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
364     if (IsImpliedShape(symbol) && details->init()) {
365       if (auto shape{GetShape(symbol)}) {
366         if (dimension < static_cast<int>(shape->size())) {
367           return std::move(shape->at(dimension));
368         }
369       }
370     } else {
371       int j{0};
372       for (const auto &shapeSpec : details->shape()) {
373         if (j++ == dimension) {
374           if (const auto &ubound{shapeSpec.ubound().GetExplicit()}) {
375             if (shapeSpec.ubound().GetExplicit()) {
376               // 8.5.8.2, paragraph 3.  If the upper bound is less than the
377               // lower bound, the extent is zero.
378               if (shapeSpec.lbound().GetExplicit()) {
379                 return GetNonNegativeExtent(shapeSpec);
380               } else {
381                 return ubound.value();
382               }
383             }
384           } else if (details->IsAssumedSize() && j == symbol.Rank()) {
385             return std::nullopt;
386           } else if (semantics::IsDescriptor(symbol)) {
387             return ExtentExpr{DescriptorInquiry{NamedEntity{base},
388                 DescriptorInquiry::Field::Extent, dimension}};
389           }
390         }
391       }
392     }
393   }
394   return std::nullopt;
395 }
396 
397 MaybeExtentExpr GetExtent(
398     FoldingContext &context, const NamedEntity &base, int dimension) {
399   return Fold(context, GetExtent(base, dimension));
400 }
401 
402 MaybeExtentExpr GetExtent(
403     const Subscript &subscript, const NamedEntity &base, int dimension) {
404   return std::visit(
405       common::visitors{
406           [&](const Triplet &triplet) -> MaybeExtentExpr {
407             MaybeExtentExpr upper{triplet.upper()};
408             if (!upper) {
409               upper = GetUpperBound(base, dimension);
410             }
411             MaybeExtentExpr lower{triplet.lower()};
412             if (!lower) {
413               lower = GetLowerBound(base, dimension);
414             }
415             return CountTrips(std::move(lower), std::move(upper),
416                 MaybeExtentExpr{triplet.stride()});
417           },
418           [&](const IndirectSubscriptIntegerExpr &subs) -> MaybeExtentExpr {
419             if (auto shape{GetShape(subs.value())}) {
420               if (GetRank(*shape) > 0) {
421                 CHECK(GetRank(*shape) == 1); // vector-valued subscript
422                 return std::move(shape->at(0));
423               }
424             }
425             return std::nullopt;
426           },
427       },
428       subscript.u);
429 }
430 
431 MaybeExtentExpr GetExtent(FoldingContext &context, const Subscript &subscript,
432     const NamedEntity &base, int dimension) {
433   return Fold(context, GetExtent(subscript, base, dimension));
434 }
435 
436 MaybeExtentExpr ComputeUpperBound(
437     ExtentExpr &&lower, MaybeExtentExpr &&extent) {
438   if (extent) {
439     return std::move(*extent) + std::move(lower) - ExtentExpr{1};
440   } else {
441     return std::nullopt;
442   }
443 }
444 
445 MaybeExtentExpr ComputeUpperBound(
446     FoldingContext &context, ExtentExpr &&lower, MaybeExtentExpr &&extent) {
447   return Fold(context, ComputeUpperBound(std::move(lower), std::move(extent)));
448 }
449 
450 MaybeExtentExpr GetUpperBound(const NamedEntity &base, int dimension) {
451   const Symbol &symbol{ResolveAssociations(base.GetLastSymbol())};
452   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
453     int j{0};
454     for (const auto &shapeSpec : details->shape()) {
455       if (j++ == dimension) {
456         if (const auto &bound{shapeSpec.ubound().GetExplicit()}) {
457           return *bound;
458         } else if (details->IsAssumedSize() && dimension + 1 == symbol.Rank()) {
459           break;
460         } else {
461           return ComputeUpperBound(
462               GetLowerBound(base, dimension), GetExtent(base, dimension));
463         }
464       }
465     }
466   } else if (const auto *assoc{
467                  symbol.detailsIf<semantics::AssocEntityDetails>()}) {
468     if (auto shape{GetShape(assoc->expr())}) {
469       if (dimension < static_cast<int>(shape->size())) {
470         return ComputeUpperBound(
471             GetLowerBound(base, dimension), std::move(shape->at(dimension)));
472       }
473     }
474   }
475   return std::nullopt;
476 }
477 
478 MaybeExtentExpr GetUpperBound(
479     FoldingContext &context, const NamedEntity &base, int dimension) {
480   return Fold(context, GetUpperBound(base, dimension));
481 }
482 
483 Shape GetUpperBounds(const NamedEntity &base) {
484   const Symbol &symbol{ResolveAssociations(base.GetLastSymbol())};
485   if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
486     Shape result;
487     int dim{0};
488     for (const auto &shapeSpec : details->shape()) {
489       if (const auto &bound{shapeSpec.ubound().GetExplicit()}) {
490         result.push_back(*bound);
491       } else if (details->IsAssumedSize()) {
492         CHECK(dim + 1 == base.Rank());
493         result.emplace_back(std::nullopt); // UBOUND folding replaces with -1
494       } else {
495         result.emplace_back(
496             ComputeUpperBound(GetLowerBound(base, dim), GetExtent(base, dim)));
497       }
498       ++dim;
499     }
500     CHECK(GetRank(result) == symbol.Rank());
501     return result;
502   } else {
503     return std::move(GetShape(symbol).value());
504   }
505 }
506 
507 Shape GetUpperBounds(FoldingContext &context, const NamedEntity &base) {
508   return Fold(context, GetUpperBounds(base));
509 }
510 
511 auto GetShapeHelper::operator()(const Symbol &symbol) const -> Result {
512   return std::visit(
513       common::visitors{
514           [&](const semantics::ObjectEntityDetails &object) {
515             if (IsImpliedShape(symbol) && object.init()) {
516               return (*this)(object.init());
517             } else if (IsAssumedRank(symbol)) {
518               return Result{};
519             } else {
520               int n{object.shape().Rank()};
521               NamedEntity base{symbol};
522               return Result{CreateShape(n, base)};
523             }
524           },
525           [](const semantics::EntityDetails &) {
526             return ScalarShape(); // no dimensions seen
527           },
528           [&](const semantics::ProcEntityDetails &proc) {
529             if (const Symbol * interface{proc.interface().symbol()}) {
530               return (*this)(*interface);
531             } else {
532               return ScalarShape();
533             }
534           },
535           [&](const semantics::AssocEntityDetails &assoc) {
536             if (assoc.rank()) { // SELECT RANK case
537               int n{assoc.rank().value()};
538               NamedEntity base{symbol};
539               return Result{CreateShape(n, base)};
540             } else {
541               return (*this)(assoc.expr());
542             }
543           },
544           [&](const semantics::SubprogramDetails &subp) {
545             if (subp.isFunction()) {
546               return (*this)(subp.result());
547             } else {
548               return Result{};
549             }
550           },
551           [&](const semantics::ProcBindingDetails &binding) {
552             return (*this)(binding.symbol());
553           },
554           [](const semantics::TypeParamDetails &) { return ScalarShape(); },
555           [](const auto &) { return Result{}; },
556       },
557       symbol.GetUltimate().details());
558 }
559 
560 auto GetShapeHelper::operator()(const Component &component) const -> Result {
561   const Symbol &symbol{component.GetLastSymbol()};
562   int rank{symbol.Rank()};
563   if (rank == 0) {
564     return (*this)(component.base());
565   } else if (symbol.has<semantics::ObjectEntityDetails>()) {
566     NamedEntity base{Component{component}};
567     return CreateShape(rank, base);
568   } else if (symbol.has<semantics::AssocEntityDetails>()) {
569     NamedEntity base{Component{component}};
570     return Result{CreateShape(rank, base)};
571   } else {
572     return (*this)(symbol);
573   }
574 }
575 
576 auto GetShapeHelper::operator()(const ArrayRef &arrayRef) const -> Result {
577   Shape shape;
578   int dimension{0};
579   const NamedEntity &base{arrayRef.base()};
580   for (const Subscript &ss : arrayRef.subscript()) {
581     if (ss.Rank() > 0) {
582       shape.emplace_back(GetExtent(ss, base, dimension));
583     }
584     ++dimension;
585   }
586   if (shape.empty()) {
587     if (const Component * component{base.UnwrapComponent()}) {
588       return (*this)(component->base());
589     }
590   }
591   return shape;
592 }
593 
594 auto GetShapeHelper::operator()(const CoarrayRef &coarrayRef) const -> Result {
595   NamedEntity base{coarrayRef.GetBase()};
596   if (coarrayRef.subscript().empty()) {
597     return (*this)(base);
598   } else {
599     Shape shape;
600     int dimension{0};
601     for (const Subscript &ss : coarrayRef.subscript()) {
602       if (ss.Rank() > 0) {
603         shape.emplace_back(GetExtent(ss, base, dimension));
604       }
605       ++dimension;
606     }
607     return shape;
608   }
609 }
610 
611 auto GetShapeHelper::operator()(const Substring &substring) const -> Result {
612   return (*this)(substring.parent());
613 }
614 
615 auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {
616   if (call.Rank() == 0) {
617     return ScalarShape();
618   } else if (call.IsElemental()) {
619     for (const auto &arg : call.arguments()) {
620       if (arg && arg->Rank() > 0) {
621         return (*this)(*arg);
622       }
623     }
624     return ScalarShape();
625   } else if (const Symbol * symbol{call.proc().GetSymbol()}) {
626     return (*this)(*symbol);
627   } else if (const auto *intrinsic{call.proc().GetSpecificIntrinsic()}) {
628     if (intrinsic->name == "shape" || intrinsic->name == "lbound" ||
629         intrinsic->name == "ubound") {
630       // These are the array-valued cases for LBOUND and UBOUND (no DIM=).
631       const auto *expr{call.arguments().front().value().UnwrapExpr()};
632       CHECK(expr);
633       return Shape{MaybeExtentExpr{ExtentExpr{expr->Rank()}}};
634     } else if (intrinsic->name == "all" || intrinsic->name == "any" ||
635         intrinsic->name == "count" || intrinsic->name == "iall" ||
636         intrinsic->name == "iany" || intrinsic->name == "iparity" ||
637         intrinsic->name == "maxval" || intrinsic->name == "minval" ||
638         intrinsic->name == "norm2" || intrinsic->name == "parity" ||
639         intrinsic->name == "product" || intrinsic->name == "sum") {
640       // Reduction with DIM=
641       if (call.arguments().size() >= 2) {
642         auto arrayShape{
643             (*this)(UnwrapExpr<Expr<SomeType>>(call.arguments().at(0)))};
644         const auto *dimArg{UnwrapExpr<Expr<SomeType>>(call.arguments().at(1))};
645         if (arrayShape && dimArg) {
646           if (auto dim{ToInt64(*dimArg)}) {
647             if (*dim >= 1 &&
648                 static_cast<std::size_t>(*dim) <= arrayShape->size()) {
649               arrayShape->erase(arrayShape->begin() + (*dim - 1));
650               return std::move(*arrayShape);
651             }
652           }
653         }
654       }
655     } else if (intrinsic->name == "maxloc" || intrinsic->name == "minloc") {
656       // TODO: FINDLOC
657       if (call.arguments().size() >= 2) {
658         if (auto arrayShape{
659                 (*this)(UnwrapExpr<Expr<SomeType>>(call.arguments().at(0)))}) {
660           auto rank{static_cast<int>(arrayShape->size())};
661           if (const auto *dimArg{
662                   UnwrapExpr<Expr<SomeType>>(call.arguments()[1])}) {
663             auto dim{ToInt64(*dimArg)};
664             if (dim && *dim >= 1 && *dim <= rank) {
665               arrayShape->erase(arrayShape->begin() + (*dim - 1));
666               return std::move(*arrayShape);
667             }
668           } else {
669             // xxxLOC(no DIM=) result is vector(1:RANK(ARRAY=))
670             return Shape{ExtentExpr{rank}};
671           }
672         }
673       }
674     } else if (intrinsic->name == "cshift" || intrinsic->name == "eoshift") {
675       if (!call.arguments().empty()) {
676         return (*this)(call.arguments()[0]);
677       }
678     } else if (intrinsic->name == "matmul") {
679       if (call.arguments().size() == 2) {
680         if (auto ashape{(*this)(call.arguments()[0])}) {
681           if (auto bshape{(*this)(call.arguments()[1])}) {
682             if (ashape->size() == 1 && bshape->size() == 2) {
683               bshape->erase(bshape->begin());
684               return std::move(*bshape); // matmul(vector, matrix)
685             } else if (ashape->size() == 2 && bshape->size() == 1) {
686               ashape->pop_back();
687               return std::move(*ashape); // matmul(matrix, vector)
688             } else if (ashape->size() == 2 && bshape->size() == 2) {
689               (*ashape)[1] = std::move((*bshape)[1]);
690               return std::move(*ashape); // matmul(matrix, matrix)
691             }
692           }
693         }
694       }
695     } else if (intrinsic->name == "reshape") {
696       if (call.arguments().size() >= 2 && call.arguments().at(1)) {
697         // SHAPE(RESHAPE(array,shape)) -> shape
698         if (const auto *shapeExpr{
699                 call.arguments().at(1).value().UnwrapExpr()}) {
700           auto shape{std::get<Expr<SomeInteger>>(shapeExpr->u)};
701           return AsShape(ConvertToType<ExtentType>(std::move(shape)));
702         }
703       }
704     } else if (intrinsic->name == "pack") {
705       if (call.arguments().size() >= 3 && call.arguments().at(2)) {
706         // SHAPE(PACK(,,VECTOR=v)) -> SHAPE(v)
707         return (*this)(call.arguments().at(2));
708       } else if (call.arguments().size() >= 2 && context_) {
709         if (auto maskShape{(*this)(call.arguments().at(1))}) {
710           if (maskShape->size() == 0) {
711             // Scalar MASK= -> [MERGE(SIZE(ARRAY=), 0, mask)]
712             if (auto arrayShape{(*this)(call.arguments().at(0))}) {
713               auto arraySize{GetSize(std::move(*arrayShape))};
714               CHECK(arraySize);
715               ActualArguments toMerge{
716                   ActualArgument{AsGenericExpr(std::move(*arraySize))},
717                   ActualArgument{AsGenericExpr(ExtentExpr{0})},
718                   common::Clone(call.arguments().at(1))};
719               auto specific{context_->intrinsics().Probe(
720                   CallCharacteristics{"merge"}, toMerge, *context_)};
721               CHECK(specific);
722               return Shape{ExtentExpr{FunctionRef<ExtentType>{
723                   ProcedureDesignator{std::move(specific->specificIntrinsic)},
724                   std::move(specific->arguments)}}};
725             }
726           } else {
727             // Non-scalar MASK= -> [COUNT(mask)]
728             ActualArguments toCount{ActualArgument{common::Clone(
729                 DEREF(call.arguments().at(1).value().UnwrapExpr()))}};
730             auto specific{context_->intrinsics().Probe(
731                 CallCharacteristics{"count"}, toCount, *context_)};
732             CHECK(specific);
733             return Shape{ExtentExpr{FunctionRef<ExtentType>{
734                 ProcedureDesignator{std::move(specific->specificIntrinsic)},
735                 std::move(specific->arguments)}}};
736           }
737         }
738       }
739     } else if (intrinsic->name == "spread") {
740       // SHAPE(SPREAD(ARRAY,DIM,NCOPIES)) = SHAPE(ARRAY) with NCOPIES inserted
741       // at position DIM.
742       if (call.arguments().size() == 3) {
743         auto arrayShape{
744             (*this)(UnwrapExpr<Expr<SomeType>>(call.arguments().at(0)))};
745         const auto *dimArg{UnwrapExpr<Expr<SomeType>>(call.arguments().at(1))};
746         const auto *nCopies{
747             UnwrapExpr<Expr<SomeInteger>>(call.arguments().at(2))};
748         if (arrayShape && dimArg && nCopies) {
749           if (auto dim{ToInt64(*dimArg)}) {
750             if (*dim >= 1 &&
751                 static_cast<std::size_t>(*dim) <= arrayShape->size() + 1) {
752               arrayShape->emplace(arrayShape->begin() + *dim - 1,
753                   ConvertToType<ExtentType>(common::Clone(*nCopies)));
754               return std::move(*arrayShape);
755             }
756           }
757         }
758       }
759     } else if (intrinsic->name == "transfer") {
760       if (call.arguments().size() == 3 && call.arguments().at(2)) {
761         // SIZE= is present; shape is vector [SIZE=]
762         if (const auto *size{
763                 UnwrapExpr<Expr<SomeInteger>>(call.arguments().at(2))}) {
764           return Shape{
765               MaybeExtentExpr{ConvertToType<ExtentType>(common::Clone(*size))}};
766         }
767       } else if (context_) {
768         if (auto moldTypeAndShape{characteristics::TypeAndShape::Characterize(
769                 call.arguments().at(1), *context_)}) {
770           if (GetRank(moldTypeAndShape->shape()) == 0) {
771             // SIZE= is absent and MOLD= is scalar: result is scalar
772             return ScalarShape();
773           } else {
774             // SIZE= is absent and MOLD= is array: result is vector whose
775             // length is determined by sizes of types.  See 16.9.193p4 case(ii).
776             if (auto sourceTypeAndShape{
777                     characteristics::TypeAndShape::Characterize(
778                         call.arguments().at(0), *context_)}) {
779               auto sourceBytes{
780                   sourceTypeAndShape->MeasureSizeInBytes(*context_)};
781               auto moldElementBytes{
782                   moldTypeAndShape->MeasureElementSizeInBytes(*context_, true)};
783               if (sourceBytes && moldElementBytes) {
784                 ExtentExpr extent{Fold(*context_,
785                     (std::move(*sourceBytes) +
786                         common::Clone(*moldElementBytes) - ExtentExpr{1}) /
787                         common::Clone(*moldElementBytes))};
788                 return Shape{MaybeExtentExpr{std::move(extent)}};
789               }
790             }
791           }
792         }
793       }
794     } else if (intrinsic->name == "transpose") {
795       if (call.arguments().size() >= 1) {
796         if (auto shape{(*this)(call.arguments().at(0))}) {
797           if (shape->size() == 2) {
798             std::swap((*shape)[0], (*shape)[1]);
799             return shape;
800           }
801         }
802       }
803     } else if (intrinsic->name == "unpack") {
804       if (call.arguments().size() >= 2) {
805         return (*this)(call.arguments()[1]); // MASK=
806       }
807     } else if (intrinsic->characteristics.value().attrs.test(characteristics::
808                        Procedure::Attr::NullPointer)) { // NULL(MOLD=)
809       return (*this)(call.arguments());
810     } else {
811       // TODO: shapes of other non-elemental intrinsic results
812     }
813   }
814   return std::nullopt;
815 }
816 
817 // Check conformance of the passed shapes.
818 std::optional<bool> CheckConformance(parser::ContextualMessages &messages,
819     const Shape &left, const Shape &right, CheckConformanceFlags::Flags flags,
820     const char *leftIs, const char *rightIs) {
821   int n{GetRank(left)};
822   if (n == 0 && (flags & CheckConformanceFlags::LeftScalarExpandable)) {
823     return true;
824   }
825   int rn{GetRank(right)};
826   if (rn == 0 && (flags & CheckConformanceFlags::RightScalarExpandable)) {
827     return true;
828   }
829   if (n != rn) {
830     messages.Say("Rank of %1$s is %2$d, but %3$s has rank %4$d"_err_en_US,
831         leftIs, n, rightIs, rn);
832     return false;
833   }
834   for (int j{0}; j < n; ++j) {
835     if (auto leftDim{ToInt64(left[j])}) {
836       if (auto rightDim{ToInt64(right[j])}) {
837         if (*leftDim != *rightDim) {
838           messages.Say("Dimension %1$d of %2$s has extent %3$jd, "
839                        "but %4$s has extent %5$jd"_err_en_US,
840               j + 1, leftIs, *leftDim, rightIs, *rightDim);
841           return false;
842         }
843       } else if (!(flags & CheckConformanceFlags::RightIsDeferredShape)) {
844         return std::nullopt;
845       }
846     } else if (!(flags & CheckConformanceFlags::LeftIsDeferredShape)) {
847       return std::nullopt;
848     }
849   }
850   return true;
851 }
852 
853 bool IncrementSubscripts(
854     ConstantSubscripts &indices, const ConstantSubscripts &extents) {
855   std::size_t rank(indices.size());
856   CHECK(rank <= extents.size());
857   for (std::size_t j{0}; j < rank; ++j) {
858     if (extents[j] < 1) {
859       return false;
860     }
861   }
862   for (std::size_t j{0}; j < rank; ++j) {
863     if (indices[j]++ < extents[j]) {
864       return true;
865     }
866     indices[j] = 1;
867   }
868   return false;
869 }
870 
871 } // namespace Fortran::evaluate
872