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/semantics.h"
20#include "flang/Semantics/symbol.h"
21#include <functional>
22
23using namespace std::placeholders; // _1, _2, &c. for std::bind()
24
25namespace Fortran::evaluate {
26
27FoldingContext &GetFoldingContextFrom(const Symbol &symbol) {
28 return symbol.owner().context().foldingContext();
29}
30
31bool IsImpliedShape(const Symbol &original) {
32 const Symbol &symbol{ResolveAssociations(original)};
33 const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()};
34 return details && symbol.attrs().test(semantics::Attr::PARAMETER) &&
35 details->shape().CanBeImpliedShape();
36}
37
38bool IsExplicitShape(const Symbol &original) {
39 const Symbol &symbol{ResolveAssociations(original)};
40 if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
41 const auto &shape{details->shape()};
42 return shape.Rank() == 0 ||
43 shape.IsExplicitShape(); // true when scalar, too
44 } else {
45 return symbol
46 .has<semantics::AssocEntityDetails>(); // exprs have explicit shape
47 }
48}
49
50Shape GetShapeHelper::ConstantShape(const Constant<ExtentType> &arrayConstant) {
51 CHECK(arrayConstant.Rank() == 1);
52 Shape result;
53 std::size_t dimensions{arrayConstant.size()};
54 for (std::size_t j{0}; j < dimensions; ++j) {
55 Scalar<ExtentType> extent{arrayConstant.values().at(j)};
56 result.emplace_back(MaybeExtentExpr{ExtentExpr{std::move(extent)}});
57 }
58 return result;
59}
60
61auto GetShapeHelper::AsShapeResult(ExtentExpr &&arrayExpr) const -> Result {
62 if (context_) {
63 arrayExpr = Fold(*context_, std::move(arrayExpr));
64 }
65 if (const auto *constArray{UnwrapConstantValue<ExtentType>(arrayExpr)}) {
66 return ConstantShape(*constArray);
67 }
68 if (auto *constructor{UnwrapExpr<ArrayConstructor<ExtentType>>(arrayExpr)}) {
69 Shape result;
70 for (auto &value : *constructor) {
71 auto *expr{std::get_if<ExtentExpr>(&value.u)};
72 if (expr && expr->Rank() == 0) {
73 result.emplace_back(std::move(*expr));
74 } else {
75 return std::nullopt;
76 }
77 }
78 return result;
79 } else {
80 return std::nullopt;
81 }
82}
83
84Shape GetShapeHelper::CreateShape(int rank, NamedEntity &base) const {
85 Shape shape;
86 for (int dimension{0}; dimension < rank; ++dimension) {
87 shape.emplace_back(GetExtent(base, dimension, invariantOnly_));
88 }
89 return shape;
90}
91
92std::optional<ExtentExpr> AsExtentArrayExpr(const Shape &shape) {
93 ArrayConstructorValues<ExtentType> values;
94 for (const auto &dim : shape) {
95 if (dim) {
96 values.Push(common::Clone(*dim));
97 } else {
98 return std::nullopt;
99 }
100 }
101 return ExtentExpr{ArrayConstructor<ExtentType>{std::move(values)}};
102}
103
104std::optional<Constant<ExtentType>> AsConstantShape(
105 FoldingContext &context, const Shape &shape) {
106 if (auto shapeArray{AsExtentArrayExpr(shape)}) {
107 auto folded{Fold(context, std::move(*shapeArray))};
108 if (auto *p{UnwrapConstantValue<ExtentType>(folded)}) {
109 return std::move(*p);
110 }
111 }
112 return std::nullopt;
113}
114
115Constant<SubscriptInteger> AsConstantShape(const ConstantSubscripts &shape) {
116 using IntType = Scalar<SubscriptInteger>;
117 std::vector<IntType> result;
118 for (auto dim : shape) {
119 result.emplace_back(dim);
120 }
121 return {std::move(result), ConstantSubscripts{GetRank(shape)}};
122}
123
124ConstantSubscripts AsConstantExtents(const Constant<ExtentType> &shape) {
125 ConstantSubscripts result;
126 for (const auto &extent : shape.values()) {
127 result.push_back(extent.ToInt64());
128 }
129 return result;
130}
131
132std::optional<ConstantSubscripts> AsConstantExtents(
133 FoldingContext &context, const Shape &shape) {
134 if (auto shapeConstant{AsConstantShape(context, shape)}) {
135 return AsConstantExtents(*shapeConstant);
136 } else {
137 return std::nullopt;
138 }
139}
140
141Shape AsShape(const ConstantSubscripts &shape) {
142 Shape result;
143 for (const auto &extent : shape) {
144 result.emplace_back(ExtentExpr{extent});
145 }
146 return result;
147}
148
149std::optional<Shape> AsShape(const std::optional<ConstantSubscripts> &shape) {
150 if (shape) {
151 return AsShape(*shape);
152 } else {
153 return std::nullopt;
154 }
155}
156
157Shape Fold(FoldingContext &context, Shape &&shape) {
158 for (auto &dim : shape) {
159 dim = Fold(context, std::move(dim));
160 }
161 return std::move(shape);
162}
163
164std::optional<Shape> Fold(
165 FoldingContext &context, std::optional<Shape> &&shape) {
166 if (shape) {
167 return Fold(context, std::move(*shape));
168 } else {
169 return std::nullopt;
170 }
171}
172
173static ExtentExpr ComputeTripCount(
174 ExtentExpr &&lower, ExtentExpr &&upper, ExtentExpr &&stride) {
175 ExtentExpr strideCopy{common::Clone(stride)};
176 ExtentExpr span{
177 (std::move(upper) - std::move(lower) + std::move(strideCopy)) /
178 std::move(stride)};
179 return ExtentExpr{
180 Extremum<ExtentType>{Ordering::Greater, std::move(span), ExtentExpr{0}}};
181}
182
183ExtentExpr CountTrips(
184 ExtentExpr &&lower, ExtentExpr &&upper, ExtentExpr &&stride) {
185 return ComputeTripCount(
186 std::move(lower), std::move(upper), std::move(stride));
187}
188
189ExtentExpr CountTrips(const ExtentExpr &lower, const ExtentExpr &upper,
190 const ExtentExpr &stride) {
191 return ComputeTripCount(
192 common::Clone(lower), common::Clone(upper), common::Clone(stride));
193}
194
195MaybeExtentExpr CountTrips(MaybeExtentExpr &&lower, MaybeExtentExpr &&upper,
196 MaybeExtentExpr &&stride) {
197 std::function<ExtentExpr(ExtentExpr &&, ExtentExpr &&, ExtentExpr &&)> bound{
198 std::bind(ComputeTripCount, _1, _2, _3)};
199 return common::MapOptional(
200 std::move(bound), std::move(lower), std::move(upper), std::move(stride));
201}
202
203MaybeExtentExpr GetSize(Shape &&shape) {
204 ExtentExpr extent{1};
205 for (auto &&dim : std::move(shape)) {
206 if (dim) {
207 extent = std::move(extent) * std::move(*dim);
208 } else {
209 return std::nullopt;
210 }
211 }
212 return extent;
213}
214
215ConstantSubscript GetSize(const ConstantSubscripts &shape) {
216 ConstantSubscript size{1};
217 for (auto dim : shape) {
218 CHECK(dim >= 0);
219 size *= dim;
220 }
221 return size;
222}
223
224bool ContainsAnyImpliedDoIndex(const ExtentExpr &expr) {
225 struct MyVisitor : public AnyTraverse<MyVisitor> {
226 using Base = AnyTraverse<MyVisitor>;
227 MyVisitor() : Base{*this} {}
228 using Base::operator();
229 bool operator()(const ImpliedDoIndex &) { return true; }
230 };
231 return MyVisitor{}(expr);
232}
233
234// Determines lower bound on a dimension. This can be other than 1 only
235// for a reference to a whole array object or component. (See LBOUND, 16.9.109).
236// ASSOCIATE construct entities may require traversal of their referents.
237template <typename RESULT, bool LBOUND_SEMANTICS>
238class GetLowerBoundHelper
239 : public Traverse<GetLowerBoundHelper<RESULT, LBOUND_SEMANTICS>, RESULT> {
240public:
241 using Result = RESULT;
242 using Base = Traverse<GetLowerBoundHelper, RESULT>;
243 using Base::operator();
244 explicit GetLowerBoundHelper(
245 int d, FoldingContext *context, bool invariantOnly)
246 : Base{*this}, dimension_{d}, context_{context},
247 invariantOnly_{invariantOnly} {}
248 static Result Default() { return Result{1}; }
249 static Result Combine(Result &&, Result &&) {
250 // Operator results and array references always have lower bounds == 1
251 return Result{1};
252 }
253
254 Result GetLowerBound(const Symbol &symbol0, NamedEntity &&base) const {
255 const Symbol &symbol{symbol0.GetUltimate()};
256 if (const auto *object{
257 symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
258 int rank{object->shape().Rank()};
259 if (dimension_ < rank) {
260 const semantics::ShapeSpec &shapeSpec{object->shape()[dimension_]};
261 if (shapeSpec.lbound().isExplicit()) {
262 if (const auto &lbound{shapeSpec.lbound().GetExplicit()};
263 lbound && lbound->Rank() == 0) {
264 if constexpr (LBOUND_SEMANTICS) {
265 bool ok{false};
266 auto lbValue{ToInt64(*lbound)};
267 if (dimension_ == rank - 1 &&
268 semantics::IsAssumedSizeArray(symbol)) {
269 // last dimension of assumed-size dummy array: don't worry
270 // about handling an empty dimension
271 ok = !invariantOnly_ || IsScopeInvariantExpr(*lbound);
272 } else if (lbValue.value_or(0) == 1) {
273 // Lower bound is 1, regardless of extent
274 ok = true;
275 } else if (const auto &ubound{shapeSpec.ubound().GetExplicit()};
276 ubound && ubound->Rank() == 0) {
277 // If we can't prove that the dimension is nonempty,
278 // we must be conservative.
279 // TODO: simple symbolic math in expression rewriting to
280 // cope with cases like A(J:J)
281 if (context_) {
282 auto extent{ToInt64(Fold(*context_,
283 ExtentExpr{*ubound} - ExtentExpr{*lbound} +
284 ExtentExpr{1}))};
285 if (extent) {
286 if (extent <= 0) {
287 return Result{1};
288 }
289 ok = true;
290 } else {
291 ok = false;
292 }
293 } else {
294 auto ubValue{ToInt64(*ubound)};
295 if (lbValue && ubValue) {
296 if (*lbValue > *ubValue) {
297 return Result{1};
298 }
299 ok = true;
300 } else {
301 ok = false;
302 }
303 }
304 }
305 return ok ? *lbound : Result{};
306 } else {
307 return *lbound;
308 }
309 } else {
310 return Result{1};
311 }
312 }
313 if (IsDescriptor(symbol)) {
314 return ExtentExpr{DescriptorInquiry{std::move(base),
315 DescriptorInquiry::Field::LowerBound, dimension_}};
316 }
317 }
318 } else if (const auto *assoc{
319 symbol.detailsIf<semantics::AssocEntityDetails>()}) {
320 if (assoc->IsAssumedSize()) { // RANK(*)
321 return Result{1};
322 } else if (assoc->IsAssumedRank()) { // RANK DEFAULT
323 } else if (assoc->rank()) { // RANK(n)
324 const Symbol &resolved{ResolveAssociations(symbol)};
325 if (IsDescriptor(resolved) && dimension_ < *assoc->rank()) {
326 return ExtentExpr{DescriptorInquiry{std::move(base),
327 DescriptorInquiry::Field::LowerBound, dimension_}};
328 }
329 } else {
330 Result exprLowerBound{((*this)(assoc->expr()))};
331 if (IsActuallyConstant(exprLowerBound)) {
332 return std::move(exprLowerBound);
333 } else {
334 // If the lower bound of the associated entity is not resolved to a
335 // constant expression at the time of the association, it is unsafe
336 // to re-evaluate it later in the associate construct. Statements
337 // in between may have modified its operands value.
338 return ExtentExpr{DescriptorInquiry{std::move(base),
339 DescriptorInquiry::Field::LowerBound, dimension_}};
340 }
341 }
342 }
343 if constexpr (LBOUND_SEMANTICS) {
344 return Result{};
345 } else {
346 return Result{1};
347 }
348 }
349
350 Result operator()(const Symbol &symbol) const {
351 return GetLowerBound(symbol, NamedEntity{symbol});
352 }
353
354 Result operator()(const Component &component) const {
355 if (component.base().Rank() == 0) {
356 return GetLowerBound(
357 component.GetLastSymbol(), NamedEntity{common::Clone(component)});
358 }
359 return Result{1};
360 }
361
362 template <typename T> Result operator()(const Expr<T> &expr) const {
363 if (const Symbol * whole{UnwrapWholeSymbolOrComponentDataRef(expr)}) {
364 return (*this)(*whole);
365 } else if constexpr (common::HasMember<Constant<T>, decltype(expr.u)>) {
366 if (const auto *con{std::get_if<Constant<T>>(&expr.u)}) {
367 ConstantSubscripts lb{con->lbounds()};
368 if (dimension_ < GetRank(lb)) {
369 return Result{lb[dimension_]};
370 }
371 } else { // operation
372 return Result{1};
373 }
374 } else {
375 return (*this)(expr.u);
376 }
377 if constexpr (LBOUND_SEMANTICS) {
378 return Result{};
379 } else {
380 return Result{1};
381 }
382 }
383
384private:
385 int dimension_; // zero-based
386 FoldingContext *context_{nullptr};
387 bool invariantOnly_{false};
388};
389
390ExtentExpr GetRawLowerBound(
391 const NamedEntity &base, int dimension, bool invariantOnly) {
392 return GetLowerBoundHelper<ExtentExpr, false>{
393 dimension, nullptr, invariantOnly}(base);
394}
395
396ExtentExpr GetRawLowerBound(FoldingContext &context, const NamedEntity &base,
397 int dimension, bool invariantOnly) {
398 return Fold(context,
399 GetLowerBoundHelper<ExtentExpr, false>{
400 dimension, &context, invariantOnly}(base));
401}
402
403MaybeExtentExpr GetLBOUND(
404 const NamedEntity &base, int dimension, bool invariantOnly) {
405 return GetLowerBoundHelper<MaybeExtentExpr, true>{
406 dimension, nullptr, invariantOnly}(base);
407}
408
409MaybeExtentExpr GetLBOUND(FoldingContext &context, const NamedEntity &base,
410 int dimension, bool invariantOnly) {
411 return Fold(context,
412 GetLowerBoundHelper<MaybeExtentExpr, true>{
413 dimension, &context, invariantOnly}(base));
414}
415
416Shape GetRawLowerBounds(const NamedEntity &base, bool invariantOnly) {
417 Shape result;
418 int rank{base.Rank()};
419 for (int dim{0}; dim < rank; ++dim) {
420 result.emplace_back(GetRawLowerBound(base, dim, invariantOnly));
421 }
422 return result;
423}
424
425Shape GetRawLowerBounds(
426 FoldingContext &context, const NamedEntity &base, bool invariantOnly) {
427 Shape result;
428 int rank{base.Rank()};
429 for (int dim{0}; dim < rank; ++dim) {
430 result.emplace_back(GetRawLowerBound(context, base, dim, invariantOnly));
431 }
432 return result;
433}
434
435Shape GetLBOUNDs(const NamedEntity &base, bool invariantOnly) {
436 Shape result;
437 int rank{base.Rank()};
438 for (int dim{0}; dim < rank; ++dim) {
439 result.emplace_back(GetLBOUND(base, dim, invariantOnly));
440 }
441 return result;
442}
443
444Shape GetLBOUNDs(
445 FoldingContext &context, const NamedEntity &base, bool invariantOnly) {
446 Shape result;
447 int rank{base.Rank()};
448 for (int dim{0}; dim < rank; ++dim) {
449 result.emplace_back(GetLBOUND(context, base, dim, invariantOnly));
450 }
451 return result;
452}
453
454// If the upper and lower bounds are constant, return a constant expression for
455// the extent. In particular, if the upper bound is less than the lower bound,
456// return zero.
457static MaybeExtentExpr GetNonNegativeExtent(
458 const semantics::ShapeSpec &shapeSpec, bool invariantOnly) {
459 const auto &ubound{shapeSpec.ubound().GetExplicit()};
460 const auto &lbound{shapeSpec.lbound().GetExplicit()};
461 std::optional<ConstantSubscript> uval{ToInt64(ubound)};
462 std::optional<ConstantSubscript> lval{ToInt64(lbound)};
463 if (uval && lval) {
464 if (*uval < *lval) {
465 return ExtentExpr{0};
466 } else {
467 return ExtentExpr{*uval - *lval + 1};
468 }
469 } else if (lbound && ubound && lbound->Rank() == 0 && ubound->Rank() == 0 &&
470 (!invariantOnly ||
471 (IsScopeInvariantExpr(*lbound) && IsScopeInvariantExpr(*ubound)))) {
472 // Apply effective IDIM (MAX calculation with 0) so thet the
473 // result is never negative
474 if (lval.value_or(0) == 1) {
475 return ExtentExpr{Extremum<SubscriptInteger>{
476 Ordering::Greater, ExtentExpr{0}, common::Clone(*ubound)}};
477 } else {
478 return ExtentExpr{
479 Extremum<SubscriptInteger>{Ordering::Greater, ExtentExpr{0},
480 common::Clone(*ubound) - common::Clone(*lbound) + ExtentExpr{1}}};
481 }
482 } else {
483 return std::nullopt;
484 }
485}
486
487static MaybeExtentExpr GetAssociatedExtent(
488 const Symbol &symbol, int dimension) {
489 if (const auto *assoc{symbol.detailsIf<semantics::AssocEntityDetails>()};
490 assoc && !assoc->rank()) { // not SELECT RANK case
491 if (auto shape{GetShape(GetFoldingContextFrom(symbol), assoc->expr())};
492 shape && dimension < static_cast<int>(shape->size())) {
493 if (auto &extent{shape->at(dimension)};
494 // Don't return a non-constant extent, as the variables that
495 // determine the shape of the selector's expression may change
496 // during execution of the construct.
497 extent && IsActuallyConstant(*extent)) {
498 return std::move(extent);
499 }
500 }
501 }
502 return ExtentExpr{DescriptorInquiry{
503 NamedEntity{symbol}, DescriptorInquiry::Field::Extent, dimension}};
504}
505
506MaybeExtentExpr GetExtent(
507 const NamedEntity &base, int dimension, bool invariantOnly) {
508 CHECK(dimension >= 0);
509 const Symbol &last{base.GetLastSymbol()};
510 const Symbol &symbol{ResolveAssociations(last)};
511 if (const auto *assoc{last.detailsIf<semantics::AssocEntityDetails>()}) {
512 if (assoc->IsAssumedSize() || assoc->IsAssumedRank()) { // RANK(*)/DEFAULT
513 return std::nullopt;
514 } else if (assoc->rank()) { // RANK(n)
515 if (semantics::IsDescriptor(symbol) && dimension < *assoc->rank()) {
516 return ExtentExpr{DescriptorInquiry{
517 NamedEntity{base}, DescriptorInquiry::Field::Extent, dimension}};
518 } else {
519 return std::nullopt;
520 }
521 } else {
522 return GetAssociatedExtent(last, dimension);
523 }
524 }
525 if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
526 if (IsImpliedShape(symbol) && details->init()) {
527 if (auto shape{
528 GetShape(GetFoldingContextFrom(symbol), symbol, invariantOnly)}) {
529 if (dimension < static_cast<int>(shape->size())) {
530 return std::move(shape->at(dimension));
531 }
532 }
533 } else {
534 int j{0};
535 for (const auto &shapeSpec : details->shape()) {
536 if (j++ == dimension) {
537 if (auto extent{GetNonNegativeExtent(shapeSpec, invariantOnly)}) {
538 return extent;
539 } else if (semantics::IsAssumedSizeArray(symbol) &&
540 j == symbol.Rank()) {
541 break;
542 } else if (semantics::IsDescriptor(symbol)) {
543 return ExtentExpr{DescriptorInquiry{NamedEntity{base},
544 DescriptorInquiry::Field::Extent, dimension}};
545 } else {
546 break;
547 }
548 }
549 }
550 }
551 }
552 return std::nullopt;
553}
554
555MaybeExtentExpr GetExtent(FoldingContext &context, const NamedEntity &base,
556 int dimension, bool invariantOnly) {
557 return Fold(context, GetExtent(base, dimension, invariantOnly));
558}
559
560MaybeExtentExpr GetExtent(const Subscript &subscript, const NamedEntity &base,
561 int dimension, bool invariantOnly) {
562 return common::visit(
563 common::visitors{
564 [&](const Triplet &triplet) -> MaybeExtentExpr {
565 MaybeExtentExpr upper{triplet.upper()};
566 if (!upper) {
567 upper = GetUBOUND(base, dimension, invariantOnly);
568 }
569 MaybeExtentExpr lower{triplet.lower()};
570 if (!lower) {
571 lower = GetLBOUND(base, dimension, invariantOnly);
572 }
573 return CountTrips(std::move(lower), std::move(upper),
574 MaybeExtentExpr{triplet.stride()});
575 },
576 [&](const IndirectSubscriptIntegerExpr &subs) -> MaybeExtentExpr {
577 if (auto shape{GetShape(
578 GetFoldingContextFrom(base.GetLastSymbol()), subs.value())};
579 shape && GetRank(*shape) == 1) {
580 // vector-valued subscript
581 return std::move(shape->at(0));
582 } else {
583 return std::nullopt;
584 }
585 },
586 },
587 subscript.u);
588}
589
590MaybeExtentExpr GetExtent(FoldingContext &context, const Subscript &subscript,
591 const NamedEntity &base, int dimension, bool invariantOnly) {
592 return Fold(context, GetExtent(subscript, base, dimension, invariantOnly));
593}
594
595MaybeExtentExpr ComputeUpperBound(
596 ExtentExpr &&lower, MaybeExtentExpr &&extent) {
597 if (extent) {
598 if (ToInt64(lower).value_or(0) == 1) {
599 return std::move(*extent);
600 } else {
601 return std::move(*extent) + std::move(lower) - ExtentExpr{1};
602 }
603 } else {
604 return std::nullopt;
605 }
606}
607
608MaybeExtentExpr ComputeUpperBound(
609 FoldingContext &context, ExtentExpr &&lower, MaybeExtentExpr &&extent) {
610 return Fold(context, ComputeUpperBound(std::move(lower), std::move(extent)));
611}
612
613MaybeExtentExpr GetRawUpperBound(
614 const NamedEntity &base, int dimension, bool invariantOnly) {
615 const Symbol &symbol{ResolveAssociations(base.GetLastSymbol())};
616 if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
617 int rank{details->shape().Rank()};
618 if (dimension < rank) {
619 const auto &bound{details->shape()[dimension].ubound().GetExplicit()};
620 if (bound && bound->Rank() == 0 &&
621 (!invariantOnly || IsScopeInvariantExpr(*bound))) {
622 return *bound;
623 } else if (semantics::IsAssumedSizeArray(symbol) &&
624 dimension + 1 == symbol.Rank()) {
625 return std::nullopt;
626 } else {
627 return ComputeUpperBound(
628 GetRawLowerBound(base, dimension), GetExtent(base, dimension));
629 }
630 }
631 } else if (const auto *assoc{
632 symbol.detailsIf<semantics::AssocEntityDetails>()}) {
633 if (assoc->IsAssumedSize() || assoc->IsAssumedRank()) {
634 return std::nullopt;
635 } else if (assoc->rank() && dimension >= *assoc->rank()) {
636 return std::nullopt;
637 } else if (auto extent{GetAssociatedExtent(symbol, dimension)}) {
638 return ComputeUpperBound(
639 GetRawLowerBound(base, dimension), std::move(extent));
640 }
641 }
642 return std::nullopt;
643}
644
645MaybeExtentExpr GetRawUpperBound(FoldingContext &context,
646 const NamedEntity &base, int dimension, bool invariantOnly) {
647 return Fold(context, GetRawUpperBound(base, dimension, invariantOnly));
648}
649
650static MaybeExtentExpr GetExplicitUBOUND(FoldingContext *context,
651 const semantics::ShapeSpec &shapeSpec, bool invariantOnly) {
652 const auto &ubound{shapeSpec.ubound().GetExplicit()};
653 if (ubound && ubound->Rank() == 0 &&
654 (!invariantOnly || IsScopeInvariantExpr(*ubound))) {
655 if (auto extent{GetNonNegativeExtent(shapeSpec, invariantOnly)}) {
656 if (auto cstExtent{ToInt64(
657 context ? Fold(*context, std::move(*extent)) : *extent)}) {
658 if (cstExtent > 0) {
659 return *ubound;
660 } else if (cstExtent == 0) {
661 return ExtentExpr{0};
662 }
663 }
664 }
665 }
666 return std::nullopt;
667}
668
669static MaybeExtentExpr GetUBOUND(FoldingContext *context,
670 const NamedEntity &base, int dimension, bool invariantOnly) {
671 const Symbol &symbol{ResolveAssociations(base.GetLastSymbol())};
672 if (const auto *details{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
673 int rank{details->shape().Rank()};
674 if (dimension < rank) {
675 const semantics::ShapeSpec &shapeSpec{details->shape()[dimension]};
676 if (auto ubound{GetExplicitUBOUND(context, shapeSpec, invariantOnly)}) {
677 return *ubound;
678 } else if (semantics::IsAssumedSizeArray(symbol) &&
679 dimension + 1 == symbol.Rank()) {
680 return std::nullopt; // UBOUND() folding replaces with -1
681 } else if (auto lb{GetLBOUND(base, dimension, invariantOnly)}) {
682 return ComputeUpperBound(
683 std::move(*lb), GetExtent(base, dimension, invariantOnly));
684 }
685 }
686 } else if (const auto *assoc{
687 symbol.detailsIf<semantics::AssocEntityDetails>()}) {
688 if (assoc->IsAssumedSize() || assoc->IsAssumedRank()) {
689 return std::nullopt;
690 } else if (assoc->rank()) { // RANK (n)
691 const Symbol &resolved{ResolveAssociations(symbol)};
692 if (IsDescriptor(resolved) && dimension < *assoc->rank()) {
693 ExtentExpr lb{DescriptorInquiry{NamedEntity{base},
694 DescriptorInquiry::Field::LowerBound, dimension}};
695 ExtentExpr extent{DescriptorInquiry{
696 std::move(base), DescriptorInquiry::Field::Extent, dimension}};
697 return ComputeUpperBound(std::move(lb), std::move(extent));
698 }
699 } else if (auto extent{GetAssociatedExtent(symbol, dimension)}) {
700 if (auto lb{GetLBOUND(base, dimension, invariantOnly)}) {
701 return ComputeUpperBound(std::move(*lb), std::move(extent));
702 }
703 }
704 }
705 return std::nullopt;
706}
707
708MaybeExtentExpr GetUBOUND(
709 const NamedEntity &base, int dimension, bool invariantOnly) {
710 return GetUBOUND(nullptr, base, dimension, invariantOnly);
711}
712
713MaybeExtentExpr GetUBOUND(FoldingContext &context, const NamedEntity &base,
714 int dimension, bool invariantOnly) {
715 return Fold(context, GetUBOUND(&context, base, dimension, invariantOnly));
716}
717
718static Shape GetUBOUNDs(
719 FoldingContext *context, const NamedEntity &base, bool invariantOnly) {
720 Shape result;
721 int rank{base.Rank()};
722 for (int dim{0}; dim < rank; ++dim) {
723 result.emplace_back(GetUBOUND(context, base, dim, invariantOnly));
724 }
725 return result;
726}
727
728Shape GetUBOUNDs(
729 FoldingContext &context, const NamedEntity &base, bool invariantOnly) {
730 return Fold(context, GetUBOUNDs(&context, base, invariantOnly));
731}
732
733Shape GetUBOUNDs(const NamedEntity &base, bool invariantOnly) {
734 return GetUBOUNDs(nullptr, base, invariantOnly);
735}
736
737MaybeExtentExpr GetLCOBOUND(
738 const Symbol &symbol0, int dimension, bool invariantOnly) {
739 const Symbol &symbol{ResolveAssociations(symbol0)};
740 if (const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
741 int corank{object->coshape().Rank()};
742 if (dimension < corank) {
743 const semantics::ShapeSpec &shapeSpec{object->coshape()[dimension]};
744 if (const auto &lcobound{shapeSpec.lbound().GetExplicit()}) {
745 if (lcobound->Rank() == 0 &&
746 (!invariantOnly || IsScopeInvariantExpr(*lcobound))) {
747 return *lcobound;
748 }
749 }
750 }
751 }
752 return std::nullopt;
753}
754
755MaybeExtentExpr GetUCOBOUND(
756 const Symbol &symbol0, int dimension, bool invariantOnly) {
757 const Symbol &symbol{ResolveAssociations(symbol0)};
758 if (const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
759 int corank{object->coshape().Rank()};
760 if (dimension < corank - 1) {
761 const semantics::ShapeSpec &shapeSpec{object->coshape()[dimension]};
762 if (const auto ucobound{shapeSpec.ubound().GetExplicit()}) {
763 if (ucobound->Rank() == 0 &&
764 (!invariantOnly || IsScopeInvariantExpr(*ucobound))) {
765 return *ucobound;
766 }
767 }
768 }
769 }
770 return std::nullopt;
771}
772
773Shape GetLCOBOUNDs(const Symbol &symbol, bool invariantOnly) {
774 Shape result;
775 int corank{symbol.Corank()};
776 for (int dim{0}; dim < corank; ++dim) {
777 result.emplace_back(GetLCOBOUND(symbol, dim, invariantOnly));
778 }
779 return result;
780}
781
782Shape GetUCOBOUNDs(const Symbol &symbol, bool invariantOnly) {
783 Shape result;
784 int corank{symbol.Corank()};
785 for (int dim{0}; dim < corank; ++dim) {
786 result.emplace_back(GetUCOBOUND(symbol, dim, invariantOnly));
787 }
788 return result;
789}
790
791auto GetShapeHelper::operator()(const Symbol &symbol) const -> Result {
792 return common::visit(
793 common::visitors{
794 [&](const semantics::ObjectEntityDetails &object) {
795 if (IsImpliedShape(symbol) && object.init()) {
796 return (*this)(object.init());
797 } else if (IsAssumedRank(symbol)) {
798 return Result{};
799 } else {
800 int n{object.shape().Rank()};
801 NamedEntity base{symbol};
802 return Result{CreateShape(n, base)};
803 }
804 },
805 [](const semantics::EntityDetails &) {
806 return ScalarShape(); // no dimensions seen
807 },
808 [&](const semantics::ProcEntityDetails &proc) {
809 if (const Symbol * interface{proc.procInterface()}) {
810 return (*this)(*interface);
811 } else {
812 return ScalarShape();
813 }
814 },
815 [&](const semantics::AssocEntityDetails &assoc) {
816 NamedEntity base{symbol};
817 if (assoc.rank()) { // SELECT RANK case
818 int n{assoc.rank().value()};
819 return Result{CreateShape(n, base)};
820 } else {
821 auto exprShape{((*this)(assoc.expr()))};
822 if (exprShape) {
823 int rank{static_cast<int>(exprShape->size())};
824 for (int dimension{0}; dimension < rank; ++dimension) {
825 auto &extent{(*exprShape)[dimension]};
826 if (extent && !IsActuallyConstant(*extent)) {
827 extent = GetExtent(base, dimension);
828 }
829 }
830 }
831 return exprShape;
832 }
833 },
834 [&](const semantics::SubprogramDetails &subp) -> Result {
835 if (subp.isFunction()) {
836 auto resultShape{(*this)(subp.result())};
837 if (resultShape && !useResultSymbolShape_) {
838 // Ensure the shape is constant. Otherwise, it may be reerring
839 // to symbols that belong to the function's scope and are
840 // meaningless on the caller side without the related call
841 // expression.
842 for (auto &extent : *resultShape) {
843 if (extent && !IsActuallyConstant(*extent)) {
844 extent.reset();
845 }
846 }
847 }
848 return resultShape;
849 } else {
850 return Result{};
851 }
852 },
853 [&](const semantics::ProcBindingDetails &binding) {
854 return (*this)(binding.symbol());
855 },
856 [](const semantics::TypeParamDetails &) { return ScalarShape(); },
857 [](const auto &) { return Result{}; },
858 },
859 symbol.GetUltimate().details());
860}
861
862auto GetShapeHelper::operator()(const Component &component) const -> Result {
863 const Symbol &symbol{component.GetLastSymbol()};
864 int rank{symbol.Rank()};
865 if (rank == 0) {
866 return (*this)(component.base());
867 } else if (symbol.has<semantics::ObjectEntityDetails>()) {
868 NamedEntity base{Component{component}};
869 return CreateShape(rank, base);
870 } else {
871 return (*this)(symbol);
872 }
873}
874
875auto GetShapeHelper::operator()(const ArrayRef &arrayRef) const -> Result {
876 Shape shape;
877 int dimension{0};
878 const NamedEntity &base{arrayRef.base()};
879 for (const Subscript &ss : arrayRef.subscript()) {
880 if (ss.Rank() > 0) {
881 shape.emplace_back(GetExtent(ss, base, dimension));
882 }
883 ++dimension;
884 }
885 if (shape.empty()) {
886 if (const Component * component{base.UnwrapComponent()}) {
887 return (*this)(component->base());
888 }
889 }
890 return shape;
891}
892
893auto GetShapeHelper::operator()(const CoarrayRef &coarrayRef) const -> Result {
894 return (*this)(coarrayRef.base());
895}
896
897auto GetShapeHelper::operator()(const Substring &substring) const -> Result {
898 return (*this)(substring.parent());
899}
900
901auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {
902 if (call.Rank() == 0) {
903 return ScalarShape();
904 } else if (call.IsElemental()) {
905 // Use the shape of an actual array argument associated with a
906 // non-OPTIONAL dummy object argument.
907 if (context_) {
908 if (auto chars{characteristics::Procedure::FromActuals(
909 call.proc(), call.arguments(), *context_)}) {
910 std::size_t j{0};
911 const ActualArgument *nonOptionalArrayArg{nullptr};
912 int anyArrayArgRank{0};
913 for (const auto &arg : call.arguments()) {
914 if (arg && arg->Rank() > 0 && j < chars->dummyArguments.size()) {
915 if (!anyArrayArgRank) {
916 anyArrayArgRank = arg->Rank();
917 } else if (arg->Rank() != anyArrayArgRank) {
918 return std::nullopt; // error recovery
919 }
920 if (!nonOptionalArrayArg &&
921 !chars->dummyArguments[j].IsOptional()) {
922 nonOptionalArrayArg = &*arg;
923 }
924 }
925 ++j;
926 }
927 if (anyArrayArgRank) {
928 if (nonOptionalArrayArg) {
929 return (*this)(*nonOptionalArrayArg);
930 } else {
931 // All dummy array arguments of the procedure are OPTIONAL.
932 // We cannot take the shape from just any array argument,
933 // because all of them might be OPTIONAL dummy arguments
934 // of the caller. Return unknown shape ranked according
935 // to the last actual array argument.
936 return Shape(anyArrayArgRank, MaybeExtentExpr{});
937 }
938 }
939 }
940 }
941 return ScalarShape();
942 } else if (const Symbol * symbol{call.proc().GetSymbol()}) {
943 auto restorer{common::ScopedSet(useResultSymbolShape_, false)};
944 return (*this)(*symbol);
945 } else if (const auto *intrinsic{call.proc().GetSpecificIntrinsic()}) {
946 if (intrinsic->name == "shape" || intrinsic->name == "lbound" ||
947 intrinsic->name == "ubound") {
948 // For LBOUND/UBOUND, these are the array-valued cases (no DIM=)
949 if (!call.arguments().empty() && call.arguments().front()) {
950 if (IsAssumedRank(*call.arguments().front())) {
951 return Shape{MaybeExtentExpr{}};
952 } else {
953 return Shape{
954 MaybeExtentExpr{ExtentExpr{call.arguments().front()->Rank()}}};
955 }
956 }
957 } else if (intrinsic->name == "all" || intrinsic->name == "any" ||
958 intrinsic->name == "count" || intrinsic->name == "iall" ||
959 intrinsic->name == "iany" || intrinsic->name == "iparity" ||
960 intrinsic->name == "maxval" || intrinsic->name == "minval" ||
961 intrinsic->name == "norm2" || intrinsic->name == "parity" ||
962 intrinsic->name == "product" || intrinsic->name == "sum") {
963 // Reduction with DIM=
964 if (call.arguments().size() >= 2) {
965 auto arrayShape{
966 (*this)(UnwrapExpr<Expr<SomeType>>(call.arguments().at(0)))};
967 const auto *dimArg{UnwrapExpr<Expr<SomeType>>(call.arguments().at(1))};
968 if (arrayShape && dimArg) {
969 if (auto dim{ToInt64(*dimArg)}) {
970 if (*dim >= 1 &&
971 static_cast<std::size_t>(*dim) <= arrayShape->size()) {
972 arrayShape->erase(arrayShape->begin() + (*dim - 1));
973 return std::move(*arrayShape);
974 }
975 }
976 }
977 }
978 } else if (intrinsic->name == "findloc" || intrinsic->name == "maxloc" ||
979 intrinsic->name == "minloc") {
980 std::size_t dimIndex{intrinsic->name == "findloc" ? 2u : 1u};
981 if (call.arguments().size() > dimIndex) {
982 if (auto arrayShape{
983 (*this)(UnwrapExpr<Expr<SomeType>>(call.arguments().at(0)))}) {
984 auto rank{static_cast<int>(arrayShape->size())};
985 if (const auto *dimArg{
986 UnwrapExpr<Expr<SomeType>>(call.arguments()[dimIndex])}) {
987 auto dim{ToInt64(*dimArg)};
988 if (dim && *dim >= 1 && *dim <= rank) {
989 arrayShape->erase(arrayShape->begin() + (*dim - 1));
990 return std::move(*arrayShape);
991 }
992 } else {
993 // xxxLOC(no DIM=) result is vector(1:RANK(ARRAY=))
994 return Shape{ExtentExpr{rank}};
995 }
996 }
997 }
998 } else if (intrinsic->name == "cshift" || intrinsic->name == "eoshift") {
999 if (!call.arguments().empty()) {
1000 return (*this)(call.arguments()[0]);
1001 }
1002 } else if (intrinsic->name == "lcobound" || intrinsic->name == "ucobound") {
1003 if (call.arguments().size() == 3 && !call.arguments().at(1).has_value()) {
1004 return Shape(1, ExtentExpr{GetCorank(call.arguments().at(0))});
1005 }
1006 } else if (intrinsic->name == "matmul") {
1007 if (call.arguments().size() == 2) {
1008 if (auto ashape{(*this)(call.arguments()[0])}) {
1009 if (auto bshape{(*this)(call.arguments()[1])}) {
1010 if (ashape->size() == 1 && bshape->size() == 2) {
1011 bshape->erase(bshape->begin());
1012 return std::move(*bshape); // matmul(vector, matrix)
1013 } else if (ashape->size() == 2 && bshape->size() == 1) {
1014 ashape->pop_back();
1015 return std::move(*ashape); // matmul(matrix, vector)
1016 } else if (ashape->size() == 2 && bshape->size() == 2) {
1017 (*ashape)[1] = std::move((*bshape)[1]);
1018 return std::move(*ashape); // matmul(matrix, matrix)
1019 }
1020 }
1021 }
1022 }
1023 } else if (intrinsic->name == "pack") {
1024 if (call.arguments().size() >= 3 && call.arguments().at(2)) {
1025 // SHAPE(PACK(,,VECTOR=v)) -> SHAPE(v)
1026 return (*this)(call.arguments().at(2));
1027 } else if (call.arguments().size() >= 2 && context_) {
1028 if (auto maskShape{(*this)(call.arguments().at(1))}) {
1029 if (maskShape->size() == 0) {
1030 // Scalar MASK= -> [MERGE(SIZE(ARRAY=), 0, mask)]
1031 if (auto arrayShape{(*this)(call.arguments().at(0))}) {
1032 if (auto arraySize{GetSize(std::move(*arrayShape))}) {
1033 ActualArguments toMerge{
1034 ActualArgument{AsGenericExpr(std::move(*arraySize))},
1035 ActualArgument{AsGenericExpr(ExtentExpr{0})},
1036 common::Clone(call.arguments().at(1))};
1037 auto specific{context_->intrinsics().Probe(
1038 CallCharacteristics{"merge"}, toMerge, *context_)};
1039 CHECK(specific);
1040 return Shape{ExtentExpr{FunctionRef<ExtentType>{
1041 ProcedureDesignator{std::move(specific->specificIntrinsic)},
1042 std::move(specific->arguments)}}};
1043 }
1044 }
1045 } else {
1046 // Non-scalar MASK= -> [COUNT(mask, KIND=extent_kind)]
1047 ActualArgument kindArg{
1048 AsGenericExpr(Constant<ExtentType>{ExtentType::kind})};
1049 kindArg.set_keyword(context_->SaveTempName("kind"));
1050 ActualArguments toCount{
1051 ActualArgument{common::Clone(
1052 DEREF(call.arguments().at(1).value().UnwrapExpr()))},
1053 std::move(kindArg)};
1054 auto specific{context_->intrinsics().Probe(
1055 CallCharacteristics{"count"}, toCount, *context_)};
1056 CHECK(specific);
1057 return Shape{ExtentExpr{FunctionRef<ExtentType>{
1058 ProcedureDesignator{std::move(specific->specificIntrinsic)},
1059 std::move(specific->arguments)}}};
1060 }
1061 }
1062 }
1063 } else if (intrinsic->name == "reshape") {
1064 if (call.arguments().size() >= 2 && call.arguments().at(1)) {
1065 // SHAPE(RESHAPE(array,shape)) -> shape
1066 if (const auto *shapeExpr{
1067 call.arguments().at(1).value().UnwrapExpr()}) {
1068 auto shapeArg{std::get<Expr<SomeInteger>>(shapeExpr->u)};
1069 if (auto result{AsShapeResult(
1070 ConvertToType<ExtentType>(std::move(shapeArg)))}) {
1071 return result;
1072 }
1073 }
1074 }
1075 } else if (intrinsic->name == "spread") {
1076 // SHAPE(SPREAD(ARRAY,DIM,NCOPIES)) = SHAPE(ARRAY) with MAX(0,NCOPIES)
1077 // inserted at position DIM.
1078 if (call.arguments().size() == 3) {
1079 auto arrayShape{
1080 (*this)(UnwrapExpr<Expr<SomeType>>(call.arguments().at(0)))};
1081 const auto *dimArg{UnwrapExpr<Expr<SomeType>>(call.arguments().at(1))};
1082 const auto *nCopies{
1083 UnwrapExpr<Expr<SomeInteger>>(call.arguments().at(2))};
1084 if (arrayShape && dimArg && nCopies) {
1085 if (auto dim{ToInt64(*dimArg)}) {
1086 if (*dim >= 1 &&
1087 static_cast<std::size_t>(*dim) <= arrayShape->size() + 1) {
1088 arrayShape->emplace(arrayShape->begin() + *dim - 1,
1089 Extremum<SubscriptInteger>{Ordering::Greater, ExtentExpr{0},
1090 ConvertToType<ExtentType>(common::Clone(*nCopies))});
1091 return std::move(*arrayShape);
1092 }
1093 }
1094 }
1095 }
1096 } else if (intrinsic->name == "transfer") {
1097 if (call.arguments().size() == 3 && call.arguments().at(2)) {
1098 // SIZE= is present; shape is vector [SIZE=]
1099 if (const auto *size{
1100 UnwrapExpr<Expr<SomeInteger>>(call.arguments().at(2))}) {
1101 return Shape{
1102 MaybeExtentExpr{ConvertToType<ExtentType>(common::Clone(*size))}};
1103 }
1104 } else if (context_) {
1105 if (auto moldTypeAndShape{characteristics::TypeAndShape::Characterize(
1106 call.arguments().at(1), *context_)}) {
1107 if (moldTypeAndShape->Rank() == 0) {
1108 // SIZE= is absent and MOLD= is scalar: result is scalar
1109 return ScalarShape();
1110 } else {
1111 // SIZE= is absent and MOLD= is array: result is vector whose
1112 // length is determined by sizes of types. See 16.9.193p4 case(ii).
1113 // Note that if sourceBytes is not known to be empty, we
1114 // can fold only when moldElementBytes is known to not be zero;
1115 // the most general case risks a division by zero otherwise.
1116 if (auto sourceTypeAndShape{
1117 characteristics::TypeAndShape::Characterize(
1118 call.arguments().at(0), *context_)}) {
1119 if (auto sourceBytes{
1120 sourceTypeAndShape->MeasureSizeInBytes(*context_)}) {
1121 *sourceBytes = Fold(*context_, std::move(*sourceBytes));
1122 if (auto sourceBytesConst{ToInt64(*sourceBytes)}) {
1123 if (*sourceBytesConst == 0) {
1124 return Shape{ExtentExpr{0}};
1125 }
1126 }
1127 if (auto moldElementBytes{
1128 moldTypeAndShape->MeasureElementSizeInBytes(
1129 *context_, true)}) {
1130 *moldElementBytes =
1131 Fold(*context_, std::move(*moldElementBytes));
1132 auto moldElementBytesConst{ToInt64(*moldElementBytes)};
1133 if (moldElementBytesConst && *moldElementBytesConst != 0) {
1134 ExtentExpr extent{Fold(*context_,
1135 (std::move(*sourceBytes) +
1136 common::Clone(*moldElementBytes) - ExtentExpr{1}) /
1137 common::Clone(*moldElementBytes))};
1138 return Shape{MaybeExtentExpr{std::move(extent)}};
1139 }
1140 }
1141 }
1142 }
1143 }
1144 }
1145 }
1146 } else if (intrinsic->name == "this_image") {
1147 if (call.arguments().size() == 2) {
1148 // THIS_IMAGE(coarray, no DIM, [TEAM])
1149 return Shape(1, ExtentExpr{GetCorank(call.arguments().at(0))});
1150 }
1151 } else if (intrinsic->name == "transpose") {
1152 if (call.arguments().size() >= 1) {
1153 if (auto shape{(*this)(call.arguments().at(0))}) {
1154 if (shape->size() == 2) {
1155 std::swap((*shape)[0], (*shape)[1]);
1156 return shape;
1157 }
1158 }
1159 }
1160 } else if (intrinsic->name == "unpack") {
1161 if (call.arguments().size() >= 2) {
1162 return (*this)(call.arguments()[1]); // MASK=
1163 }
1164 } else if (intrinsic->characteristics.value().attrs.test(
1165 characteristics::Procedure::Attr::NullPointer) ||
1166 intrinsic->characteristics.value().attrs.test(
1167 characteristics::Procedure::Attr::NullAllocatable)) { // NULL(MOLD=)
1168 return (*this)(call.arguments());
1169 } else {
1170 // TODO: shapes of other non-elemental intrinsic results
1171 }
1172 }
1173 // The rank is always known even if the extents are not.
1174 return Shape(static_cast<std::size_t>(call.Rank()), MaybeExtentExpr{});
1175}
1176
1177void GetShapeHelper::AccumulateExtent(
1178 ExtentExpr &result, ExtentExpr &&n) const {
1179 result = std::move(result) + std::move(n);
1180 if (context_) {
1181 // Fold during expression creation to avoid creating an expression so
1182 // large we can't evaluate it without overflowing the stack.
1183 result = Fold(*context_, std::move(result));
1184 }
1185}
1186
1187// Check conformance of the passed shapes.
1188std::optional<bool> CheckConformance(parser::ContextualMessages &messages,
1189 const Shape &left, const Shape &right, CheckConformanceFlags::Flags flags,
1190 const char *leftIs, const char *rightIs) {
1191 int n{GetRank(left)};
1192 if (n == 0 && (flags & CheckConformanceFlags::LeftScalarExpandable)) {
1193 return true;
1194 }
1195 int rn{GetRank(right)};
1196 if (rn == 0 && (flags & CheckConformanceFlags::RightScalarExpandable)) {
1197 return true;
1198 }
1199 if (n != rn) {
1200 messages.Say("Rank of %1$s is %2$d, but %3$s has rank %4$d"_err_en_US,
1201 leftIs, n, rightIs, rn);
1202 return false;
1203 }
1204 for (int j{0}; j < n; ++j) {
1205 if (auto leftDim{ToInt64(left[j])}) {
1206 if (auto rightDim{ToInt64(right[j])}) {
1207 if (*leftDim != *rightDim) {
1208 messages.Say("Dimension %1$d of %2$s has extent %3$jd, "
1209 "but %4$s has extent %5$jd"_err_en_US,
1210 j + 1, leftIs, *leftDim, rightIs, *rightDim);
1211 return false;
1212 }
1213 } else if (!(flags & CheckConformanceFlags::RightIsDeferredShape)) {
1214 return std::nullopt;
1215 }
1216 } else if (!(flags & CheckConformanceFlags::LeftIsDeferredShape)) {
1217 return std::nullopt;
1218 }
1219 }
1220 return true;
1221}
1222
1223bool IncrementSubscripts(
1224 ConstantSubscripts &indices, const ConstantSubscripts &extents) {
1225 std::size_t rank(indices.size());
1226 CHECK(rank <= extents.size());
1227 for (std::size_t j{0}; j < rank; ++j) {
1228 if (extents[j] < 1) {
1229 return false;
1230 }
1231 }
1232 for (std::size_t j{0}; j < rank; ++j) {
1233 if (indices[j]++ < extents[j]) {
1234 return true;
1235 }
1236 indices[j] = 1;
1237 }
1238 return false;
1239}
1240
1241} // namespace Fortran::evaluate
1242

source code of flang/lib/Evaluate/shape.cpp