xref: /llvm-project/flang/lib/Evaluate/check-expression.cpp (revision 543cd89d3fb5a108d4050635c00093695b2b6c6d) 
1 //===-- lib/Evaluate/check-expression.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/check-expression.h"
10 #include "flang/Evaluate/characteristics.h"
11 #include "flang/Evaluate/intrinsics.h"
12 #include "flang/Evaluate/traverse.h"
13 #include "flang/Evaluate/type.h"
14 #include "flang/Semantics/symbol.h"
15 #include "flang/Semantics/tools.h"
16 #include <set>
17 #include <string>
18 
19 namespace Fortran::evaluate {
20 
21 // Constant expression predicate IsConstantExpr().
22 // This code determines whether an expression is a "constant expression"
23 // in the sense of section 10.1.12.  This is not the same thing as being
24 // able to fold it (yet) into a known constant value; specifically,
25 // the expression may reference derived type kind parameters whose values
26 // are not yet known.
27 class IsConstantExprHelper : public AllTraverse<IsConstantExprHelper, true> {
28 public:
29   using Base = AllTraverse<IsConstantExprHelper, true>;
30   IsConstantExprHelper() : Base{*this} {}
31   using Base::operator();
32 
33   // A missing expression is not considered to be constant.
34   template <typename A> bool operator()(const std::optional<A> &x) const {
35     return x && (*this)(*x);
36   }
37 
38   bool operator()(const TypeParamInquiry &inq) const {
39     return semantics::IsKindTypeParameter(inq.parameter());
40   }
41   bool operator()(const semantics::Symbol &symbol) const {
42     const auto &ultimate{symbol.GetUltimate()};
43     return IsNamedConstant(ultimate) || IsImpliedDoIndex(ultimate) ||
44         IsInitialProcedureTarget(ultimate);
45   }
46   bool operator()(const CoarrayRef &) const { return false; }
47   bool operator()(const semantics::ParamValue &param) const {
48     return param.isExplicit() && (*this)(param.GetExplicit());
49   }
50   bool operator()(const ProcedureRef &) const;
51   bool operator()(const StructureConstructor &constructor) const {
52     for (const auto &[symRef, expr] : constructor) {
53       if (!IsConstantStructureConstructorComponent(*symRef, expr.value())) {
54         return false;
55       }
56     }
57     return true;
58   }
59   bool operator()(const Component &component) const {
60     return (*this)(component.base());
61   }
62   // Forbid integer division by zero in constants.
63   template <int KIND>
64   bool operator()(
65       const Divide<Type<TypeCategory::Integer, KIND>> &division) const {
66     using T = Type<TypeCategory::Integer, KIND>;
67     if (const auto divisor{GetScalarConstantValue<T>(division.right())}) {
68       return !divisor->IsZero() && (*this)(division.left());
69     } else {
70       return false;
71     }
72   }
73 
74   bool operator()(const Constant<SomeDerived> &) const { return true; }
75   bool operator()(const DescriptorInquiry &) const { return false; }
76 
77 private:
78   bool IsConstantStructureConstructorComponent(
79       const Symbol &, const Expr<SomeType> &) const;
80   bool IsConstantExprShape(const Shape &) const;
81 };
82 
83 bool IsConstantExprHelper::IsConstantStructureConstructorComponent(
84     const Symbol &component, const Expr<SomeType> &expr) const {
85   if (IsAllocatable(component)) {
86     return IsNullPointer(expr);
87   } else if (IsPointer(component)) {
88     return IsNullPointer(expr) || IsInitialDataTarget(expr) ||
89         IsInitialProcedureTarget(expr);
90   } else {
91     return (*this)(expr);
92   }
93 }
94 
95 bool IsConstantExprHelper::operator()(const ProcedureRef &call) const {
96   // LBOUND, UBOUND, and SIZE with DIM= arguments will have been reritten
97   // into DescriptorInquiry operations.
98   if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&call.proc().u)}) {
99     if (intrinsic->name == "kind" ||
100         intrinsic->name == IntrinsicProcTable::InvalidName) {
101       // kind is always a constant, and we avoid cascading errors by considering
102       // invalid calls to intrinsics to be constant
103       return true;
104     } else if (intrinsic->name == "lbound" && call.arguments().size() == 1) {
105       // LBOUND(x) without DIM=
106       auto base{ExtractNamedEntity(call.arguments()[0]->UnwrapExpr())};
107       return base && IsConstantExprShape(GetLowerBounds(*base));
108     } else if (intrinsic->name == "ubound" && call.arguments().size() == 1) {
109       // UBOUND(x) without DIM=
110       auto base{ExtractNamedEntity(call.arguments()[0]->UnwrapExpr())};
111       return base && IsConstantExprShape(GetUpperBounds(*base));
112     } else if (intrinsic->name == "shape") {
113       auto shape{GetShape(call.arguments()[0]->UnwrapExpr())};
114       return shape && IsConstantExprShape(*shape);
115     } else if (intrinsic->name == "size" && call.arguments().size() == 1) {
116       // SIZE(x) without DIM
117       auto shape{GetShape(call.arguments()[0]->UnwrapExpr())};
118       return shape && IsConstantExprShape(*shape);
119     }
120     // TODO: STORAGE_SIZE
121   }
122   return false;
123 }
124 
125 bool IsConstantExprHelper::IsConstantExprShape(const Shape &shape) const {
126   for (const auto &extent : shape) {
127     if (!(*this)(extent)) {
128       return false;
129     }
130   }
131   return true;
132 }
133 
134 template <typename A> bool IsConstantExpr(const A &x) {
135   return IsConstantExprHelper{}(x);
136 }
137 template bool IsConstantExpr(const Expr<SomeType> &);
138 template bool IsConstantExpr(const Expr<SomeInteger> &);
139 template bool IsConstantExpr(const Expr<SubscriptInteger> &);
140 template bool IsConstantExpr(const StructureConstructor &);
141 
142 // IsActuallyConstant()
143 struct IsActuallyConstantHelper {
144   template <typename A> bool operator()(const A &) { return false; }
145   template <typename T> bool operator()(const Constant<T> &) { return true; }
146   template <typename T> bool operator()(const Parentheses<T> &x) {
147     return (*this)(x.left());
148   }
149   template <typename T> bool operator()(const Expr<T> &x) {
150     return std::visit([=](const auto &y) { return (*this)(y); }, x.u);
151   }
152   template <typename A> bool operator()(const A *x) { return x && (*this)(*x); }
153   template <typename A> bool operator()(const std::optional<A> &x) {
154     return x && (*this)(*x);
155   }
156 };
157 
158 template <typename A> bool IsActuallyConstant(const A &x) {
159   return IsActuallyConstantHelper{}(x);
160 }
161 
162 template bool IsActuallyConstant(const Expr<SomeType> &);
163 
164 // Object pointer initialization checking predicate IsInitialDataTarget().
165 // This code determines whether an expression is allowable as the static
166 // data address used to initialize a pointer with "=> x".  See C765.
167 class IsInitialDataTargetHelper
168     : public AllTraverse<IsInitialDataTargetHelper, true> {
169 public:
170   using Base = AllTraverse<IsInitialDataTargetHelper, true>;
171   using Base::operator();
172   explicit IsInitialDataTargetHelper(parser::ContextualMessages *m)
173       : Base{*this}, messages_{m} {}
174 
175   bool emittedMessage() const { return emittedMessage_; }
176 
177   bool operator()(const BOZLiteralConstant &) const { return false; }
178   bool operator()(const NullPointer &) const { return true; }
179   template <typename T> bool operator()(const Constant<T> &) const {
180     return false;
181   }
182   bool operator()(const semantics::Symbol &symbol) {
183     const Symbol &ultimate{symbol.GetUltimate()};
184     if (IsAllocatable(ultimate)) {
185       if (messages_) {
186         messages_->Say(
187             "An initial data target may not be a reference to an ALLOCATABLE '%s'"_err_en_US,
188             ultimate.name());
189         emittedMessage_ = true;
190       }
191       return false;
192     } else if (ultimate.Corank() > 0) {
193       if (messages_) {
194         messages_->Say(
195             "An initial data target may not be a reference to a coarray '%s'"_err_en_US,
196             ultimate.name());
197         emittedMessage_ = true;
198       }
199       return false;
200     } else if (!ultimate.attrs().test(semantics::Attr::TARGET)) {
201       if (messages_) {
202         messages_->Say(
203             "An initial data target may not be a reference to an object '%s' that lacks the TARGET attribute"_err_en_US,
204             ultimate.name());
205         emittedMessage_ = true;
206       }
207       return false;
208     } else if (!IsSaved(ultimate)) {
209       if (messages_) {
210         messages_->Say(
211             "An initial data target may not be a reference to an object '%s' that lacks the SAVE attribute"_err_en_US,
212             ultimate.name());
213         emittedMessage_ = true;
214       }
215       return false;
216     }
217     return true;
218   }
219   bool operator()(const StaticDataObject &) const { return false; }
220   bool operator()(const TypeParamInquiry &) const { return false; }
221   bool operator()(const Triplet &x) const {
222     return IsConstantExpr(x.lower()) && IsConstantExpr(x.upper()) &&
223         IsConstantExpr(x.stride());
224   }
225   bool operator()(const Subscript &x) const {
226     return std::visit(common::visitors{
227                           [&](const Triplet &t) { return (*this)(t); },
228                           [&](const auto &y) {
229                             return y.value().Rank() == 0 &&
230                                 IsConstantExpr(y.value());
231                           },
232                       },
233         x.u);
234   }
235   bool operator()(const CoarrayRef &) const { return false; }
236   bool operator()(const Substring &x) const {
237     return IsConstantExpr(x.lower()) && IsConstantExpr(x.upper()) &&
238         (*this)(x.parent());
239   }
240   bool operator()(const DescriptorInquiry &) const { return false; }
241   template <typename T> bool operator()(const ArrayConstructor<T> &) const {
242     return false;
243   }
244   bool operator()(const StructureConstructor &) const { return false; }
245   template <typename T> bool operator()(const FunctionRef<T> &) {
246     return false;
247   }
248   template <typename D, typename R, typename... O>
249   bool operator()(const Operation<D, R, O...> &) const {
250     return false;
251   }
252   template <typename T> bool operator()(const Parentheses<T> &x) const {
253     return (*this)(x.left());
254   }
255   template <typename T> bool operator()(const FunctionRef<T> &x) const {
256     return false;
257   }
258   bool operator()(const Relational<SomeType> &) const { return false; }
259 
260 private:
261   parser::ContextualMessages *messages_;
262   bool emittedMessage_{false};
263 };
264 
265 bool IsInitialDataTarget(
266     const Expr<SomeType> &x, parser::ContextualMessages *messages) {
267   IsInitialDataTargetHelper helper{messages};
268   bool result{helper(x)};
269   if (!result && messages && !helper.emittedMessage()) {
270     messages->Say(
271         "An initial data target must be a designator with constant subscripts"_err_en_US);
272   }
273   return result;
274 }
275 
276 bool IsInitialProcedureTarget(const semantics::Symbol &symbol) {
277   const auto &ultimate{symbol.GetUltimate()};
278   return std::visit(
279       common::visitors{
280           [](const semantics::SubprogramDetails &) { return true; },
281           [](const semantics::SubprogramNameDetails &) { return true; },
282           [&](const semantics::ProcEntityDetails &proc) {
283             return !semantics::IsPointer(ultimate) && !proc.isDummy();
284           },
285           [](const auto &) { return false; },
286       },
287       ultimate.details());
288 }
289 
290 bool IsInitialProcedureTarget(const ProcedureDesignator &proc) {
291   if (const auto *intrin{proc.GetSpecificIntrinsic()}) {
292     return !intrin->isRestrictedSpecific;
293   } else if (proc.GetComponent()) {
294     return false;
295   } else {
296     return IsInitialProcedureTarget(DEREF(proc.GetSymbol()));
297   }
298 }
299 
300 bool IsInitialProcedureTarget(const Expr<SomeType> &expr) {
301   if (const auto *proc{std::get_if<ProcedureDesignator>(&expr.u)}) {
302     return IsInitialProcedureTarget(*proc);
303   } else {
304     return IsNullPointer(expr);
305   }
306 }
307 
308 class ArrayConstantBoundChanger {
309 public:
310   ArrayConstantBoundChanger(ConstantSubscripts &&lbounds)
311       : lbounds_{std::move(lbounds)} {}
312 
313   template <typename A> A ChangeLbounds(A &&x) const {
314     return std::move(x); // default case
315   }
316   template <typename T> Constant<T> ChangeLbounds(Constant<T> &&x) {
317     x.set_lbounds(std::move(lbounds_));
318     return std::move(x);
319   }
320   template <typename T> Expr<T> ChangeLbounds(Parentheses<T> &&x) {
321     return ChangeLbounds(
322         std::move(x.left())); // Constant<> can be parenthesized
323   }
324   template <typename T> Expr<T> ChangeLbounds(Expr<T> &&x) {
325     return std::visit(
326         [&](auto &&x) { return Expr<T>{ChangeLbounds(std::move(x))}; },
327         std::move(x.u)); // recurse until we hit a constant
328   }
329 
330 private:
331   ConstantSubscripts &&lbounds_;
332 };
333 
334 // Converts, folds, and then checks type, rank, and shape of an
335 // initialization expression for a named constant, a non-pointer
336 // variable static initializatio, a component default initializer,
337 // a type parameter default value, or instantiated type parameter value.
338 std::optional<Expr<SomeType>> NonPointerInitializationExpr(const Symbol &symbol,
339     Expr<SomeType> &&x, FoldingContext &context,
340     const semantics::Scope *instantiation) {
341   CHECK(!IsPointer(symbol));
342   if (auto symTS{
343           characteristics::TypeAndShape::Characterize(symbol, context)}) {
344     auto xType{x.GetType()};
345     if (auto converted{ConvertToType(symTS->type(), std::move(x))}) {
346       auto folded{Fold(context, std::move(*converted))};
347       if (IsActuallyConstant(folded)) {
348         int symRank{GetRank(symTS->shape())};
349         if (IsImpliedShape(symbol)) {
350           if (folded.Rank() == symRank) {
351             return {std::move(folded)};
352           } else {
353             context.messages().Say(
354                 "Implied-shape parameter '%s' has rank %d but its initializer has rank %d"_err_en_US,
355                 symbol.name(), symRank, folded.Rank());
356           }
357         } else if (auto extents{AsConstantExtents(context, symTS->shape())}) {
358           if (folded.Rank() == 0 && symRank == 0) {
359             // symbol and constant are both scalars
360             return {std::move(folded)};
361           } else if (folded.Rank() == 0 && symRank > 0) {
362             // expand the scalar constant to an array
363             return ScalarConstantExpander{std::move(*extents),
364                 AsConstantExtents(
365                     context, GetLowerBounds(context, NamedEntity{symbol}))}
366                 .Expand(std::move(folded));
367           } else if (auto resultShape{GetShape(context, folded)}) {
368             if (CheckConformance(context.messages(), symTS->shape(),
369                     *resultShape, "initialized object",
370                     "initialization expression", false, false)) {
371               // make a constant array with adjusted lower bounds
372               return ArrayConstantBoundChanger{
373                   std::move(*AsConstantExtents(
374                       context, GetLowerBounds(context, NamedEntity{symbol})))}
375                   .ChangeLbounds(std::move(folded));
376             }
377           }
378         } else if (IsNamedConstant(symbol)) {
379           if (IsExplicitShape(symbol)) {
380             context.messages().Say(
381                 "Named constant '%s' array must have constant shape"_err_en_US,
382                 symbol.name());
383           } else {
384             // Declaration checking handles other cases
385           }
386         } else {
387           context.messages().Say(
388               "Shape of initialized object '%s' must be constant"_err_en_US,
389               symbol.name());
390         }
391       } else if (IsErrorExpr(folded)) {
392       } else if (IsLenTypeParameter(symbol)) {
393         return {std::move(folded)};
394       } else if (IsKindTypeParameter(symbol)) {
395         if (instantiation) {
396           context.messages().Say(
397               "Value of kind type parameter '%s' (%s) must be a scalar INTEGER constant"_err_en_US,
398               symbol.name(), folded.AsFortran());
399         } else {
400           return {std::move(folded)};
401         }
402       } else if (IsNamedConstant(symbol)) {
403         context.messages().Say(
404             "Value of named constant '%s' (%s) cannot be computed as a constant value"_err_en_US,
405             symbol.name(), folded.AsFortran());
406       } else {
407         context.messages().Say(
408             "Initialization expression for '%s' (%s) cannot be computed as a constant value"_err_en_US,
409             symbol.name(), folded.AsFortran());
410       }
411     } else if (xType) {
412       context.messages().Say(
413           "Initialization expression cannot be converted to declared type of '%s' from %s"_err_en_US,
414           symbol.name(), xType->AsFortran());
415     } else {
416       context.messages().Say(
417           "Initialization expression cannot be converted to declared type of '%s'"_err_en_US,
418           symbol.name());
419     }
420   }
421   return std::nullopt;
422 }
423 
424 // Specification expression validation (10.1.11(2), C1010)
425 class CheckSpecificationExprHelper
426     : public AnyTraverse<CheckSpecificationExprHelper,
427           std::optional<std::string>> {
428 public:
429   using Result = std::optional<std::string>;
430   using Base = AnyTraverse<CheckSpecificationExprHelper, Result>;
431   explicit CheckSpecificationExprHelper(
432       const semantics::Scope &s, FoldingContext &context)
433       : Base{*this}, scope_{s}, context_{context} {}
434   using Base::operator();
435 
436   Result operator()(const ProcedureDesignator &) const {
437     return "dummy procedure argument";
438   }
439   Result operator()(const CoarrayRef &) const { return "coindexed reference"; }
440 
441   Result operator()(const semantics::Symbol &symbol) const {
442     const auto &ultimate{symbol.GetUltimate()};
443     if (semantics::IsNamedConstant(ultimate) || ultimate.owner().IsModule() ||
444         ultimate.owner().IsSubmodule()) {
445       return std::nullopt;
446     } else if (scope_.IsDerivedType() &&
447         IsVariableName(ultimate)) { // C750, C754
448       return "derived type component or type parameter value not allowed to "
449              "reference variable '"s +
450           ultimate.name().ToString() + "'";
451     } else if (IsDummy(ultimate)) {
452       if (ultimate.attrs().test(semantics::Attr::OPTIONAL)) {
453         return "reference to OPTIONAL dummy argument '"s +
454             ultimate.name().ToString() + "'";
455       } else if (ultimate.attrs().test(semantics::Attr::INTENT_OUT)) {
456         return "reference to INTENT(OUT) dummy argument '"s +
457             ultimate.name().ToString() + "'";
458       } else if (ultimate.has<semantics::ObjectEntityDetails>()) {
459         return std::nullopt;
460       } else {
461         return "dummy procedure argument";
462       }
463     } else if (const auto *object{
464                    ultimate.detailsIf<semantics::ObjectEntityDetails>()}) {
465       if (object->commonBlock()) {
466         return std::nullopt;
467       }
468     }
469     for (const semantics::Scope *s{&scope_}; !s->IsGlobal();) {
470       s = &s->parent();
471       if (s == &ultimate.owner()) {
472         return std::nullopt;
473       }
474     }
475     return "reference to local entity '"s + ultimate.name().ToString() + "'";
476   }
477 
478   Result operator()(const Component &x) const {
479     // Don't look at the component symbol.
480     return (*this)(x.base());
481   }
482   Result operator()(const DescriptorInquiry &) const {
483     // Subtle: Uses of SIZE(), LBOUND(), &c. that are valid in specification
484     // expressions will have been converted to expressions over descriptor
485     // inquiries by Fold().
486     return std::nullopt;
487   }
488 
489   Result operator()(const TypeParamInquiry &inq) const {
490     if (scope_.IsDerivedType() && !IsConstantExpr(inq) &&
491         inq.base() /* X%T, not local T */) { // C750, C754
492       return "non-constant reference to a type parameter inquiry not "
493              "allowed for derived type components or type parameter values";
494     }
495     return std::nullopt;
496   }
497 
498   template <typename T> Result operator()(const FunctionRef<T> &x) const {
499     if (const auto *symbol{x.proc().GetSymbol()}) {
500       const Symbol &ultimate{symbol->GetUltimate()};
501       if (!semantics::IsPureProcedure(ultimate)) {
502         return "reference to impure function '"s + ultimate.name().ToString() +
503             "'";
504       }
505       if (semantics::IsStmtFunction(ultimate)) {
506         return "reference to statement function '"s +
507             ultimate.name().ToString() + "'";
508       }
509       if (scope_.IsDerivedType()) { // C750, C754
510         return "reference to function '"s + ultimate.name().ToString() +
511             "' not allowed for derived type components or type parameter"
512             " values";
513       }
514       // TODO: other checks for standard module procedures
515     } else {
516       const SpecificIntrinsic &intrin{DEREF(x.proc().GetSpecificIntrinsic())};
517       if (scope_.IsDerivedType()) { // C750, C754
518         if ((context_.intrinsics().IsIntrinsic(intrin.name) &&
519                 badIntrinsicsForComponents_.find(intrin.name) !=
520                     badIntrinsicsForComponents_.end()) ||
521             IsProhibitedFunction(intrin.name)) {
522           return "reference to intrinsic '"s + intrin.name +
523               "' not allowed for derived type components or type parameter"
524               " values";
525         }
526         if (context_.intrinsics().GetIntrinsicClass(intrin.name) ==
527                 IntrinsicClass::inquiryFunction &&
528             !IsConstantExpr(x)) {
529           return "non-constant reference to inquiry intrinsic '"s +
530               intrin.name +
531               "' not allowed for derived type components or type"
532               " parameter values";
533         }
534       } else if (intrin.name == "present") {
535         return std::nullopt; // no need to check argument(s)
536       }
537       if (IsConstantExpr(x)) {
538         // inquiry functions may not need to check argument(s)
539         return std::nullopt;
540       }
541     }
542     return (*this)(x.arguments());
543   }
544 
545 private:
546   const semantics::Scope &scope_;
547   FoldingContext &context_;
548   const std::set<std::string> badIntrinsicsForComponents_{
549       "allocated", "associated", "extends_type_of", "present", "same_type_as"};
550   static bool IsProhibitedFunction(std::string name) { return false; }
551 };
552 
553 template <typename A>
554 void CheckSpecificationExpr(
555     const A &x, const semantics::Scope &scope, FoldingContext &context) {
556   if (auto why{CheckSpecificationExprHelper{scope, context}(x)}) {
557     context.messages().Say(
558         "Invalid specification expression: %s"_err_en_US, *why);
559   }
560 }
561 
562 template void CheckSpecificationExpr(
563     const Expr<SomeType> &, const semantics::Scope &, FoldingContext &);
564 template void CheckSpecificationExpr(
565     const Expr<SomeInteger> &, const semantics::Scope &, FoldingContext &);
566 template void CheckSpecificationExpr(
567     const Expr<SubscriptInteger> &, const semantics::Scope &, FoldingContext &);
568 template void CheckSpecificationExpr(const std::optional<Expr<SomeType>> &,
569     const semantics::Scope &, FoldingContext &);
570 template void CheckSpecificationExpr(const std::optional<Expr<SomeInteger>> &,
571     const semantics::Scope &, FoldingContext &);
572 template void CheckSpecificationExpr(
573     const std::optional<Expr<SubscriptInteger>> &, const semantics::Scope &,
574     FoldingContext &);
575 
576 // IsSimplyContiguous() -- 9.5.4
577 class IsSimplyContiguousHelper
578     : public AnyTraverse<IsSimplyContiguousHelper, std::optional<bool>> {
579 public:
580   using Result = std::optional<bool>; // tri-state
581   using Base = AnyTraverse<IsSimplyContiguousHelper, Result>;
582   explicit IsSimplyContiguousHelper(FoldingContext &c)
583       : Base{*this}, context_{c} {}
584   using Base::operator();
585 
586   Result operator()(const semantics::Symbol &symbol) const {
587     if (symbol.attrs().test(semantics::Attr::CONTIGUOUS) ||
588         symbol.Rank() == 0) {
589       return true;
590     } else if (semantics::IsPointer(symbol)) {
591       return false;
592     } else if (const auto *details{
593                    symbol.detailsIf<semantics::ObjectEntityDetails>()}) {
594       // N.B. ALLOCATABLEs are deferred shape, not assumed, and
595       // are obviously contiguous.
596       return !details->IsAssumedShape() && !details->IsAssumedRank();
597     } else {
598       return false;
599     }
600   }
601 
602   Result operator()(const ArrayRef &x) const {
603     const auto &symbol{x.GetLastSymbol()};
604     if (!(*this)(symbol)) {
605       return false;
606     } else if (auto rank{CheckSubscripts(x.subscript())}) {
607       // a(:)%b(1,1) is not contiguous; a(1)%b(:,:) is
608       return *rank > 0 || x.Rank() == 0;
609     } else {
610       return false;
611     }
612   }
613   Result operator()(const CoarrayRef &x) const {
614     return CheckSubscripts(x.subscript()).has_value();
615   }
616   Result operator()(const Component &x) const {
617     return x.base().Rank() == 0 && (*this)(x.GetLastSymbol());
618   }
619   Result operator()(const ComplexPart &) const { return false; }
620   Result operator()(const Substring &) const { return false; }
621 
622   template <typename T> Result operator()(const FunctionRef<T> &x) const {
623     if (auto chars{
624             characteristics::Procedure::Characterize(x.proc(), context_)}) {
625       if (chars->functionResult) {
626         const auto &result{*chars->functionResult};
627         return !result.IsProcedurePointer() &&
628             result.attrs.test(characteristics::FunctionResult::Attr::Pointer) &&
629             result.attrs.test(
630                 characteristics::FunctionResult::Attr::Contiguous);
631       }
632     }
633     return false;
634   }
635 
636 private:
637   // If the subscripts can possibly be on a simply-contiguous array reference,
638   // return the rank.
639   static std::optional<int> CheckSubscripts(
640       const std::vector<Subscript> &subscript) {
641     bool anyTriplet{false};
642     int rank{0};
643     for (auto j{subscript.size()}; j-- > 0;) {
644       if (const auto *triplet{std::get_if<Triplet>(&subscript[j].u)}) {
645         if (!triplet->IsStrideOne()) {
646           return std::nullopt;
647         } else if (anyTriplet) {
648           if (triplet->lower() || triplet->upper()) {
649             // all triplets before the last one must be just ":"
650             return std::nullopt;
651           }
652         } else {
653           anyTriplet = true;
654         }
655         ++rank;
656       } else if (anyTriplet || subscript[j].Rank() > 0) {
657         return std::nullopt;
658       }
659     }
660     return rank;
661   }
662 
663   FoldingContext &context_;
664 };
665 
666 template <typename A>
667 bool IsSimplyContiguous(const A &x, FoldingContext &context) {
668   if (IsVariable(x)) {
669     auto known{IsSimplyContiguousHelper{context}(x)};
670     return known && *known;
671   } else {
672     return true; // not a variable
673   }
674 }
675 
676 template bool IsSimplyContiguous(const Expr<SomeType> &, FoldingContext &);
677 
678 // IsErrorExpr()
679 struct IsErrorExprHelper : public AnyTraverse<IsErrorExprHelper, bool> {
680   using Result = bool;
681   using Base = AnyTraverse<IsErrorExprHelper, Result>;
682   IsErrorExprHelper() : Base{*this} {}
683   using Base::operator();
684 
685   bool operator()(const SpecificIntrinsic &x) {
686     return x.name == IntrinsicProcTable::InvalidName;
687   }
688 };
689 
690 template <typename A> bool IsErrorExpr(const A &x) {
691   return IsErrorExprHelper{}(x);
692 }
693 
694 template bool IsErrorExpr(const Expr<SomeType> &);
695 
696 } // namespace Fortran::evaluate
697