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