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