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