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 ¶m) 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