xref: /llvm-project/flang/lib/Evaluate/check-expression.cpp (revision 1c91d9bdea3b6c38e8fbce46ec8181a9c0aa26f8) 
1 //===-- lib/Evaluate/check-expression.cpp ---------------------------------===//
2 //
3 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
4 // See https://llvm.org/LICENSE.txt for license information.
5 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
6 //
7 //===----------------------------------------------------------------------===//
8 
9 #include "flang/Evaluate/check-expression.h"
10 #include "flang/Evaluate/characteristics.h"
11 #include "flang/Evaluate/intrinsics.h"
12 #include "flang/Evaluate/tools.h"
13 #include "flang/Evaluate/traverse.h"
14 #include "flang/Evaluate/type.h"
15 #include "flang/Semantics/semantics.h"
16 #include "flang/Semantics/symbol.h"
17 #include "flang/Semantics/tools.h"
18 #include <set>
19 #include <string>
20 
21 namespace Fortran::evaluate {
22 
23 // Constant expression predicates IsConstantExpr() & IsScopeInvariantExpr().
24 // This code determines whether an expression is a "constant expression"
25 // in the sense of section 10.1.12.  This is not the same thing as being
26 // able to fold it (yet) into a known constant value; specifically,
27 // the expression may reference derived type kind parameters whose values
28 // are not yet known.
29 //
30 // The variant form (IsScopeInvariantExpr()) also accepts symbols that are
31 // INTENT(IN) dummy arguments without the VALUE attribute.
32 template <bool INVARIANT>
33 class IsConstantExprHelper
34     : public AllTraverse<IsConstantExprHelper<INVARIANT>, true> {
35 public:
36   using Base = AllTraverse<IsConstantExprHelper, true>;
37   IsConstantExprHelper() : Base{*this} {}
38   using Base::operator();
39 
40   // A missing expression is not considered to be constant.
41   template <typename A> bool operator()(const std::optional<A> &x) const {
42     return x && (*this)(*x);
43   }
44 
45   bool operator()(const TypeParamInquiry &inq) const {
46     return INVARIANT || semantics::IsKindTypeParameter(inq.parameter());
47   }
48   bool operator()(const semantics::Symbol &symbol) const {
49     const auto &ultimate{GetAssociationRoot(symbol)};
50     return IsNamedConstant(ultimate) || IsImpliedDoIndex(ultimate) ||
51         IsInitialProcedureTarget(ultimate) ||
52         ultimate.has<semantics::TypeParamDetails>() ||
53         (INVARIANT && IsIntentIn(symbol) && !IsOptional(symbol) &&
54             !symbol.attrs().test(semantics::Attr::VALUE));
55   }
56   bool operator()(const CoarrayRef &) const { return false; }
57   bool operator()(const semantics::ParamValue &param) const {
58     return param.isExplicit() && (*this)(param.GetExplicit());
59   }
60   bool operator()(const ProcedureRef &) const;
61   bool operator()(const StructureConstructor &constructor) const {
62     for (const auto &[symRef, expr] : constructor) {
63       if (!IsConstantStructureConstructorComponent(*symRef, expr.value())) {
64         return false;
65       }
66     }
67     return true;
68   }
69   bool operator()(const Component &component) const {
70     return (*this)(component.base());
71   }
72   // Forbid integer division by zero in constants.
73   template <int KIND>
74   bool operator()(
75       const Divide<Type<TypeCategory::Integer, KIND>> &division) const {
76     using T = Type<TypeCategory::Integer, KIND>;
77     if (const auto divisor{GetScalarConstantValue<T>(division.right())}) {
78       return !divisor->IsZero() && (*this)(division.left());
79     } else {
80       return false;
81     }
82   }
83 
84   bool operator()(const Constant<SomeDerived> &) const { return true; }
85   bool operator()(const DescriptorInquiry &x) const {
86     const Symbol &sym{x.base().GetLastSymbol()};
87     return INVARIANT && !IsAllocatable(sym) &&
88         (!IsDummy(sym) ||
89             (IsIntentIn(sym) && !IsOptional(sym) &&
90                 !sym.attrs().test(semantics::Attr::VALUE)));
91   }
92 
93 private:
94   bool IsConstantStructureConstructorComponent(
95       const Symbol &, const Expr<SomeType> &) const;
96   bool IsConstantExprShape(const Shape &) const;
97 };
98 
99 template <bool INVARIANT>
100 bool IsConstantExprHelper<INVARIANT>::IsConstantStructureConstructorComponent(
101     const Symbol &component, const Expr<SomeType> &expr) const {
102   if (IsAllocatable(component)) {
103     return IsNullObjectPointer(expr);
104   } else if (IsPointer(component)) {
105     return IsNullPointer(expr) || IsInitialDataTarget(expr) ||
106         IsInitialProcedureTarget(expr);
107   } else {
108     return (*this)(expr);
109   }
110 }
111 
112 template <bool INVARIANT>
113 bool IsConstantExprHelper<INVARIANT>::operator()(
114     const ProcedureRef &call) const {
115   // LBOUND, UBOUND, and SIZE with truly constant DIM= arguments will have
116   // been rewritten into DescriptorInquiry operations.
117   if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&call.proc().u)}) {
118     const characteristics::Procedure &proc{intrinsic->characteristics.value()};
119     if (intrinsic->name == "kind" ||
120         intrinsic->name == IntrinsicProcTable::InvalidName ||
121         call.arguments().empty() || !call.arguments()[0]) {
122       // kind is always a constant, and we avoid cascading errors by considering
123       // invalid calls to intrinsics to be constant
124       return true;
125     } else if (intrinsic->name == "lbound") {
126       auto base{ExtractNamedEntity(call.arguments()[0]->UnwrapExpr())};
127       return base && IsConstantExprShape(GetLBOUNDs(*base));
128     } else if (intrinsic->name == "ubound") {
129       auto base{ExtractNamedEntity(call.arguments()[0]->UnwrapExpr())};
130       return base && IsConstantExprShape(GetUBOUNDs(*base));
131     } else if (intrinsic->name == "shape" || intrinsic->name == "size") {
132       auto shape{GetShape(call.arguments()[0]->UnwrapExpr())};
133       return shape && IsConstantExprShape(*shape);
134     } else if (proc.IsPure()) {
135       for (const auto &arg : call.arguments()) {
136         if (!arg) {
137           return false;
138         } else if (const auto *expr{arg->UnwrapExpr()};
139                    !expr || !(*this)(*expr)) {
140           return false;
141         }
142       }
143       return true;
144     }
145     // TODO: STORAGE_SIZE
146   }
147   return false;
148 }
149 
150 template <bool INVARIANT>
151 bool IsConstantExprHelper<INVARIANT>::IsConstantExprShape(
152     const Shape &shape) const {
153   for (const auto &extent : shape) {
154     if (!(*this)(extent)) {
155       return false;
156     }
157   }
158   return true;
159 }
160 
161 template <typename A> bool IsConstantExpr(const A &x) {
162   return IsConstantExprHelper<false>{}(x);
163 }
164 template bool IsConstantExpr(const Expr<SomeType> &);
165 template bool IsConstantExpr(const Expr<SomeInteger> &);
166 template bool IsConstantExpr(const Expr<SubscriptInteger> &);
167 template bool IsConstantExpr(const StructureConstructor &);
168 
169 // IsScopeInvariantExpr()
170 template <typename A> bool IsScopeInvariantExpr(const A &x) {
171   return IsConstantExprHelper<true>{}(x);
172 }
173 template bool IsScopeInvariantExpr(const Expr<SomeType> &);
174 template bool IsScopeInvariantExpr(const Expr<SomeInteger> &);
175 template bool IsScopeInvariantExpr(const Expr<SubscriptInteger> &);
176 
177 // IsActuallyConstant()
178 struct IsActuallyConstantHelper {
179   template <typename A> bool operator()(const A &) { return false; }
180   template <typename T> bool operator()(const Constant<T> &) { return true; }
181   template <typename T> bool operator()(const Parentheses<T> &x) {
182     return (*this)(x.left());
183   }
184   template <typename T> bool operator()(const Expr<T> &x) {
185     return common::visit([=](const auto &y) { return (*this)(y); }, x.u);
186   }
187   bool operator()(const Expr<SomeType> &x) {
188     return common::visit([this](const auto &y) { return (*this)(y); }, x.u);
189   }
190   bool operator()(const StructureConstructor &x) {
191     for (const auto &pair : x) {
192       const Expr<SomeType> &y{pair.second.value()};
193       if (!(*this)(y) && !IsNullPointer(y)) {
194         return false;
195       }
196     }
197     return true;
198   }
199   template <typename A> bool operator()(const A *x) { return x && (*this)(*x); }
200   template <typename A> bool operator()(const std::optional<A> &x) {
201     return x && (*this)(*x);
202   }
203 };
204 
205 template <typename A> bool IsActuallyConstant(const A &x) {
206   return IsActuallyConstantHelper{}(x);
207 }
208 
209 template bool IsActuallyConstant(const Expr<SomeType> &);
210 template bool IsActuallyConstant(const Expr<SomeInteger> &);
211 template bool IsActuallyConstant(const Expr<SubscriptInteger> &);
212 template bool IsActuallyConstant(const std::optional<Expr<SubscriptInteger>> &);
213 
214 // Object pointer initialization checking predicate IsInitialDataTarget().
215 // This code determines whether an expression is allowable as the static
216 // data address used to initialize a pointer with "=> x".  See C765.
217 class IsInitialDataTargetHelper
218     : public AllTraverse<IsInitialDataTargetHelper, true> {
219 public:
220   using Base = AllTraverse<IsInitialDataTargetHelper, true>;
221   using Base::operator();
222   explicit IsInitialDataTargetHelper(parser::ContextualMessages *m)
223       : Base{*this}, messages_{m} {}
224 
225   bool emittedMessage() const { return emittedMessage_; }
226 
227   bool operator()(const BOZLiteralConstant &) const { return false; }
228   bool operator()(const NullPointer &) const { return true; }
229   template <typename T> bool operator()(const Constant<T> &) const {
230     return false;
231   }
232   bool operator()(const semantics::Symbol &symbol) {
233     // This function checks only base symbols, not components.
234     const Symbol &ultimate{symbol.GetUltimate()};
235     if (const auto *assoc{
236             ultimate.detailsIf<semantics::AssocEntityDetails>()}) {
237       if (const auto &expr{assoc->expr()}) {
238         if (IsVariable(*expr)) {
239           return (*this)(*expr);
240         } else if (messages_) {
241           messages_->Say(
242               "An initial data target may not be an associated expression ('%s')"_err_en_US,
243               ultimate.name());
244           emittedMessage_ = true;
245         }
246       }
247       return false;
248     } else if (!ultimate.attrs().test(semantics::Attr::TARGET)) {
249       if (messages_) {
250         messages_->Say(
251             "An initial data target may not be a reference to an object '%s' that lacks the TARGET attribute"_err_en_US,
252             ultimate.name());
253         emittedMessage_ = true;
254       }
255       return false;
256     } else if (!IsSaved(ultimate)) {
257       if (messages_) {
258         messages_->Say(
259             "An initial data target may not be a reference to an object '%s' that lacks the SAVE attribute"_err_en_US,
260             ultimate.name());
261         emittedMessage_ = true;
262       }
263       return false;
264     } else {
265       return CheckVarOrComponent(ultimate);
266     }
267   }
268   bool operator()(const StaticDataObject &) const { return false; }
269   bool operator()(const TypeParamInquiry &) const { return false; }
270   bool operator()(const Triplet &x) const {
271     return IsConstantExpr(x.lower()) && IsConstantExpr(x.upper()) &&
272         IsConstantExpr(x.stride());
273   }
274   bool operator()(const Subscript &x) const {
275     return common::visit(common::visitors{
276                              [&](const Triplet &t) { return (*this)(t); },
277                              [&](const auto &y) {
278                                return y.value().Rank() == 0 &&
279                                    IsConstantExpr(y.value());
280                              },
281                          },
282         x.u);
283   }
284   bool operator()(const CoarrayRef &) const { return false; }
285   bool operator()(const Component &x) {
286     return CheckVarOrComponent(x.GetLastSymbol()) && (*this)(x.base());
287   }
288   bool operator()(const Substring &x) const {
289     return IsConstantExpr(x.lower()) && IsConstantExpr(x.upper()) &&
290         (*this)(x.parent());
291   }
292   bool operator()(const DescriptorInquiry &) const { return false; }
293   template <typename T> bool operator()(const ArrayConstructor<T> &) const {
294     return false;
295   }
296   bool operator()(const StructureConstructor &) const { return false; }
297   template <typename D, typename R, typename... O>
298   bool operator()(const Operation<D, R, O...> &) const {
299     return false;
300   }
301   template <typename T> bool operator()(const Parentheses<T> &x) const {
302     return (*this)(x.left());
303   }
304   bool operator()(const ProcedureRef &x) const {
305     if (const SpecificIntrinsic * intrinsic{x.proc().GetSpecificIntrinsic()}) {
306       return intrinsic->characteristics.value().attrs.test(
307           characteristics::Procedure::Attr::NullPointer);
308     }
309     return false;
310   }
311   bool operator()(const Relational<SomeType> &) const { return false; }
312 
313 private:
314   bool CheckVarOrComponent(const semantics::Symbol &symbol) {
315     const Symbol &ultimate{symbol.GetUltimate()};
316     if (IsAllocatable(ultimate)) {
317       if (messages_) {
318         messages_->Say(
319             "An initial data target may not be a reference to an ALLOCATABLE '%s'"_err_en_US,
320             ultimate.name());
321         emittedMessage_ = true;
322       }
323       return false;
324     } else if (ultimate.Corank() > 0) {
325       if (messages_) {
326         messages_->Say(
327             "An initial data target may not be a reference to a coarray '%s'"_err_en_US,
328             ultimate.name());
329         emittedMessage_ = true;
330       }
331       return false;
332     }
333     return true;
334   }
335 
336   parser::ContextualMessages *messages_;
337   bool emittedMessage_{false};
338 };
339 
340 bool IsInitialDataTarget(
341     const Expr<SomeType> &x, parser::ContextualMessages *messages) {
342   IsInitialDataTargetHelper helper{messages};
343   bool result{helper(x)};
344   if (!result && messages && !helper.emittedMessage()) {
345     messages->Say(
346         "An initial data target must be a designator with constant subscripts"_err_en_US);
347   }
348   return result;
349 }
350 
351 bool IsInitialProcedureTarget(const semantics::Symbol &symbol) {
352   const auto &ultimate{symbol.GetUltimate()};
353   return common::visit(
354       common::visitors{
355           [](const semantics::SubprogramDetails &subp) {
356             return !subp.isDummy();
357           },
358           [](const semantics::SubprogramNameDetails &) { return true; },
359           [&](const semantics::ProcEntityDetails &proc) {
360             return !semantics::IsPointer(ultimate) && !proc.isDummy();
361           },
362           [](const auto &) { return false; },
363       },
364       ultimate.details());
365 }
366 
367 bool IsInitialProcedureTarget(const ProcedureDesignator &proc) {
368   if (const auto *intrin{proc.GetSpecificIntrinsic()}) {
369     return !intrin->isRestrictedSpecific;
370   } else if (proc.GetComponent()) {
371     return false;
372   } else {
373     return IsInitialProcedureTarget(DEREF(proc.GetSymbol()));
374   }
375 }
376 
377 bool IsInitialProcedureTarget(const Expr<SomeType> &expr) {
378   if (const auto *proc{std::get_if<ProcedureDesignator>(&expr.u)}) {
379     return IsInitialProcedureTarget(*proc);
380   } else {
381     return IsNullProcedurePointer(expr);
382   }
383 }
384 
385 // Converts, folds, and then checks type, rank, and shape of an
386 // initialization expression for a named constant, a non-pointer
387 // variable static initialization, a component default initializer,
388 // a type parameter default value, or instantiated type parameter value.
389 std::optional<Expr<SomeType>> NonPointerInitializationExpr(const Symbol &symbol,
390     Expr<SomeType> &&x, FoldingContext &context,
391     const semantics::Scope *instantiation) {
392   CHECK(!IsPointer(symbol));
393   if (auto symTS{
394           characteristics::TypeAndShape::Characterize(symbol, context)}) {
395     auto xType{x.GetType()};
396     auto converted{ConvertToType(symTS->type(), Expr<SomeType>{x})};
397     if (!converted &&
398         symbol.owner().context().IsEnabled(
399             common::LanguageFeature::LogicalIntegerAssignment)) {
400       converted = DataConstantConversionExtension(context, symTS->type(), x);
401       if (converted &&
402           symbol.owner().context().ShouldWarn(
403               common::LanguageFeature::LogicalIntegerAssignment)) {
404         context.messages().Say(
405             "nonstandard usage: initialization of %s with %s"_port_en_US,
406             symTS->type().AsFortran(), x.GetType().value().AsFortran());
407       }
408     }
409     if (converted) {
410       auto folded{Fold(context, std::move(*converted))};
411       if (IsActuallyConstant(folded)) {
412         int symRank{GetRank(symTS->shape())};
413         if (IsImpliedShape(symbol)) {
414           if (folded.Rank() == symRank) {
415             return ArrayConstantBoundChanger{
416                 std::move(*AsConstantExtents(
417                     context, GetRawLowerBounds(context, NamedEntity{symbol})))}
418                 .ChangeLbounds(std::move(folded));
419           } else {
420             context.messages().Say(
421                 "Implied-shape parameter '%s' has rank %d but its initializer has rank %d"_err_en_US,
422                 symbol.name(), symRank, folded.Rank());
423           }
424         } else if (auto extents{AsConstantExtents(context, symTS->shape())}) {
425           if (folded.Rank() == 0 && symRank == 0) {
426             // symbol and constant are both scalars
427             return {std::move(folded)};
428           } else if (folded.Rank() == 0 && symRank > 0) {
429             // expand the scalar constant to an array
430             return ScalarConstantExpander{std::move(*extents),
431                 AsConstantExtents(
432                     context, GetRawLowerBounds(context, NamedEntity{symbol}))}
433                 .Expand(std::move(folded));
434           } else if (auto resultShape{GetShape(context, folded)}) {
435             if (CheckConformance(context.messages(), symTS->shape(),
436                     *resultShape, CheckConformanceFlags::None,
437                     "initialized object", "initialization expression")
438                     .value_or(false /*fail if not known now to conform*/)) {
439               // make a constant array with adjusted lower bounds
440               return ArrayConstantBoundChanger{
441                   std::move(*AsConstantExtents(context,
442                       GetRawLowerBounds(context, NamedEntity{symbol})))}
443                   .ChangeLbounds(std::move(folded));
444             }
445           }
446         } else if (IsNamedConstant(symbol)) {
447           if (IsExplicitShape(symbol)) {
448             context.messages().Say(
449                 "Named constant '%s' array must have constant shape"_err_en_US,
450                 symbol.name());
451           } else {
452             // Declaration checking handles other cases
453           }
454         } else {
455           context.messages().Say(
456               "Shape of initialized object '%s' must be constant"_err_en_US,
457               symbol.name());
458         }
459       } else if (IsErrorExpr(folded)) {
460       } else if (IsLenTypeParameter(symbol)) {
461         return {std::move(folded)};
462       } else if (IsKindTypeParameter(symbol)) {
463         if (instantiation) {
464           context.messages().Say(
465               "Value of kind type parameter '%s' (%s) must be a scalar INTEGER constant"_err_en_US,
466               symbol.name(), folded.AsFortran());
467         } else {
468           return {std::move(folded)};
469         }
470       } else if (IsNamedConstant(symbol)) {
471         context.messages().Say(
472             "Value of named constant '%s' (%s) cannot be computed as a constant value"_err_en_US,
473             symbol.name(), folded.AsFortran());
474       } else {
475         context.messages().Say(
476             "Initialization expression for '%s' (%s) cannot be computed as a constant value"_err_en_US,
477             symbol.name(), folded.AsFortran());
478       }
479     } else if (xType) {
480       context.messages().Say(
481           "Initialization expression cannot be converted to declared type of '%s' from %s"_err_en_US,
482           symbol.name(), xType->AsFortran());
483     } else {
484       context.messages().Say(
485           "Initialization expression cannot be converted to declared type of '%s'"_err_en_US,
486           symbol.name());
487     }
488   }
489   return std::nullopt;
490 }
491 
492 static bool IsNonLocal(const semantics::Symbol &symbol) {
493   return semantics::IsDummy(symbol) || symbol.has<semantics::UseDetails>() ||
494       symbol.owner().kind() == semantics::Scope::Kind::Module ||
495       semantics::FindCommonBlockContaining(symbol) ||
496       symbol.has<semantics::HostAssocDetails>();
497 }
498 
499 static bool IsPermissibleInquiry(const semantics::Symbol &firstSymbol,
500     const semantics::Symbol &lastSymbol, DescriptorInquiry::Field field,
501     const semantics::Scope &localScope) {
502   if (IsNonLocal(firstSymbol)) {
503     return true;
504   }
505   if (&localScope != &firstSymbol.owner()) {
506     return true;
507   }
508   // Inquiries on local objects may not access a deferred bound or length.
509   // (This code used to be a switch, but it proved impossible to write it
510   // thus without running afoul of bogus warnings from different C++
511   // compilers.)
512   if (field == DescriptorInquiry::Field::Rank) {
513     return true; // always known
514   }
515   const auto *object{lastSymbol.detailsIf<semantics::ObjectEntityDetails>()};
516   if (field == DescriptorInquiry::Field::LowerBound ||
517       field == DescriptorInquiry::Field::Extent ||
518       field == DescriptorInquiry::Field::Stride) {
519     return object && !object->shape().CanBeDeferredShape();
520   }
521   if (field == DescriptorInquiry::Field::Len) {
522     return object && object->type() &&
523         object->type()->category() == semantics::DeclTypeSpec::Character &&
524         !object->type()->characterTypeSpec().length().isDeferred();
525   }
526   return false;
527 }
528 
529 // Specification expression validation (10.1.11(2), C1010)
530 class CheckSpecificationExprHelper
531     : public AnyTraverse<CheckSpecificationExprHelper,
532           std::optional<std::string>> {
533 public:
534   using Result = std::optional<std::string>;
535   using Base = AnyTraverse<CheckSpecificationExprHelper, Result>;
536   explicit CheckSpecificationExprHelper(
537       const semantics::Scope &s, FoldingContext &context)
538       : Base{*this}, scope_{s}, context_{context} {}
539   using Base::operator();
540 
541   Result operator()(const CoarrayRef &) const { return "coindexed reference"; }
542 
543   Result operator()(const semantics::Symbol &symbol) const {
544     const auto &ultimate{symbol.GetUltimate()};
545     if (const auto *assoc{
546             ultimate.detailsIf<semantics::AssocEntityDetails>()}) {
547       return (*this)(assoc->expr());
548     } else if (semantics::IsNamedConstant(ultimate) ||
549         ultimate.owner().IsModule() || ultimate.owner().IsSubmodule()) {
550       return std::nullopt;
551     } else if (scope_.IsDerivedType() &&
552         IsVariableName(ultimate)) { // C750, C754
553       return "derived type component or type parameter value not allowed to "
554              "reference variable '"s +
555           ultimate.name().ToString() + "'";
556     } else if (IsDummy(ultimate)) {
557       if (ultimate.attrs().test(semantics::Attr::OPTIONAL)) {
558         return "reference to OPTIONAL dummy argument '"s +
559             ultimate.name().ToString() + "'";
560       } else if (!inInquiry_ &&
561           ultimate.attrs().test(semantics::Attr::INTENT_OUT)) {
562         return "reference to INTENT(OUT) dummy argument '"s +
563             ultimate.name().ToString() + "'";
564       } else if (ultimate.has<semantics::ObjectEntityDetails>()) {
565         return std::nullopt;
566       } else {
567         return "dummy procedure argument";
568       }
569     } else if (&symbol.owner() != &scope_ || &ultimate.owner() != &scope_) {
570       return std::nullopt; // host association is in play
571     } else if (const auto *object{
572                    ultimate.detailsIf<semantics::ObjectEntityDetails>()}) {
573       if (object->commonBlock()) {
574         return std::nullopt;
575       }
576     }
577     if (inInquiry_) {
578       return std::nullopt;
579     } else {
580       return "reference to local entity '"s + ultimate.name().ToString() + "'";
581     }
582   }
583 
584   Result operator()(const Component &x) const {
585     // Don't look at the component symbol.
586     return (*this)(x.base());
587   }
588   Result operator()(const ArrayRef &x) const {
589     if (auto result{(*this)(x.base())}) {
590       return result;
591     }
592     // The subscripts don't get special protection for being in a
593     // specification inquiry context;
594     auto restorer{common::ScopedSet(inInquiry_, false)};
595     return (*this)(x.subscript());
596   }
597   Result operator()(const Substring &x) const {
598     if (auto result{(*this)(x.parent())}) {
599       return result;
600     }
601     // The bounds don't get special protection for being in a
602     // specification inquiry context;
603     auto restorer{common::ScopedSet(inInquiry_, false)};
604     if (auto result{(*this)(x.lower())}) {
605       return result;
606     }
607     return (*this)(x.upper());
608   }
609   Result operator()(const DescriptorInquiry &x) const {
610     // Many uses of SIZE(), LBOUND(), &c. that are valid in specification
611     // expressions will have been converted to expressions over descriptor
612     // inquiries by Fold().
613     // Catch REAL, ALLOCATABLE :: X(:); REAL :: Y(SIZE(X))
614     if (IsPermissibleInquiry(x.base().GetFirstSymbol(),
615             x.base().GetLastSymbol(), x.field(), scope_)) {
616       auto restorer{common::ScopedSet(inInquiry_, true)};
617       return (*this)(x.base());
618     } else if (IsConstantExpr(x)) {
619       return std::nullopt;
620     } else {
621       return "non-constant descriptor inquiry not allowed for local object";
622     }
623   }
624 
625   Result operator()(const TypeParamInquiry &inq) const {
626     if (scope_.IsDerivedType() && !IsConstantExpr(inq) &&
627         inq.base() /* X%T, not local T */) { // C750, C754
628       return "non-constant reference to a type parameter inquiry not "
629              "allowed for derived type components or type parameter values";
630     }
631     return std::nullopt;
632   }
633 
634   Result operator()(const ProcedureRef &x) const {
635     bool inInquiry{false};
636     if (const auto *symbol{x.proc().GetSymbol()}) {
637       const Symbol &ultimate{symbol->GetUltimate()};
638       if (!semantics::IsPureProcedure(ultimate)) {
639         return "reference to impure function '"s + ultimate.name().ToString() +
640             "'";
641       }
642       if (semantics::IsStmtFunction(ultimate)) {
643         return "reference to statement function '"s +
644             ultimate.name().ToString() + "'";
645       }
646       if (scope_.IsDerivedType()) { // C750, C754
647         return "reference to function '"s + ultimate.name().ToString() +
648             "' not allowed for derived type components or type parameter"
649             " values";
650       }
651       if (auto procChars{
652               characteristics::Procedure::Characterize(x.proc(), context_)}) {
653         const auto iter{std::find_if(procChars->dummyArguments.begin(),
654             procChars->dummyArguments.end(),
655             [](const characteristics::DummyArgument &dummy) {
656               return std::holds_alternative<characteristics::DummyProcedure>(
657                   dummy.u);
658             })};
659         if (iter != procChars->dummyArguments.end()) {
660           return "reference to function '"s + ultimate.name().ToString() +
661               "' with dummy procedure argument '" + iter->name + '\'';
662         }
663       }
664       // References to internal functions are caught in expression semantics.
665       // TODO: other checks for standard module procedures
666     } else { // intrinsic
667       const SpecificIntrinsic &intrin{DEREF(x.proc().GetSpecificIntrinsic())};
668       inInquiry = context_.intrinsics().GetIntrinsicClass(intrin.name) ==
669           IntrinsicClass::inquiryFunction;
670       if (scope_.IsDerivedType()) { // C750, C754
671         if ((context_.intrinsics().IsIntrinsic(intrin.name) &&
672                 badIntrinsicsForComponents_.find(intrin.name) !=
673                     badIntrinsicsForComponents_.end())) {
674           return "reference to intrinsic '"s + intrin.name +
675               "' not allowed for derived type components or type parameter"
676               " values";
677         }
678         if (inInquiry && !IsConstantExpr(x)) {
679           return "non-constant reference to inquiry intrinsic '"s +
680               intrin.name +
681               "' not allowed for derived type components or type"
682               " parameter values";
683         }
684       }
685       // Type-determined inquiries (DIGITS, HUGE, &c.) will have already been
686       // folded and won't arrive here.  Inquiries that are represented with
687       // DescriptorInquiry operations (LBOUND) are checked elsewhere.  If a
688       // call that makes it to here satisfies the requirements of a constant
689       // expression (as Fortran defines it), it's fine.
690       if (IsConstantExpr(x)) {
691         return std::nullopt;
692       }
693       if (intrin.name == "present") {
694         return std::nullopt; // always ok
695       }
696       // Catch CHARACTER(:), ALLOCATABLE :: X; CHARACTER(LEN(X)) :: Y
697       if (inInquiry && x.arguments().size() >= 1) {
698         if (const auto &arg{x.arguments().at(0)}) {
699           if (auto dataRef{ExtractDataRef(*arg, true, true)}) {
700             if (intrin.name == "allocated" || intrin.name == "associated" ||
701                 intrin.name == "is_contiguous") { // ok
702             } else if (intrin.name == "len" &&
703                 IsPermissibleInquiry(dataRef->GetFirstSymbol(),
704                     dataRef->GetLastSymbol(), DescriptorInquiry::Field::Len,
705                     scope_)) { // ok
706             } else if (intrin.name == "lbound" &&
707                 IsPermissibleInquiry(dataRef->GetFirstSymbol(),
708                     dataRef->GetLastSymbol(),
709                     DescriptorInquiry::Field::LowerBound, scope_)) { // ok
710             } else if ((intrin.name == "shape" || intrin.name == "size" ||
711                            intrin.name == "sizeof" ||
712                            intrin.name == "storage_size" ||
713                            intrin.name == "ubound") &&
714                 IsPermissibleInquiry(dataRef->GetFirstSymbol(),
715                     dataRef->GetLastSymbol(), DescriptorInquiry::Field::Extent,
716                     scope_)) { // ok
717             } else {
718               return "non-constant inquiry function '"s + intrin.name +
719                   "' not allowed for local object";
720             }
721           }
722         }
723       }
724     }
725     auto restorer{common::ScopedSet(inInquiry_, inInquiry)};
726     return (*this)(x.arguments());
727   }
728 
729 private:
730   const semantics::Scope &scope_;
731   FoldingContext &context_;
732   // Contextual information: this flag is true when in an argument to
733   // an inquiry intrinsic like SIZE().
734   mutable bool inInquiry_{false};
735   const std::set<std::string> badIntrinsicsForComponents_{
736       "allocated", "associated", "extends_type_of", "present", "same_type_as"};
737 };
738 
739 template <typename A>
740 void CheckSpecificationExpr(
741     const A &x, const semantics::Scope &scope, FoldingContext &context) {
742   if (auto why{CheckSpecificationExprHelper{scope, context}(x)}) {
743     context.messages().Say(
744         "Invalid specification expression: %s"_err_en_US, *why);
745   }
746 }
747 
748 template void CheckSpecificationExpr(
749     const Expr<SomeType> &, const semantics::Scope &, FoldingContext &);
750 template void CheckSpecificationExpr(
751     const Expr<SomeInteger> &, const semantics::Scope &, FoldingContext &);
752 template void CheckSpecificationExpr(
753     const Expr<SubscriptInteger> &, const semantics::Scope &, FoldingContext &);
754 template void CheckSpecificationExpr(const std::optional<Expr<SomeType>> &,
755     const semantics::Scope &, FoldingContext &);
756 template void CheckSpecificationExpr(const std::optional<Expr<SomeInteger>> &,
757     const semantics::Scope &, FoldingContext &);
758 template void CheckSpecificationExpr(
759     const std::optional<Expr<SubscriptInteger>> &, const semantics::Scope &,
760     FoldingContext &);
761 
762 // IsContiguous() -- 9.5.4
763 class IsContiguousHelper
764     : public AnyTraverse<IsContiguousHelper, std::optional<bool>> {
765 public:
766   using Result = std::optional<bool>; // tri-state
767   using Base = AnyTraverse<IsContiguousHelper, Result>;
768   explicit IsContiguousHelper(FoldingContext &c) : Base{*this}, context_{c} {}
769   using Base::operator();
770 
771   template <typename T> Result operator()(const Constant<T> &) const {
772     return true;
773   }
774   Result operator()(const StaticDataObject &) const { return true; }
775   Result operator()(const semantics::Symbol &symbol) const {
776     const auto &ultimate{symbol.GetUltimate()};
777     if (ultimate.attrs().test(semantics::Attr::CONTIGUOUS)) {
778       return true;
779     } else if (!IsVariable(symbol)) {
780       return true;
781     } else if (ultimate.Rank() == 0) {
782       // Extension: accept scalars as a degenerate case of
783       // simple contiguity to allow their use in contexts like
784       // data targets in pointer assignments with remapping.
785       return true;
786     } else if (ultimate.has<semantics::AssocEntityDetails>()) {
787       return Base::operator()(ultimate); // use expr
788     } else if (semantics::IsPointer(ultimate) ||
789         semantics::IsAssumedShape(ultimate) || IsAssumedRank(ultimate)) {
790       return std::nullopt;
791     } else if (ultimate.has<semantics::ObjectEntityDetails>()) {
792       return true;
793     } else {
794       return Base::operator()(ultimate);
795     }
796   }
797 
798   Result operator()(const ArrayRef &x) const {
799     if (x.Rank() == 0) {
800       return true; // scalars considered contiguous
801     }
802     int subscriptRank{0};
803     auto baseLbounds{GetLBOUNDs(context_, x.base())};
804     auto baseUbounds{GetUBOUNDs(context_, x.base())};
805     auto subscripts{CheckSubscripts(
806         x.subscript(), subscriptRank, &baseLbounds, &baseUbounds)};
807     if (!subscripts.value_or(false)) {
808       return subscripts; // subscripts not known to be contiguous
809     } else if (subscriptRank > 0) {
810       // a(1)%b(:,:) is contiguous if and only if a(1)%b is contiguous.
811       return (*this)(x.base());
812     } else {
813       // a(:)%b(1,1) is (probably) not contiguous.
814       return std::nullopt;
815     }
816   }
817   Result operator()(const CoarrayRef &x) const {
818     int rank{0};
819     return CheckSubscripts(x.subscript(), rank).has_value();
820   }
821   Result operator()(const Component &x) const {
822     if (x.base().Rank() == 0) {
823       return (*this)(x.GetLastSymbol());
824     } else {
825       if (Result baseIsContiguous{(*this)(x.base())}) {
826         if (!*baseIsContiguous) {
827           return false;
828         }
829         // TODO could be true if base contiguous and this is only component, or
830         // if base has only one element?
831       }
832       return std::nullopt;
833     }
834   }
835   Result operator()(const ComplexPart &x) const {
836     return x.complex().Rank() == 0;
837   }
838   Result operator()(const Substring &) const { return std::nullopt; }
839 
840   Result operator()(const ProcedureRef &x) const {
841     if (auto chars{
842             characteristics::Procedure::Characterize(x.proc(), context_)}) {
843       if (chars->functionResult) {
844         const auto &result{*chars->functionResult};
845         if (!result.IsProcedurePointer()) {
846           if (result.attrs.test(
847                   characteristics::FunctionResult::Attr::Contiguous)) {
848             return true;
849           }
850           if (!result.attrs.test(
851                   characteristics::FunctionResult::Attr::Pointer)) {
852             return true;
853           }
854           if (const auto *type{result.GetTypeAndShape()};
855               type && type->Rank() == 0) {
856             return true; // pointer to scalar
857           }
858           // Must be non-CONTIGUOUS pointer to array
859         }
860       }
861     }
862     return std::nullopt;
863   }
864 
865   Result operator()(const NullPointer &) const { return true; }
866 
867 private:
868   // Returns "true" for a provably empty or simply contiguous array section;
869   // return "false" for a provably nonempty discontiguous section or for use
870   // of a vector subscript.
871   std::optional<bool> CheckSubscripts(const std::vector<Subscript> &subscript,
872       int &rank, const Shape *baseLbounds = nullptr,
873       const Shape *baseUbounds = nullptr) const {
874     bool anyTriplet{false};
875     rank = 0;
876     // Detect any provably empty dimension in this array section, which would
877     // render the whole section empty and therefore vacuously contiguous.
878     std::optional<bool> result;
879     bool mayBeEmpty{false};
880     auto dims{subscript.size()};
881     std::vector<bool> knownPartialSlice(dims, false);
882     for (auto j{dims}; j-- > 0;) {
883       std::optional<ConstantSubscript> dimLbound;
884       std::optional<ConstantSubscript> dimUbound;
885       std::optional<ConstantSubscript> dimExtent;
886       if (baseLbounds && j < baseLbounds->size()) {
887         if (const auto &lb{baseLbounds->at(j)}) {
888           dimLbound = ToInt64(Fold(context_, Expr<SubscriptInteger>{*lb}));
889         }
890       }
891       if (baseUbounds && j < baseUbounds->size()) {
892         if (const auto &ub{baseUbounds->at(j)}) {
893           dimUbound = ToInt64(Fold(context_, Expr<SubscriptInteger>{*ub}));
894         }
895       }
896       if (dimLbound && dimUbound) {
897         if (*dimLbound <= *dimUbound) {
898           dimExtent = *dimUbound - *dimLbound + 1;
899         } else {
900           // This is an empty dimension.
901           result = true;
902           dimExtent = 0;
903         }
904       }
905 
906       if (const auto *triplet{std::get_if<Triplet>(&subscript[j].u)}) {
907         ++rank;
908         if (auto stride{ToInt64(triplet->stride())}) {
909           const Expr<SubscriptInteger> *lowerBound{triplet->GetLower()};
910           const Expr<SubscriptInteger> *upperBound{triplet->GetUpper()};
911           std::optional<ConstantSubscript> lowerVal{lowerBound
912                   ? ToInt64(Fold(context_, Expr<SubscriptInteger>{*lowerBound}))
913                   : dimLbound};
914           std::optional<ConstantSubscript> upperVal{upperBound
915                   ? ToInt64(Fold(context_, Expr<SubscriptInteger>{*upperBound}))
916                   : dimUbound};
917           if (lowerVal && upperVal) {
918             if (*lowerVal < *upperVal) {
919               if (*stride < 0) {
920                 result = true; // empty dimension
921               } else if (!result && *stride > 1 &&
922                   *lowerVal + *stride <= *upperVal) {
923                 result = false; // discontiguous if not empty
924               }
925             } else if (*lowerVal > *upperVal) {
926               if (*stride > 0) {
927                 result = true; // empty dimension
928               } else if (!result && *stride < 0 &&
929                   *lowerVal + *stride >= *upperVal) {
930                 result = false; // discontiguous if not empty
931               }
932             } else {
933               mayBeEmpty = true;
934             }
935           } else {
936             mayBeEmpty = true;
937           }
938         } else {
939           mayBeEmpty = true;
940         }
941       } else if (subscript[j].Rank() > 0) {
942         ++rank;
943         if (!result) {
944           result = false; // vector subscript
945         }
946         mayBeEmpty = true;
947       } else {
948         // Scalar subscript.
949         if (dimExtent && *dimExtent > 1) {
950           knownPartialSlice[j] = true;
951         }
952       }
953     }
954     if (rank == 0) {
955       result = true; // scalar
956     }
957     if (result) {
958       return result;
959     }
960     // Not provably discontiguous at this point.
961     // Return "true" if simply contiguous, otherwise nullopt.
962     for (auto j{subscript.size()}; j-- > 0;) {
963       if (const auto *triplet{std::get_if<Triplet>(&subscript[j].u)}) {
964         auto stride{ToInt64(triplet->stride())};
965         if (!stride || stride != 1) {
966           return std::nullopt;
967         } else if (anyTriplet) {
968           if (triplet->GetLower() || triplet->GetUpper()) {
969             // all triplets before the last one must be just ":" for
970             // simple contiguity
971             return std::nullopt;
972           }
973         } else {
974           anyTriplet = true;
975         }
976         ++rank;
977       } else if (anyTriplet) {
978         // If the section cannot be empty, and this dimension's
979         // scalar subscript is known not to cover the whole
980         // dimension, then the array section is provably
981         // discontiguous.
982         return (mayBeEmpty || !knownPartialSlice[j])
983             ? std::nullopt
984             : std::make_optional(false);
985       }
986     }
987     return true; // simply contiguous
988   }
989 
990   FoldingContext &context_;
991 };
992 
993 template <typename A>
994 std::optional<bool> IsContiguous(const A &x, FoldingContext &context) {
995   return IsContiguousHelper{context}(x);
996 }
997 
998 template std::optional<bool> IsContiguous(
999     const Expr<SomeType> &, FoldingContext &);
1000 template std::optional<bool> IsContiguous(const ArrayRef &, FoldingContext &);
1001 template std::optional<bool> IsContiguous(const Substring &, FoldingContext &);
1002 template std::optional<bool> IsContiguous(const Component &, FoldingContext &);
1003 template std::optional<bool> IsContiguous(
1004     const ComplexPart &, FoldingContext &);
1005 template std::optional<bool> IsContiguous(const CoarrayRef &, FoldingContext &);
1006 template std::optional<bool> IsContiguous(const Symbol &, FoldingContext &);
1007 
1008 // IsErrorExpr()
1009 struct IsErrorExprHelper : public AnyTraverse<IsErrorExprHelper, bool> {
1010   using Result = bool;
1011   using Base = AnyTraverse<IsErrorExprHelper, Result>;
1012   IsErrorExprHelper() : Base{*this} {}
1013   using Base::operator();
1014 
1015   bool operator()(const SpecificIntrinsic &x) {
1016     return x.name == IntrinsicProcTable::InvalidName;
1017   }
1018 };
1019 
1020 template <typename A> bool IsErrorExpr(const A &x) {
1021   return IsErrorExprHelper{}(x);
1022 }
1023 
1024 template bool IsErrorExpr(const Expr<SomeType> &);
1025 
1026 // C1577
1027 // TODO: Also check C1579 & C1582 here
1028 class StmtFunctionChecker
1029     : public AnyTraverse<StmtFunctionChecker, std::optional<parser::Message>> {
1030 public:
1031   using Result = std::optional<parser::Message>;
1032   using Base = AnyTraverse<StmtFunctionChecker, Result>;
1033   StmtFunctionChecker(const Symbol &sf, FoldingContext &context)
1034       : Base{*this}, sf_{sf}, context_{context} {
1035     if (!context_.languageFeatures().IsEnabled(
1036             common::LanguageFeature::StatementFunctionExtensions)) {
1037       severity_ = parser::Severity::Error;
1038     } else if (context_.languageFeatures().ShouldWarn(
1039                    common::LanguageFeature::StatementFunctionExtensions)) {
1040       severity_ = parser::Severity::Portability;
1041     }
1042   }
1043   using Base::operator();
1044 
1045   template <typename T> Result operator()(const ArrayConstructor<T> &) const {
1046     if (severity_) {
1047       auto msg{
1048           "Statement function '%s' should not contain an array constructor"_port_en_US};
1049       msg.set_severity(*severity_);
1050       return parser::Message{sf_.name(), std::move(msg), sf_.name()};
1051     } else {
1052       return std::nullopt;
1053     }
1054   }
1055   Result operator()(const StructureConstructor &) const {
1056     if (severity_) {
1057       auto msg{
1058           "Statement function '%s' should not contain a structure constructor"_port_en_US};
1059       msg.set_severity(*severity_);
1060       return parser::Message{sf_.name(), std::move(msg), sf_.name()};
1061     } else {
1062       return std::nullopt;
1063     }
1064   }
1065   Result operator()(const TypeParamInquiry &) const {
1066     if (severity_) {
1067       auto msg{
1068           "Statement function '%s' should not contain a type parameter inquiry"_port_en_US};
1069       msg.set_severity(*severity_);
1070       return parser::Message{sf_.name(), std::move(msg), sf_.name()};
1071     } else {
1072       return std::nullopt;
1073     }
1074   }
1075   Result operator()(const ProcedureDesignator &proc) const {
1076     if (const Symbol * symbol{proc.GetSymbol()}) {
1077       const Symbol &ultimate{symbol->GetUltimate()};
1078       if (const auto *subp{
1079               ultimate.detailsIf<semantics::SubprogramDetails>()}) {
1080         if (subp->stmtFunction() && &ultimate.owner() == &sf_.owner()) {
1081           if (ultimate.name().begin() > sf_.name().begin()) {
1082             return parser::Message{sf_.name(),
1083                 "Statement function '%s' may not reference another statement function '%s' that is defined later"_err_en_US,
1084                 sf_.name(), ultimate.name()};
1085           }
1086         }
1087       }
1088       if (auto chars{
1089               characteristics::Procedure::Characterize(proc, context_)}) {
1090         if (!chars->CanBeCalledViaImplicitInterface()) {
1091           if (severity_) {
1092             auto msg{
1093                 "Statement function '%s' should not reference function '%s' that requires an explicit interface"_port_en_US};
1094             msg.set_severity(*severity_);
1095             return parser::Message{
1096                 sf_.name(), std::move(msg), sf_.name(), symbol->name()};
1097           }
1098         }
1099       }
1100     }
1101     if (proc.Rank() > 0) {
1102       if (severity_) {
1103         auto msg{
1104             "Statement function '%s' should not reference a function that returns an array"_port_en_US};
1105         msg.set_severity(*severity_);
1106         return parser::Message{sf_.name(), std::move(msg), sf_.name()};
1107       }
1108     }
1109     return std::nullopt;
1110   }
1111   Result operator()(const ActualArgument &arg) const {
1112     if (const auto *expr{arg.UnwrapExpr()}) {
1113       if (auto result{(*this)(*expr)}) {
1114         return result;
1115       }
1116       if (expr->Rank() > 0 && !UnwrapWholeSymbolOrComponentDataRef(*expr)) {
1117         if (severity_) {
1118           auto msg{
1119               "Statement function '%s' should not pass an array argument that is not a whole array"_port_en_US};
1120           msg.set_severity(*severity_);
1121           return parser::Message{sf_.name(), std::move(msg), sf_.name()};
1122         }
1123       }
1124     }
1125     return std::nullopt;
1126   }
1127 
1128 private:
1129   const Symbol &sf_;
1130   FoldingContext &context_;
1131   std::optional<parser::Severity> severity_;
1132 };
1133 
1134 std::optional<parser::Message> CheckStatementFunction(
1135     const Symbol &sf, const Expr<SomeType> &expr, FoldingContext &context) {
1136   return StmtFunctionChecker{sf, context}(expr);
1137 }
1138 
1139 } // namespace Fortran::evaluate
1140