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