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