xref: /llvm-project/flang/lib/Evaluate/check-expression.cpp (revision 51a2ac645f4efde053175e7cc8f7882d1ea0e14d) 
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/tools.h"
13 #include "flang/Evaluate/traverse.h"
14 #include "flang/Evaluate/type.h"
15 #include "flang/Semantics/symbol.h"
16 #include "flang/Semantics/tools.h"
17 #include <set>
18 #include <string>
19 
20 namespace Fortran::evaluate {
21 
22 // Constant expression predicates IsConstantExpr() & IsScopeInvariantExpr().
23 // This code determines whether an expression is a "constant expression"
24 // in the sense of section 10.1.12.  This is not the same thing as being
25 // able to fold it (yet) into a known constant value; specifically,
26 // the expression may reference derived type kind parameters whose values
27 // are not yet known.
28 //
29 // The variant form (IsScopeInvariantExpr()) also accepts symbols that are
30 // INTENT(IN) dummy arguments without the VALUE attribute.
31 template <bool INVARIANT>
32 class IsConstantExprHelper
33     : public AllTraverse<IsConstantExprHelper<INVARIANT>, true> {
34 public:
35   using Base = AllTraverse<IsConstantExprHelper, true>;
36   IsConstantExprHelper() : Base{*this} {}
37   using Base::operator();
38 
39   // A missing expression is not considered to be constant.
40   template <typename A> bool operator()(const std::optional<A> &x) const {
41     return x && (*this)(*x);
42   }
43 
44   bool operator()(const TypeParamInquiry &inq) const {
45     return INVARIANT || semantics::IsKindTypeParameter(inq.parameter());
46   }
47   bool operator()(const semantics::Symbol &symbol) const {
48     const auto &ultimate{GetAssociationRoot(symbol)};
49     return IsNamedConstant(ultimate) || IsImpliedDoIndex(ultimate) ||
50         IsInitialProcedureTarget(ultimate) ||
51         ultimate.has<semantics::TypeParamDetails>() ||
52         (INVARIANT && IsIntentIn(symbol) && !IsOptional(symbol) &&
53             !symbol.attrs().test(semantics::Attr::VALUE));
54   }
55   bool operator()(const CoarrayRef &) const { return false; }
56   bool operator()(const semantics::ParamValue &param) const {
57     return param.isExplicit() && (*this)(param.GetExplicit());
58   }
59   bool operator()(const ProcedureRef &) const;
60   bool operator()(const StructureConstructor &constructor) const {
61     for (const auto &[symRef, expr] : constructor) {
62       if (!IsConstantStructureConstructorComponent(*symRef, expr.value())) {
63         return false;
64       }
65     }
66     return true;
67   }
68   bool operator()(const Component &component) const {
69     return (*this)(component.base());
70   }
71   // Forbid integer division by zero in constants.
72   template <int KIND>
73   bool operator()(
74       const Divide<Type<TypeCategory::Integer, KIND>> &division) const {
75     using T = Type<TypeCategory::Integer, KIND>;
76     if (const auto divisor{GetScalarConstantValue<T>(division.right())}) {
77       return !divisor->IsZero() && (*this)(division.left());
78     } else {
79       return false;
80     }
81   }
82 
83   bool operator()(const Constant<SomeDerived> &) const { return true; }
84   bool operator()(const DescriptorInquiry &x) const {
85     const Symbol &sym{x.base().GetLastSymbol()};
86     return INVARIANT && !IsAllocatable(sym) &&
87         (!IsDummy(sym) ||
88             (IsIntentIn(sym) && !IsOptional(sym) &&
89                 !sym.attrs().test(semantics::Attr::VALUE)));
90   }
91 
92 private:
93   bool IsConstantStructureConstructorComponent(
94       const Symbol &, const Expr<SomeType> &) const;
95   bool IsConstantExprShape(const Shape &) const;
96 };
97 
98 template <bool INVARIANT>
99 bool IsConstantExprHelper<INVARIANT>::IsConstantStructureConstructorComponent(
100     const Symbol &component, const Expr<SomeType> &expr) const {
101   if (IsAllocatable(component)) {
102     return IsNullObjectPointer(expr);
103   } else if (IsPointer(component)) {
104     return IsNullPointer(expr) || IsInitialDataTarget(expr) ||
105         IsInitialProcedureTarget(expr);
106   } else {
107     return (*this)(expr);
108   }
109 }
110 
111 template <bool INVARIANT>
112 bool IsConstantExprHelper<INVARIANT>::operator()(
113     const ProcedureRef &call) const {
114   // LBOUND, UBOUND, and SIZE with truly constant DIM= arguments will have
115   // been rewritten into DescriptorInquiry operations.
116   if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&call.proc().u)}) {
117     const characteristics::Procedure &proc{intrinsic->characteristics.value()};
118     if (intrinsic->name == "kind" ||
119         intrinsic->name == IntrinsicProcTable::InvalidName ||
120         call.arguments().empty() || !call.arguments()[0]) {
121       // kind is always a constant, and we avoid cascading errors by considering
122       // invalid calls to intrinsics to be constant
123       return true;
124     } else if (intrinsic->name == "lbound") {
125       auto base{ExtractNamedEntity(call.arguments()[0]->UnwrapExpr())};
126       return base && IsConstantExprShape(GetLBOUNDs(*base));
127     } else if (intrinsic->name == "ubound") {
128       auto base{ExtractNamedEntity(call.arguments()[0]->UnwrapExpr())};
129       return base && IsConstantExprShape(GetUBOUNDs(*base));
130     } else if (intrinsic->name == "shape" || intrinsic->name == "size") {
131       auto shape{GetShape(call.arguments()[0]->UnwrapExpr())};
132       return shape && IsConstantExprShape(*shape);
133     } else if (proc.IsPure()) {
134       for (const auto &arg : call.arguments()) {
135         if (!arg) {
136           return false;
137         } else if (const auto *expr{arg->UnwrapExpr()};
138                    !expr || !(*this)(*expr)) {
139           return false;
140         }
141       }
142       return true;
143     }
144     // TODO: STORAGE_SIZE
145   }
146   return false;
147 }
148 
149 template <bool INVARIANT>
150 bool IsConstantExprHelper<INVARIANT>::IsConstantExprShape(
151     const Shape &shape) const {
152   for (const auto &extent : shape) {
153     if (!(*this)(extent)) {
154       return false;
155     }
156   }
157   return true;
158 }
159 
160 template <typename A> bool IsConstantExpr(const A &x) {
161   return IsConstantExprHelper<false>{}(x);
162 }
163 template bool IsConstantExpr(const Expr<SomeType> &);
164 template bool IsConstantExpr(const Expr<SomeInteger> &);
165 template bool IsConstantExpr(const Expr<SubscriptInteger> &);
166 template bool IsConstantExpr(const StructureConstructor &);
167 
168 // IsScopeInvariantExpr()
169 template <typename A> bool IsScopeInvariantExpr(const A &x) {
170   return IsConstantExprHelper<true>{}(x);
171 }
172 template bool IsScopeInvariantExpr(const Expr<SomeType> &);
173 template bool IsScopeInvariantExpr(const Expr<SomeInteger> &);
174 template bool IsScopeInvariantExpr(const Expr<SubscriptInteger> &);
175 
176 // IsActuallyConstant()
177 struct IsActuallyConstantHelper {
178   template <typename A> bool operator()(const A &) { return false; }
179   template <typename T> bool operator()(const Constant<T> &) { return true; }
180   template <typename T> bool operator()(const Parentheses<T> &x) {
181     return (*this)(x.left());
182   }
183   template <typename T> bool operator()(const Expr<T> &x) {
184     return common::visit([=](const auto &y) { return (*this)(y); }, x.u);
185   }
186   bool operator()(const Expr<SomeType> &x) {
187     return common::visit([this](const auto &y) { return (*this)(y); }, x.u);
188   }
189   bool operator()(const StructureConstructor &x) {
190     for (const auto &pair : x) {
191       const Expr<SomeType> &y{pair.second.value()};
192       if (!(*this)(y) && !IsNullPointer(y)) {
193         return false;
194       }
195     }
196     return true;
197   }
198   template <typename A> bool operator()(const A *x) { return x && (*this)(*x); }
199   template <typename A> bool operator()(const std::optional<A> &x) {
200     return x && (*this)(*x);
201   }
202 };
203 
204 template <typename A> bool IsActuallyConstant(const A &x) {
205   return IsActuallyConstantHelper{}(x);
206 }
207 
208 template bool IsActuallyConstant(const Expr<SomeType> &);
209 template bool IsActuallyConstant(const Expr<SomeInteger> &);
210 template bool IsActuallyConstant(const Expr<SubscriptInteger> &);
211 template bool IsActuallyConstant(const std::optional<Expr<SubscriptInteger>> &);
212 
213 // Object pointer initialization checking predicate IsInitialDataTarget().
214 // This code determines whether an expression is allowable as the static
215 // data address used to initialize a pointer with "=> x".  See C765.
216 class IsInitialDataTargetHelper
217     : public AllTraverse<IsInitialDataTargetHelper, true> {
218 public:
219   using Base = AllTraverse<IsInitialDataTargetHelper, true>;
220   using Base::operator();
221   explicit IsInitialDataTargetHelper(parser::ContextualMessages *m)
222       : Base{*this}, messages_{m} {}
223 
224   bool emittedMessage() const { return emittedMessage_; }
225 
226   bool operator()(const BOZLiteralConstant &) const { return false; }
227   bool operator()(const NullPointer &) const { return true; }
228   template <typename T> bool operator()(const Constant<T> &) const {
229     return false;
230   }
231   bool operator()(const semantics::Symbol &symbol) {
232     // This function checks only base symbols, not components.
233     const Symbol &ultimate{symbol.GetUltimate()};
234     if (const auto *assoc{
235             ultimate.detailsIf<semantics::AssocEntityDetails>()}) {
236       if (const auto &expr{assoc->expr()}) {
237         if (IsVariable(*expr)) {
238           return (*this)(*expr);
239         } else if (messages_) {
240           messages_->Say(
241               "An initial data target may not be an associated expression ('%s')"_err_en_US,
242               ultimate.name());
243           emittedMessage_ = true;
244         }
245       }
246       return false;
247     } else if (!ultimate.attrs().test(semantics::Attr::TARGET)) {
248       if (messages_) {
249         messages_->Say(
250             "An initial data target may not be a reference to an object '%s' that lacks the TARGET attribute"_err_en_US,
251             ultimate.name());
252         emittedMessage_ = true;
253       }
254       return false;
255     } else if (!IsSaved(ultimate)) {
256       if (messages_) {
257         messages_->Say(
258             "An initial data target may not be a reference to an object '%s' that lacks the SAVE attribute"_err_en_US,
259             ultimate.name());
260         emittedMessage_ = true;
261       }
262       return false;
263     } else {
264       return CheckVarOrComponent(ultimate);
265     }
266   }
267   bool operator()(const StaticDataObject &) const { return false; }
268   bool operator()(const TypeParamInquiry &) const { return false; }
269   bool operator()(const Triplet &x) const {
270     return IsConstantExpr(x.lower()) && IsConstantExpr(x.upper()) &&
271         IsConstantExpr(x.stride());
272   }
273   bool operator()(const Subscript &x) const {
274     return common::visit(common::visitors{
275                              [&](const Triplet &t) { return (*this)(t); },
276                              [&](const auto &y) {
277                                return y.value().Rank() == 0 &&
278                                    IsConstantExpr(y.value());
279                              },
280                          },
281         x.u);
282   }
283   bool operator()(const CoarrayRef &) const { return false; }
284   bool operator()(const Component &x) {
285     return CheckVarOrComponent(x.GetLastSymbol()) && (*this)(x.base());
286   }
287   bool operator()(const Substring &x) const {
288     return IsConstantExpr(x.lower()) && IsConstantExpr(x.upper()) &&
289         (*this)(x.parent());
290   }
291   bool operator()(const DescriptorInquiry &) const { return false; }
292   template <typename T> bool operator()(const ArrayConstructor<T> &) const {
293     return false;
294   }
295   bool operator()(const StructureConstructor &) const { return false; }
296   template <typename D, typename R, typename... O>
297   bool operator()(const Operation<D, R, O...> &) const {
298     return false;
299   }
300   template <typename T> bool operator()(const Parentheses<T> &x) const {
301     return (*this)(x.left());
302   }
303   bool operator()(const ProcedureRef &x) const {
304     if (const SpecificIntrinsic * intrinsic{x.proc().GetSpecificIntrinsic()}) {
305       return intrinsic->characteristics.value().attrs.test(
306           characteristics::Procedure::Attr::NullPointer);
307     }
308     return false;
309   }
310   bool operator()(const Relational<SomeType> &) const { return false; }
311 
312 private:
313   bool CheckVarOrComponent(const semantics::Symbol &symbol) {
314     const Symbol &ultimate{symbol.GetUltimate()};
315     if (IsAllocatable(ultimate)) {
316       if (messages_) {
317         messages_->Say(
318             "An initial data target may not be a reference to an ALLOCATABLE '%s'"_err_en_US,
319             ultimate.name());
320         emittedMessage_ = true;
321       }
322       return false;
323     } else if (ultimate.Corank() > 0) {
324       if (messages_) {
325         messages_->Say(
326             "An initial data target may not be a reference to a coarray '%s'"_err_en_US,
327             ultimate.name());
328         emittedMessage_ = true;
329       }
330       return false;
331     }
332     return true;
333   }
334 
335   parser::ContextualMessages *messages_;
336   bool emittedMessage_{false};
337 };
338 
339 bool IsInitialDataTarget(
340     const Expr<SomeType> &x, parser::ContextualMessages *messages) {
341   IsInitialDataTargetHelper helper{messages};
342   bool result{helper(x)};
343   if (!result && messages && !helper.emittedMessage()) {
344     messages->Say(
345         "An initial data target must be a designator with constant subscripts"_err_en_US);
346   }
347   return result;
348 }
349 
350 bool IsInitialProcedureTarget(const semantics::Symbol &symbol) {
351   const auto &ultimate{symbol.GetUltimate()};
352   return common::visit(
353       common::visitors{
354           [](const semantics::SubprogramDetails &subp) {
355             return !subp.isDummy();
356           },
357           [](const semantics::SubprogramNameDetails &) { return true; },
358           [&](const semantics::ProcEntityDetails &proc) {
359             return !semantics::IsPointer(ultimate) && !proc.isDummy();
360           },
361           [](const auto &) { return false; },
362       },
363       ultimate.details());
364 }
365 
366 bool IsInitialProcedureTarget(const ProcedureDesignator &proc) {
367   if (const auto *intrin{proc.GetSpecificIntrinsic()}) {
368     return !intrin->isRestrictedSpecific;
369   } else if (proc.GetComponent()) {
370     return false;
371   } else {
372     return IsInitialProcedureTarget(DEREF(proc.GetSymbol()));
373   }
374 }
375 
376 bool IsInitialProcedureTarget(const Expr<SomeType> &expr) {
377   if (const auto *proc{std::get_if<ProcedureDesignator>(&expr.u)}) {
378     return IsInitialProcedureTarget(*proc);
379   } else {
380     return IsNullProcedurePointer(expr);
381   }
382 }
383 
384 // Converts, folds, and then checks type, rank, and shape of an
385 // initialization expression for a named constant, a non-pointer
386 // variable static initialization, a component default initializer,
387 // a type parameter default value, or instantiated type parameter value.
388 std::optional<Expr<SomeType>> NonPointerInitializationExpr(const Symbol &symbol,
389     Expr<SomeType> &&x, FoldingContext &context,
390     const semantics::Scope *instantiation) {
391   CHECK(!IsPointer(symbol));
392   if (auto symTS{
393           characteristics::TypeAndShape::Characterize(symbol, context)}) {
394     auto xType{x.GetType()};
395     auto converted{ConvertToType(symTS->type(), Expr<SomeType>{x})};
396     if (!converted &&
397         symbol.owner().context().IsEnabled(
398             common::LanguageFeature::LogicalIntegerAssignment)) {
399       converted = DataConstantConversionExtension(context, symTS->type(), x);
400       if (converted &&
401           symbol.owner().context().ShouldWarn(
402               common::LanguageFeature::LogicalIntegerAssignment)) {
403         context.messages().Say(
404             "nonstandard usage: initialization of %s with %s"_port_en_US,
405             symTS->type().AsFortran(), x.GetType().value().AsFortran());
406       }
407     }
408     if (converted) {
409       auto folded{Fold(context, std::move(*converted))};
410       if (IsActuallyConstant(folded)) {
411         int symRank{GetRank(symTS->shape())};
412         if (IsImpliedShape(symbol)) {
413           if (folded.Rank() == symRank) {
414             return ArrayConstantBoundChanger{
415                 std::move(*AsConstantExtents(
416                     context, GetRawLowerBounds(context, NamedEntity{symbol})))}
417                 .ChangeLbounds(std::move(folded));
418           } else {
419             context.messages().Say(
420                 "Implied-shape parameter '%s' has rank %d but its initializer has rank %d"_err_en_US,
421                 symbol.name(), symRank, folded.Rank());
422           }
423         } else if (auto extents{AsConstantExtents(context, symTS->shape())}) {
424           if (folded.Rank() == 0 && symRank == 0) {
425             // symbol and constant are both scalars
426             return {std::move(folded)};
427           } else if (folded.Rank() == 0 && symRank > 0) {
428             // expand the scalar constant to an array
429             return ScalarConstantExpander{std::move(*extents),
430                 AsConstantExtents(
431                     context, GetRawLowerBounds(context, NamedEntity{symbol}))}
432                 .Expand(std::move(folded));
433           } else if (auto resultShape{GetShape(context, folded)}) {
434             if (CheckConformance(context.messages(), symTS->shape(),
435                     *resultShape, CheckConformanceFlags::None,
436                     "initialized object", "initialization expression")
437                     .value_or(false /*fail if not known now to conform*/)) {
438               // make a constant array with adjusted lower bounds
439               return ArrayConstantBoundChanger{
440                   std::move(*AsConstantExtents(context,
441                       GetRawLowerBounds(context, NamedEntity{symbol})))}
442                   .ChangeLbounds(std::move(folded));
443             }
444           }
445         } else if (IsNamedConstant(symbol)) {
446           if (IsExplicitShape(symbol)) {
447             context.messages().Say(
448                 "Named constant '%s' array must have constant shape"_err_en_US,
449                 symbol.name());
450           } else {
451             // Declaration checking handles other cases
452           }
453         } else {
454           context.messages().Say(
455               "Shape of initialized object '%s' must be constant"_err_en_US,
456               symbol.name());
457         }
458       } else if (IsErrorExpr(folded)) {
459       } else if (IsLenTypeParameter(symbol)) {
460         return {std::move(folded)};
461       } else if (IsKindTypeParameter(symbol)) {
462         if (instantiation) {
463           context.messages().Say(
464               "Value of kind type parameter '%s' (%s) must be a scalar INTEGER constant"_err_en_US,
465               symbol.name(), folded.AsFortran());
466         } else {
467           return {std::move(folded)};
468         }
469       } else if (IsNamedConstant(symbol)) {
470         context.messages().Say(
471             "Value of named constant '%s' (%s) cannot be computed as a constant value"_err_en_US,
472             symbol.name(), folded.AsFortran());
473       } else {
474         context.messages().Say(
475             "Initialization expression for '%s' (%s) cannot be computed as a constant value"_err_en_US,
476             symbol.name(), folded.AsFortran());
477       }
478     } else if (xType) {
479       context.messages().Say(
480           "Initialization expression cannot be converted to declared type of '%s' from %s"_err_en_US,
481           symbol.name(), xType->AsFortran());
482     } else {
483       context.messages().Say(
484           "Initialization expression cannot be converted to declared type of '%s'"_err_en_US,
485           symbol.name());
486     }
487   }
488   return std::nullopt;
489 }
490 
491 static bool IsNonLocal(const semantics::Symbol &symbol) {
492   return semantics::IsDummy(symbol) || symbol.has<semantics::UseDetails>() ||
493       symbol.owner().kind() == semantics::Scope::Kind::Module ||
494       semantics::FindCommonBlockContaining(symbol) ||
495       symbol.has<semantics::HostAssocDetails>();
496 }
497 
498 static bool IsPermissibleInquiry(const semantics::Symbol &firstSymbol,
499     const semantics::Symbol &lastSymbol, DescriptorInquiry::Field field,
500     const semantics::Scope &localScope) {
501   if (IsNonLocal(firstSymbol)) {
502     return true;
503   }
504   if (&localScope != &firstSymbol.owner()) {
505     return true;
506   }
507   // Inquiries on local objects may not access a deferred bound or length.
508   // (This code used to be a switch, but it proved impossible to write it
509   // thus without running afoul of bogus warnings from different C++
510   // compilers.)
511   if (field == DescriptorInquiry::Field::Rank) {
512     return true; // always known
513   }
514   const auto *object{lastSymbol.detailsIf<semantics::ObjectEntityDetails>()};
515   if (field == DescriptorInquiry::Field::LowerBound ||
516       field == DescriptorInquiry::Field::Extent ||
517       field == DescriptorInquiry::Field::Stride) {
518     return object && !object->shape().CanBeDeferredShape();
519   }
520   if (field == DescriptorInquiry::Field::Len) {
521     return object && object->type() &&
522         object->type()->category() == semantics::DeclTypeSpec::Character &&
523         !object->type()->characterTypeSpec().length().isDeferred();
524   }
525   return false;
526 }
527 
528 // Specification expression validation (10.1.11(2), C1010)
529 class CheckSpecificationExprHelper
530     : public AnyTraverse<CheckSpecificationExprHelper,
531           std::optional<std::string>> {
532 public:
533   using Result = std::optional<std::string>;
534   using Base = AnyTraverse<CheckSpecificationExprHelper, Result>;
535   explicit CheckSpecificationExprHelper(
536       const semantics::Scope &s, FoldingContext &context)
537       : Base{*this}, scope_{s}, context_{context} {}
538   using Base::operator();
539 
540   Result operator()(const CoarrayRef &) const { return "coindexed reference"; }
541 
542   Result operator()(const semantics::Symbol &symbol) const {
543     const auto &ultimate{symbol.GetUltimate()};
544     if (const auto *assoc{
545             ultimate.detailsIf<semantics::AssocEntityDetails>()}) {
546       return (*this)(assoc->expr());
547     } else if (semantics::IsNamedConstant(ultimate) ||
548         ultimate.owner().IsModule() || ultimate.owner().IsSubmodule()) {
549       return std::nullopt;
550     } else if (scope_.IsDerivedType() &&
551         IsVariableName(ultimate)) { // C750, C754
552       return "derived type component or type parameter value not allowed to "
553              "reference variable '"s +
554           ultimate.name().ToString() + "'";
555     } else if (IsDummy(ultimate)) {
556       if (ultimate.attrs().test(semantics::Attr::OPTIONAL)) {
557         return "reference to OPTIONAL dummy argument '"s +
558             ultimate.name().ToString() + "'";
559       } else if (!inInquiry_ &&
560           ultimate.attrs().test(semantics::Attr::INTENT_OUT)) {
561         return "reference to INTENT(OUT) dummy argument '"s +
562             ultimate.name().ToString() + "'";
563       } else if (ultimate.has<semantics::ObjectEntityDetails>()) {
564         return std::nullopt;
565       } else {
566         return "dummy procedure argument";
567       }
568     } else if (&symbol.owner() != &scope_ || &ultimate.owner() != &scope_) {
569       return std::nullopt; // host association is in play
570     } else if (const auto *object{
571                    ultimate.detailsIf<semantics::ObjectEntityDetails>()}) {
572       if (object->commonBlock()) {
573         return std::nullopt;
574       }
575     }
576     if (inInquiry_) {
577       return std::nullopt;
578     } else {
579       return "reference to local entity '"s + ultimate.name().ToString() + "'";
580     }
581   }
582 
583   Result operator()(const Component &x) const {
584     // Don't look at the component symbol.
585     return (*this)(x.base());
586   }
587   Result operator()(const ArrayRef &x) const {
588     if (auto result{(*this)(x.base())}) {
589       return result;
590     }
591     // The subscripts don't get special protection for being in a
592     // specification inquiry context;
593     auto restorer{common::ScopedSet(inInquiry_, false)};
594     return (*this)(x.subscript());
595   }
596   Result operator()(const Substring &x) const {
597     if (auto result{(*this)(x.parent())}) {
598       return result;
599     }
600     // The bounds don't get special protection for being in a
601     // specification inquiry context;
602     auto restorer{common::ScopedSet(inInquiry_, false)};
603     if (auto result{(*this)(x.lower())}) {
604       return result;
605     }
606     return (*this)(x.upper());
607   }
608   Result operator()(const DescriptorInquiry &x) const {
609     // Many uses of SIZE(), LBOUND(), &c. that are valid in specification
610     // expressions will have been converted to expressions over descriptor
611     // inquiries by Fold().
612     // Catch REAL, ALLOCATABLE :: X(:); REAL :: Y(SIZE(X))
613     if (IsPermissibleInquiry(x.base().GetFirstSymbol(),
614             x.base().GetLastSymbol(), x.field(), scope_)) {
615       auto restorer{common::ScopedSet(inInquiry_, true)};
616       return (*this)(x.base());
617     } else if (IsConstantExpr(x)) {
618       return std::nullopt;
619     } else {
620       return "non-constant descriptor inquiry not allowed for local object";
621     }
622   }
623 
624   Result operator()(const TypeParamInquiry &inq) const {
625     if (scope_.IsDerivedType() && !IsConstantExpr(inq) &&
626         inq.base() /* X%T, not local T */) { // C750, C754
627       return "non-constant reference to a type parameter inquiry not "
628              "allowed for derived type components or type parameter values";
629     }
630     return std::nullopt;
631   }
632 
633   Result operator()(const ProcedureRef &x) const {
634     bool inInquiry{false};
635     if (const auto *symbol{x.proc().GetSymbol()}) {
636       const Symbol &ultimate{symbol->GetUltimate()};
637       if (!semantics::IsPureProcedure(ultimate)) {
638         return "reference to impure function '"s + ultimate.name().ToString() +
639             "'";
640       }
641       if (semantics::IsStmtFunction(ultimate)) {
642         return "reference to statement function '"s +
643             ultimate.name().ToString() + "'";
644       }
645       if (scope_.IsDerivedType()) { // C750, C754
646         return "reference to function '"s + ultimate.name().ToString() +
647             "' not allowed for derived type components or type parameter"
648             " values";
649       }
650       if (auto procChars{
651               characteristics::Procedure::Characterize(x.proc(), context_)}) {
652         const auto iter{std::find_if(procChars->dummyArguments.begin(),
653             procChars->dummyArguments.end(),
654             [](const characteristics::DummyArgument &dummy) {
655               return std::holds_alternative<characteristics::DummyProcedure>(
656                   dummy.u);
657             })};
658         if (iter != procChars->dummyArguments.end()) {
659           return "reference to function '"s + ultimate.name().ToString() +
660               "' with dummy procedure argument '" + iter->name + '\'';
661         }
662       }
663       // References to internal functions are caught in expression semantics.
664       // TODO: other checks for standard module procedures
665     } else { // intrinsic
666       const SpecificIntrinsic &intrin{DEREF(x.proc().GetSpecificIntrinsic())};
667       inInquiry = context_.intrinsics().GetIntrinsicClass(intrin.name) ==
668           IntrinsicClass::inquiryFunction;
669       if (scope_.IsDerivedType()) { // C750, C754
670         if ((context_.intrinsics().IsIntrinsic(intrin.name) &&
671                 badIntrinsicsForComponents_.find(intrin.name) !=
672                     badIntrinsicsForComponents_.end())) {
673           return "reference to intrinsic '"s + intrin.name +
674               "' not allowed for derived type components or type parameter"
675               " values";
676         }
677         if (inInquiry && !IsConstantExpr(x)) {
678           return "non-constant reference to inquiry intrinsic '"s +
679               intrin.name +
680               "' not allowed for derived type components or type"
681               " parameter values";
682         }
683       }
684       // Type-determined inquiries (DIGITS, HUGE, &c.) will have already been
685       // folded and won't arrive here.  Inquiries that are represented with
686       // DescriptorInquiry operations (LBOUND) are checked elsewhere.  If a
687       // call that makes it to here satisfies the requirements of a constant
688       // expression (as Fortran defines it), it's fine.
689       if (IsConstantExpr(x)) {
690         return std::nullopt;
691       }
692       if (intrin.name == "present") {
693         return std::nullopt; // always ok
694       }
695       // Catch CHARACTER(:), ALLOCATABLE :: X; CHARACTER(LEN(X)) :: Y
696       if (inInquiry && x.arguments().size() >= 1) {
697         if (const auto &arg{x.arguments().at(0)}) {
698           if (auto dataRef{ExtractDataRef(*arg, true, true)}) {
699             if (intrin.name == "allocated" || intrin.name == "associated" ||
700                 intrin.name == "is_contiguous") { // ok
701             } else if (intrin.name == "len" &&
702                 IsPermissibleInquiry(dataRef->GetFirstSymbol(),
703                     dataRef->GetLastSymbol(), DescriptorInquiry::Field::Len,
704                     scope_)) { // ok
705             } else if (intrin.name == "lbound" &&
706                 IsPermissibleInquiry(dataRef->GetFirstSymbol(),
707                     dataRef->GetLastSymbol(),
708                     DescriptorInquiry::Field::LowerBound, scope_)) { // ok
709             } else if ((intrin.name == "shape" || intrin.name == "size" ||
710                            intrin.name == "sizeof" ||
711                            intrin.name == "storage_size" ||
712                            intrin.name == "ubound") &&
713                 IsPermissibleInquiry(dataRef->GetFirstSymbol(),
714                     dataRef->GetLastSymbol(), DescriptorInquiry::Field::Extent,
715                     scope_)) { // ok
716             } else {
717               return "non-constant inquiry function '"s + intrin.name +
718                   "' not allowed for local object";
719             }
720           }
721         }
722       }
723     }
724     auto restorer{common::ScopedSet(inInquiry_, inInquiry)};
725     return (*this)(x.arguments());
726   }
727 
728 private:
729   const semantics::Scope &scope_;
730   FoldingContext &context_;
731   // Contextual information: this flag is true when in an argument to
732   // an inquiry intrinsic like SIZE().
733   mutable bool inInquiry_{false};
734   const std::set<std::string> badIntrinsicsForComponents_{
735       "allocated", "associated", "extends_type_of", "present", "same_type_as"};
736 };
737 
738 template <typename A>
739 void CheckSpecificationExpr(
740     const A &x, const semantics::Scope &scope, FoldingContext &context) {
741   if (auto why{CheckSpecificationExprHelper{scope, context}(x)}) {
742     context.messages().Say(
743         "Invalid specification expression: %s"_err_en_US, *why);
744   }
745 }
746 
747 template void CheckSpecificationExpr(
748     const Expr<SomeType> &, const semantics::Scope &, FoldingContext &);
749 template void CheckSpecificationExpr(
750     const Expr<SomeInteger> &, const semantics::Scope &, FoldingContext &);
751 template void CheckSpecificationExpr(
752     const Expr<SubscriptInteger> &, const semantics::Scope &, FoldingContext &);
753 template void CheckSpecificationExpr(const std::optional<Expr<SomeType>> &,
754     const semantics::Scope &, FoldingContext &);
755 template void CheckSpecificationExpr(const std::optional<Expr<SomeInteger>> &,
756     const semantics::Scope &, FoldingContext &);
757 template void CheckSpecificationExpr(
758     const std::optional<Expr<SubscriptInteger>> &, const semantics::Scope &,
759     FoldingContext &);
760 
761 // IsContiguous() -- 9.5.4
762 class IsContiguousHelper
763     : public AnyTraverse<IsContiguousHelper, std::optional<bool>> {
764 public:
765   using Result = std::optional<bool>; // tri-state
766   using Base = AnyTraverse<IsContiguousHelper, Result>;
767   explicit IsContiguousHelper(FoldingContext &c) : Base{*this}, context_{c} {}
768   using Base::operator();
769 
770   template <typename T> Result operator()(const Constant<T> &) const {
771     return true;
772   }
773   Result operator()(const StaticDataObject &) const { return true; }
774   Result operator()(const semantics::Symbol &symbol) const {
775     const auto &ultimate{symbol.GetUltimate()};
776     if (ultimate.attrs().test(semantics::Attr::CONTIGUOUS)) {
777       return true;
778     } else if (!IsVariable(symbol)) {
779       return true;
780     } else if (ultimate.Rank() == 0) {
781       // Extension: accept scalars as a degenerate case of
782       // simple contiguity to allow their use in contexts like
783       // data targets in pointer assignments with remapping.
784       return true;
785     } else if (ultimate.has<semantics::AssocEntityDetails>()) {
786       return Base::operator()(ultimate); // use expr
787     } else if (semantics::IsPointer(ultimate) ||
788         semantics::IsAssumedShape(ultimate) || IsAssumedRank(ultimate)) {
789       return std::nullopt;
790     } else if (ultimate.has<semantics::ObjectEntityDetails>()) {
791       return true;
792     } else {
793       return Base::operator()(ultimate);
794     }
795   }
796 
797   Result operator()(const ArrayRef &x) const {
798     if (x.Rank() == 0) {
799       return true; // scalars considered contiguous
800     }
801     int subscriptRank{0};
802     auto baseLbounds{GetLBOUNDs(context_, x.base())};
803     auto baseUbounds{GetUBOUNDs(context_, x.base())};
804     auto subscripts{CheckSubscripts(
805         x.subscript(), subscriptRank, &baseLbounds, &baseUbounds)};
806     if (!subscripts.value_or(false)) {
807       return subscripts; // subscripts not known to be contiguous
808     } else if (subscriptRank > 0) {
809       // a(1)%b(:,:) is contiguous if and only if a(1)%b is contiguous.
810       return (*this)(x.base());
811     } else {
812       // a(:)%b(1,1) is (probably) not contiguous.
813       return std::nullopt;
814     }
815   }
816   Result operator()(const CoarrayRef &x) const {
817     int rank{0};
818     return CheckSubscripts(x.subscript(), rank).has_value();
819   }
820   Result operator()(const Component &x) const {
821     if (x.base().Rank() == 0) {
822       return (*this)(x.GetLastSymbol());
823     } else {
824       if (Result baseIsContiguous{(*this)(x.base())}) {
825         if (!*baseIsContiguous) {
826           return false;
827         }
828         // TODO could be true if base contiguous and this is only component, or
829         // if base has only one element?
830       }
831       return std::nullopt;
832     }
833   }
834   Result operator()(const ComplexPart &x) const {
835     return x.complex().Rank() == 0;
836   }
837   Result operator()(const Substring &) const { return std::nullopt; }
838 
839   Result operator()(const ProcedureRef &x) const {
840     if (auto chars{
841             characteristics::Procedure::Characterize(x.proc(), context_)}) {
842       if (chars->functionResult) {
843         const auto &result{*chars->functionResult};
844         if (!result.IsProcedurePointer()) {
845           if (result.attrs.test(
846                   characteristics::FunctionResult::Attr::Contiguous)) {
847             return true;
848           }
849           if (!result.attrs.test(
850                   characteristics::FunctionResult::Attr::Pointer)) {
851             return true;
852           }
853           if (const auto *type{result.GetTypeAndShape()};
854               type && type->Rank() == 0) {
855             return true; // pointer to scalar
856           }
857           // Must be non-CONTIGUOUS pointer to array
858         }
859       }
860     }
861     return std::nullopt;
862   }
863 
864   Result operator()(const NullPointer &) const { return true; }
865 
866 private:
867   // Returns "true" for a provably empty or simply contiguous array section;
868   // return "false" for a provably nonempty discontiguous section or for use
869   // of a vector subscript.
870   std::optional<bool> CheckSubscripts(const std::vector<Subscript> &subscript,
871       int &rank, const Shape *baseLbounds = nullptr,
872       const Shape *baseUbounds = nullptr) const {
873     bool anyTriplet{false};
874     rank = 0;
875     // Detect any provably empty dimension in this array section, which would
876     // render the whole section empty and therefore vacuously contiguous.
877     std::optional<bool> result;
878     bool mayBeEmpty{false};
879     auto dims{subscript.size()};
880     std::vector<bool> knownPartialSlice(dims, false);
881     for (auto j{dims}; j-- > 0;) {
882       std::optional<ConstantSubscript> dimLbound;
883       std::optional<ConstantSubscript> dimUbound;
884       std::optional<ConstantSubscript> dimExtent;
885       if (baseLbounds && j < baseLbounds->size()) {
886         if (const auto &lb{baseLbounds->at(j)}) {
887           dimLbound = ToInt64(Fold(context_, Expr<SubscriptInteger>{*lb}));
888         }
889       }
890       if (baseUbounds && j < baseUbounds->size()) {
891         if (const auto &ub{baseUbounds->at(j)}) {
892           dimUbound = ToInt64(Fold(context_, Expr<SubscriptInteger>{*ub}));
893         }
894       }
895       if (dimLbound && dimUbound) {
896         if (*dimLbound <= *dimUbound) {
897           dimExtent = *dimUbound - *dimLbound + 1;
898         } else {
899           // This is an empty dimension.
900           result = true;
901           dimExtent = 0;
902         }
903       }
904 
905       if (const auto *triplet{std::get_if<Triplet>(&subscript[j].u)}) {
906         ++rank;
907         if (auto stride{ToInt64(triplet->stride())}) {
908           const Expr<SubscriptInteger> *lowerBound{triplet->GetLower()};
909           const Expr<SubscriptInteger> *upperBound{triplet->GetUpper()};
910           std::optional<ConstantSubscript> lowerVal{lowerBound
911                   ? ToInt64(Fold(context_, Expr<SubscriptInteger>{*lowerBound}))
912                   : dimLbound};
913           std::optional<ConstantSubscript> upperVal{upperBound
914                   ? ToInt64(Fold(context_, Expr<SubscriptInteger>{*upperBound}))
915                   : dimUbound};
916           if (lowerVal && upperVal) {
917             if (*lowerVal < *upperVal) {
918               if (*stride < 0) {
919                 result = true; // empty dimension
920               } else if (!result && *stride > 1 &&
921                   *lowerVal + *stride <= *upperVal) {
922                 result = false; // discontiguous if not empty
923               }
924             } else if (*lowerVal > *upperVal) {
925               if (*stride > 0) {
926                 result = true; // empty dimension
927               } else if (!result && *stride < 0 &&
928                   *lowerVal + *stride >= *upperVal) {
929                 result = false; // discontiguous if not empty
930               }
931             } else {
932               mayBeEmpty = true;
933             }
934           } else {
935             mayBeEmpty = true;
936           }
937         } else {
938           mayBeEmpty = true;
939         }
940       } else if (subscript[j].Rank() > 0) {
941         ++rank;
942         if (!result) {
943           result = false; // vector subscript
944         }
945         mayBeEmpty = true;
946       } else {
947         // Scalar subscript.
948         if (dimExtent && *dimExtent > 1) {
949           knownPartialSlice[j] = true;
950         }
951       }
952     }
953     if (rank == 0) {
954       result = true; // scalar
955     }
956     if (result) {
957       return result;
958     }
959     // Not provably discontiguous at this point.
960     // Return "true" if simply contiguous, otherwise nullopt.
961     for (auto j{subscript.size()}; j-- > 0;) {
962       if (const auto *triplet{std::get_if<Triplet>(&subscript[j].u)}) {
963         auto stride{ToInt64(triplet->stride())};
964         if (!stride || stride != 1) {
965           return std::nullopt;
966         } else if (anyTriplet) {
967           if (triplet->GetLower() || triplet->GetUpper()) {
968             // all triplets before the last one must be just ":" for
969             // simple contiguity
970             return std::nullopt;
971           }
972         } else {
973           anyTriplet = true;
974         }
975         ++rank;
976       } else if (anyTriplet) {
977         // If the section cannot be empty, and this dimension's
978         // scalar subscript is known not to cover the whole
979         // dimension, then the array section is provably
980         // discontiguous.
981         return (mayBeEmpty || !knownPartialSlice[j])
982             ? std::nullopt
983             : std::make_optional(false);
984       }
985     }
986     return true; // simply contiguous
987   }
988 
989   FoldingContext &context_;
990 };
991 
992 template <typename A>
993 std::optional<bool> IsContiguous(const A &x, FoldingContext &context) {
994   return IsContiguousHelper{context}(x);
995 }
996 
997 template std::optional<bool> IsContiguous(
998     const Expr<SomeType> &, FoldingContext &);
999 template std::optional<bool> IsContiguous(const ArrayRef &, FoldingContext &);
1000 template std::optional<bool> IsContiguous(const Substring &, FoldingContext &);
1001 template std::optional<bool> IsContiguous(const Component &, FoldingContext &);
1002 template std::optional<bool> IsContiguous(
1003     const ComplexPart &, FoldingContext &);
1004 template std::optional<bool> IsContiguous(const CoarrayRef &, FoldingContext &);
1005 template std::optional<bool> IsContiguous(const Symbol &, FoldingContext &);
1006 
1007 // IsErrorExpr()
1008 struct IsErrorExprHelper : public AnyTraverse<IsErrorExprHelper, bool> {
1009   using Result = bool;
1010   using Base = AnyTraverse<IsErrorExprHelper, Result>;
1011   IsErrorExprHelper() : Base{*this} {}
1012   using Base::operator();
1013 
1014   bool operator()(const SpecificIntrinsic &x) {
1015     return x.name == IntrinsicProcTable::InvalidName;
1016   }
1017 };
1018 
1019 template <typename A> bool IsErrorExpr(const A &x) {
1020   return IsErrorExprHelper{}(x);
1021 }
1022 
1023 template bool IsErrorExpr(const Expr<SomeType> &);
1024 
1025 // C1577
1026 // TODO: Also check C1579 & C1582 here
1027 class StmtFunctionChecker
1028     : public AnyTraverse<StmtFunctionChecker, std::optional<parser::Message>> {
1029 public:
1030   using Result = std::optional<parser::Message>;
1031   using Base = AnyTraverse<StmtFunctionChecker, Result>;
1032   StmtFunctionChecker(const Symbol &sf, FoldingContext &context)
1033       : Base{*this}, sf_{sf}, context_{context} {}
1034   using Base::operator();
1035 
1036   template <typename T> Result operator()(const ArrayConstructor<T> &) const {
1037     return parser::Message{sf_.name(),
1038         "Statement function '%s' should not contain an array constructor"_port_en_US,
1039         sf_.name()};
1040   }
1041   Result operator()(const StructureConstructor &) const {
1042     return parser::Message{sf_.name(),
1043         "Statement function '%s' should not contain a structure constructor"_port_en_US,
1044         sf_.name()};
1045   }
1046   Result operator()(const TypeParamInquiry &) const {
1047     return parser::Message{sf_.name(),
1048         "Statement function '%s' should not contain a type parameter inquiry"_port_en_US,
1049         sf_.name()};
1050   }
1051   Result operator()(const ProcedureDesignator &proc) const {
1052     if (const Symbol * symbol{proc.GetSymbol()}) {
1053       const Symbol &ultimate{symbol->GetUltimate()};
1054       if (const auto *subp{
1055               ultimate.detailsIf<semantics::SubprogramDetails>()}) {
1056         if (subp->stmtFunction() && &ultimate.owner() == &sf_.owner()) {
1057           if (ultimate.name().begin() > sf_.name().begin()) {
1058             return parser::Message{sf_.name(),
1059                 "Statement function '%s' may not reference another statement function '%s' that is defined later"_err_en_US,
1060                 sf_.name(), ultimate.name()};
1061           }
1062         }
1063       }
1064       if (auto chars{
1065               characteristics::Procedure::Characterize(proc, context_)}) {
1066         if (!chars->CanBeCalledViaImplicitInterface()) {
1067           return parser::Message(sf_.name(),
1068               "Statement function '%s' should not reference function '%s' that requires an explicit interface"_port_en_US,
1069               sf_.name(), symbol->name());
1070         }
1071       }
1072     }
1073     if (proc.Rank() > 0) {
1074       return parser::Message(sf_.name(),
1075           "Statement function '%s' should not reference a function that returns an array"_port_en_US,
1076           sf_.name());
1077     }
1078     return std::nullopt;
1079   }
1080   Result operator()(const ActualArgument &arg) const {
1081     if (const auto *expr{arg.UnwrapExpr()}) {
1082       if (auto result{(*this)(*expr)}) {
1083         return result;
1084       }
1085       if (expr->Rank() > 0 && !UnwrapWholeSymbolOrComponentDataRef(*expr)) {
1086         return parser::Message(sf_.name(),
1087             "Statement function '%s' should not pass an array argument that is not a whole array"_port_en_US,
1088             sf_.name());
1089       }
1090     }
1091     return std::nullopt;
1092   }
1093 
1094 private:
1095   const Symbol &sf_;
1096   FoldingContext &context_;
1097 };
1098 
1099 std::optional<parser::Message> CheckStatementFunction(
1100     const Symbol &sf, const Expr<SomeType> &expr, FoldingContext &context) {
1101   return StmtFunctionChecker{sf, context}(expr);
1102 }
1103 
1104 } // namespace Fortran::evaluate
1105