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