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