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