flang/lib/Evaluate/check-expression.cpp

   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