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
21namespace 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.
32template <bool INVARIANT>
33class IsConstantExprHelper
34 : public AllTraverse<IsConstantExprHelper<INVARIANT>, true> {
35public:
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 // Prevent integer division by known zeroes in constant expressions.
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 ((*this)(division.left()) && (*this)(division.right())) {
78 const auto divisor{GetScalarConstantValue<T>(division.right())};
79 return !divisor || !divisor->IsZero();
80 } else {
81 return false;
82 }
83 }
84
85 bool operator()(const Constant<SomeDerived> &) const { return true; }
86 bool operator()(const DescriptorInquiry &x) const {
87 const Symbol &sym{x.base().GetLastSymbol()};
88 return INVARIANT && !IsAllocatable(sym) &&
89 (!IsDummy(sym) ||
90 (IsIntentIn(sym) && !IsOptional(sym) &&
91 !sym.attrs().test(semantics::Attr::VALUE)));
92 }
93
94private:
95 bool IsConstantStructureConstructorComponent(
96 const Symbol &, const Expr<SomeType> &) const;
97 bool IsConstantExprShape(const Shape &) const;
98};
99
100template <bool INVARIANT>
101bool IsConstantExprHelper<INVARIANT>::IsConstantStructureConstructorComponent(
102 const Symbol &component, const Expr<SomeType> &expr) const {
103 if (IsAllocatable(component)) {
104 return IsNullObjectPointer(&expr);
105 } else if (IsPointer(component)) {
106 return IsNullPointerOrAllocatable(&expr) || IsInitialDataTarget(expr) ||
107 IsInitialProcedureTarget(expr);
108 } else {
109 return (*this)(expr);
110 }
111}
112
113template <bool INVARIANT>
114bool IsConstantExprHelper<INVARIANT>::operator()(
115 const ProcedureRef &call) const {
116 // LBOUND, UBOUND, and SIZE with truly constant DIM= arguments will have
117 // been rewritten into DescriptorInquiry operations.
118 if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&call.proc().u)}) {
119 const characteristics::Procedure &proc{intrinsic->characteristics.value()};
120 if (intrinsic->name == "kind" ||
121 intrinsic->name == IntrinsicProcTable::InvalidName ||
122 call.arguments().empty() || !call.arguments()[0]) {
123 // kind is always a constant, and we avoid cascading errors by considering
124 // invalid calls to intrinsics to be constant
125 return true;
126 } else if (intrinsic->name == "lbound") {
127 auto base{ExtractNamedEntity(call.arguments()[0]->UnwrapExpr())};
128 return base && IsConstantExprShape(GetLBOUNDs(*base));
129 } else if (intrinsic->name == "ubound") {
130 auto base{ExtractNamedEntity(call.arguments()[0]->UnwrapExpr())};
131 return base && IsConstantExprShape(GetUBOUNDs(*base));
132 } else if (intrinsic->name == "shape" || intrinsic->name == "size") {
133 auto shape{GetShape(call.arguments()[0]->UnwrapExpr())};
134 return shape && IsConstantExprShape(*shape);
135 } else if (proc.IsPure()) {
136 std::size_t j{0};
137 for (const auto &arg : call.arguments()) {
138 if (const auto *dataDummy{j < proc.dummyArguments.size()
139 ? std::get_if<characteristics::DummyDataObject>(
140 &proc.dummyArguments[j].u)
141 : nullptr};
142 dataDummy &&
143 dataDummy->attrs.test(
144 characteristics::DummyDataObject::Attr::OnlyIntrinsicInquiry)) {
145 // The value of the argument doesn't matter
146 } else if (!arg) {
147 return false;
148 } else if (const auto *expr{arg->UnwrapExpr()};
149 !expr || !(*this)(*expr)) {
150 return false;
151 }
152 ++j;
153 }
154 return true;
155 }
156 // TODO: STORAGE_SIZE
157 }
158 return false;
159}
160
161template <bool INVARIANT>
162bool IsConstantExprHelper<INVARIANT>::IsConstantExprShape(
163 const Shape &shape) const {
164 for (const auto &extent : shape) {
165 if (!(*this)(extent)) {
166 return false;
167 }
168 }
169 return true;
170}
171
172template <typename A> bool IsConstantExpr(const A &x) {
173 return IsConstantExprHelper<false>{}(x);
174}
175template bool IsConstantExpr(const Expr<SomeType> &);
176template bool IsConstantExpr(const Expr<SomeInteger> &);
177template bool IsConstantExpr(const Expr<SubscriptInteger> &);
178template bool IsConstantExpr(const StructureConstructor &);
179
180// IsScopeInvariantExpr()
181template <typename A> bool IsScopeInvariantExpr(const A &x) {
182 return IsConstantExprHelper<true>{}(x);
183}
184template bool IsScopeInvariantExpr(const Expr<SomeType> &);
185template bool IsScopeInvariantExpr(const Expr<SomeInteger> &);
186template bool IsScopeInvariantExpr(const Expr<SubscriptInteger> &);
187
188// IsActuallyConstant()
189struct IsActuallyConstantHelper {
190 template <typename A> bool operator()(const A &) { return false; }
191 template <typename T> bool operator()(const Constant<T> &) { return true; }
192 template <typename T> bool operator()(const Parentheses<T> &x) {
193 return (*this)(x.left());
194 }
195 template <typename T> bool operator()(const Expr<T> &x) {
196 return common::visit([=](const auto &y) { return (*this)(y); }, x.u);
197 }
198 bool operator()(const Expr<SomeType> &x) {
199 return common::visit([this](const auto &y) { return (*this)(y); }, x.u);
200 }
201 bool operator()(const StructureConstructor &x) {
202 for (const auto &pair : x) {
203 const Expr<SomeType> &y{pair.second.value()};
204 const auto sym{pair.first};
205 const bool compIsConstant{(*this)(y)};
206 // If an allocatable component is initialized by a constant,
207 // the structure constructor is not a constant.
208 if ((!compIsConstant && !IsNullPointerOrAllocatable(&y)) ||
209 (compIsConstant && IsAllocatable(sym))) {
210 return false;
211 }
212 }
213 return true;
214 }
215 template <typename A> bool operator()(const A *x) { return x && (*this)(*x); }
216 template <typename A> bool operator()(const std::optional<A> &x) {
217 return x && (*this)(*x);
218 }
219};
220
221template <typename A> bool IsActuallyConstant(const A &x) {
222 return IsActuallyConstantHelper{}(x);
223}
224
225template bool IsActuallyConstant(const Expr<SomeType> &);
226template bool IsActuallyConstant(const Expr<SomeInteger> &);
227template bool IsActuallyConstant(const Expr<SubscriptInteger> &);
228template bool IsActuallyConstant(const std::optional<Expr<SubscriptInteger>> &);
229
230// Object pointer initialization checking predicate IsInitialDataTarget().
231// This code determines whether an expression is allowable as the static
232// data address used to initialize a pointer with "=> x". See C765.
233class IsInitialDataTargetHelper
234 : public AllTraverse<IsInitialDataTargetHelper, true> {
235public:
236 using Base = AllTraverse<IsInitialDataTargetHelper, true>;
237 using Base::operator();
238 explicit IsInitialDataTargetHelper(parser::ContextualMessages *m)
239 : Base{*this}, messages_{m} {}
240
241 bool emittedMessage() const { return emittedMessage_; }
242
243 bool operator()(const BOZLiteralConstant &) const { return false; }
244 bool operator()(const NullPointer &) const { return true; }
245 template <typename T> bool operator()(const Constant<T> &) const {
246 return false;
247 }
248 bool operator()(const semantics::Symbol &symbol) {
249 // This function checks only base symbols, not components.
250 const Symbol &ultimate{symbol.GetUltimate()};
251 if (const auto *assoc{
252 ultimate.detailsIf<semantics::AssocEntityDetails>()}) {
253 if (const auto &expr{assoc->expr()}) {
254 if (IsVariable(*expr)) {
255 return (*this)(*expr);
256 } else if (messages_) {
257 messages_->Say(
258 "An initial data target may not be an associated expression ('%s')"_err_en_US,
259 ultimate.name());
260 emittedMessage_ = true;
261 }
262 }
263 return false;
264 } else if (!CheckVarOrComponent(ultimate)) {
265 return false;
266 } else if (!ultimate.attrs().test(semantics::Attr::TARGET)) {
267 if (messages_) {
268 messages_->Say(
269 "An initial data target may not be a reference to an object '%s' that lacks the TARGET attribute"_err_en_US,
270 ultimate.name());
271 emittedMessage_ = true;
272 }
273 return false;
274 } else if (!IsSaved(ultimate)) {
275 if (messages_) {
276 messages_->Say(
277 "An initial data target may not be a reference to an object '%s' that lacks the SAVE attribute"_err_en_US,
278 ultimate.name());
279 emittedMessage_ = true;
280 }
281 return false;
282 } else {
283 return true;
284 }
285 }
286 bool operator()(const StaticDataObject &) const { return false; }
287 bool operator()(const TypeParamInquiry &) const { return false; }
288 bool operator()(const Triplet &x) const {
289 return IsConstantExpr(x.lower()) && IsConstantExpr(x.upper()) &&
290 IsConstantExpr(x.stride());
291 }
292 bool operator()(const Subscript &x) const {
293 return common::visit(common::visitors{
294 [&](const Triplet &t) { return (*this)(t); },
295 [&](const auto &y) {
296 return y.value().Rank() == 0 &&
297 IsConstantExpr(y.value());
298 },
299 },
300 x.u);
301 }
302 bool operator()(const CoarrayRef &) const { return false; }
303 bool operator()(const Component &x) {
304 return CheckVarOrComponent(x.GetLastSymbol()) && (*this)(x.base());
305 }
306 bool operator()(const Substring &x) const {
307 return IsConstantExpr(x.lower()) && IsConstantExpr(x.upper()) &&
308 (*this)(x.parent());
309 }
310 bool operator()(const DescriptorInquiry &) const { return false; }
311 template <typename T> bool operator()(const ArrayConstructor<T> &) const {
312 return false;
313 }
314 bool operator()(const StructureConstructor &) const { return false; }
315 template <typename D, typename R, typename... O>
316 bool operator()(const Operation<D, R, O...> &) const {
317 return false;
318 }
319 template <typename T> bool operator()(const Parentheses<T> &x) const {
320 return (*this)(x.left());
321 }
322 bool operator()(const ProcedureRef &x) const {
323 if (const SpecificIntrinsic * intrinsic{x.proc().GetSpecificIntrinsic()}) {
324 return intrinsic->characteristics.value().attrs.test(
325 characteristics::Procedure::Attr::NullPointer) ||
326 intrinsic->characteristics.value().attrs.test(
327 characteristics::Procedure::Attr::NullAllocatable);
328 }
329 return false;
330 }
331 bool operator()(const Relational<SomeType> &) const { return false; }
332
333private:
334 bool CheckVarOrComponent(const semantics::Symbol &symbol) {
335 const Symbol &ultimate{symbol.GetUltimate()};
336 const char *unacceptable{nullptr};
337 if (ultimate.Corank() > 0) {
338 unacceptable = "a coarray";
339 } else if (IsAllocatable(ultimate)) {
340 unacceptable = "an ALLOCATABLE";
341 } else if (IsPointer(ultimate)) {
342 unacceptable = "a POINTER";
343 } else {
344 return true;
345 }
346 if (messages_) {
347 messages_->Say(
348 "An initial data target may not be a reference to %s '%s'"_err_en_US,
349 unacceptable, ultimate.name());
350 emittedMessage_ = true;
351 }
352 return false;
353 }
354
355 parser::ContextualMessages *messages_;
356 bool emittedMessage_{false};
357};
358
359bool IsInitialDataTarget(
360 const Expr<SomeType> &x, parser::ContextualMessages *messages) {
361 IsInitialDataTargetHelper helper{messages};
362 bool result{helper(x)};
363 if (!result && messages && !helper.emittedMessage()) {
364 messages->Say(
365 "An initial data target must be a designator with constant subscripts"_err_en_US);
366 }
367 return result;
368}
369
370bool IsInitialProcedureTarget(const semantics::Symbol &symbol) {
371 const auto &ultimate{symbol.GetUltimate()};
372 return common::visit(
373 common::visitors{
374 [&](const semantics::SubprogramDetails &subp) {
375 return !subp.isDummy() && !subp.stmtFunction() &&
376 symbol.owner().kind() != semantics::Scope::Kind::MainProgram &&
377 symbol.owner().kind() != semantics::Scope::Kind::Subprogram;
378 },
379 [](const semantics::SubprogramNameDetails &x) {
380 return x.kind() != semantics::SubprogramKind::Internal;
381 },
382 [&](const semantics::ProcEntityDetails &proc) {
383 return !semantics::IsPointer(ultimate) && !proc.isDummy();
384 },
385 [](const auto &) { return false; },
386 },
387 ultimate.details());
388}
389
390bool IsInitialProcedureTarget(const ProcedureDesignator &proc) {
391 if (const auto *intrin{proc.GetSpecificIntrinsic()}) {
392 return !intrin->isRestrictedSpecific;
393 } else if (proc.GetComponent()) {
394 return false;
395 } else {
396 return IsInitialProcedureTarget(DEREF(proc.GetSymbol()));
397 }
398}
399
400bool IsInitialProcedureTarget(const Expr<SomeType> &expr) {
401 if (const auto *proc{std::get_if<ProcedureDesignator>(&expr.u)}) {
402 return IsInitialProcedureTarget(*proc);
403 } else {
404 return IsNullProcedurePointer(&expr);
405 }
406}
407
408// Converts, folds, and then checks type, rank, and shape of an
409// initialization expression for a named constant, a non-pointer
410// variable static initialization, a component default initializer,
411// a type parameter default value, or instantiated type parameter value.
412std::optional<Expr<SomeType>> NonPointerInitializationExpr(const Symbol &symbol,
413 Expr<SomeType> &&x, FoldingContext &context,
414 const semantics::Scope *instantiation) {
415 CHECK(!IsPointer(symbol));
416 if (auto symTS{
417 characteristics::TypeAndShape::Characterize(symbol, context)}) {
418 auto xType{x.GetType()};
419 auto converted{ConvertToType(symTS->type(), Expr<SomeType>{x})};
420 if (!converted &&
421 symbol.owner().context().IsEnabled(
422 common::LanguageFeature::LogicalIntegerAssignment)) {
423 converted = DataConstantConversionExtension(context, symTS->type(), x);
424 if (converted &&
425 symbol.owner().context().ShouldWarn(
426 common::LanguageFeature::LogicalIntegerAssignment)) {
427 context.messages().Say(
428 common::LanguageFeature::LogicalIntegerAssignment,
429 "nonstandard usage: initialization of %s with %s"_port_en_US,
430 symTS->type().AsFortran(), x.GetType().value().AsFortran());
431 }
432 }
433 if (converted) {
434 auto folded{Fold(context, std::move(*converted))};
435 if (IsActuallyConstant(folded)) {
436 int symRank{symTS->Rank()};
437 if (IsImpliedShape(symbol)) {
438 if (folded.Rank() == symRank) {
439 return ArrayConstantBoundChanger{
440 std::move(*AsConstantExtents(
441 context, GetRawLowerBounds(context, NamedEntity{symbol})))}
442 .ChangeLbounds(std::move(folded));
443 } else {
444 context.messages().Say(
445 "Implied-shape parameter '%s' has rank %d but its initializer has rank %d"_err_en_US,
446 symbol.name(), symRank, folded.Rank());
447 }
448 } else if (auto extents{AsConstantExtents(context, symTS->shape())};
449 extents && !HasNegativeExtent(*extents)) {
450 if (folded.Rank() == 0 && symRank == 0) {
451 // symbol and constant are both scalars
452 return {std::move(folded)};
453 } else if (folded.Rank() == 0 && symRank > 0) {
454 // expand the scalar constant to an array
455 return ScalarConstantExpander{std::move(*extents),
456 AsConstantExtents(
457 context, GetRawLowerBounds(context, NamedEntity{symbol}))}
458 .Expand(std::move(folded));
459 } else if (auto resultShape{GetShape(context, folded)}) {
460 CHECK(symTS->shape()); // Assumed-ranks cannot be initialized.
461 if (CheckConformance(context.messages(), *symTS->shape(),
462 *resultShape, CheckConformanceFlags::None,
463 "initialized object", "initialization expression")
464 .value_or(false /*fail if not known now to conform*/)) {
465 // make a constant array with adjusted lower bounds
466 return ArrayConstantBoundChanger{
467 std::move(*AsConstantExtents(context,
468 GetRawLowerBounds(context, NamedEntity{symbol})))}
469 .ChangeLbounds(std::move(folded));
470 }
471 }
472 } else if (IsNamedConstant(symbol)) {
473 if (IsExplicitShape(symbol)) {
474 context.messages().Say(
475 "Named constant '%s' array must have constant shape"_err_en_US,
476 symbol.name());
477 } else {
478 // Declaration checking handles other cases
479 }
480 } else {
481 context.messages().Say(
482 "Shape of initialized object '%s' must be constant"_err_en_US,
483 symbol.name());
484 }
485 } else if (IsErrorExpr(folded)) {
486 } else if (IsLenTypeParameter(symbol)) {
487 return {std::move(folded)};
488 } else if (IsKindTypeParameter(symbol)) {
489 if (instantiation) {
490 context.messages().Say(
491 "Value of kind type parameter '%s' (%s) must be a scalar INTEGER constant"_err_en_US,
492 symbol.name(), folded.AsFortran());
493 } else {
494 return {std::move(folded)};
495 }
496 } else if (IsNamedConstant(symbol)) {
497 if (symbol.name() == "numeric_storage_size" &&
498 symbol.owner().IsModule() &&
499 DEREF(symbol.owner().symbol()).name() == "iso_fortran_env") {
500 // Very special case: numeric_storage_size is not folded until
501 // it read from the iso_fortran_env module file, as its value
502 // depends on compilation options.
503 return {std::move(folded)};
504 }
505 context.messages().Say(
506 "Value of named constant '%s' (%s) cannot be computed as a constant value"_err_en_US,
507 symbol.name(), folded.AsFortran());
508 } else {
509 context.messages().Say(
510 "Initialization expression for '%s' (%s) cannot be computed as a constant value"_err_en_US,
511 symbol.name(), x.AsFortran());
512 }
513 } else if (xType) {
514 context.messages().Say(
515 "Initialization expression cannot be converted to declared type of '%s' from %s"_err_en_US,
516 symbol.name(), xType->AsFortran());
517 } else {
518 context.messages().Say(
519 "Initialization expression cannot be converted to declared type of '%s'"_err_en_US,
520 symbol.name());
521 }
522 }
523 return std::nullopt;
524}
525
526// Specification expression validation (10.1.11(2), C1010)
527class CheckSpecificationExprHelper
528 : public AnyTraverse<CheckSpecificationExprHelper,
529 std::optional<std::string>> {
530public:
531 using Result = std::optional<std::string>;
532 using Base = AnyTraverse<CheckSpecificationExprHelper, Result>;
533 explicit CheckSpecificationExprHelper(const semantics::Scope &s,
534 FoldingContext &context, bool forElementalFunctionResult)
535 : Base{*this}, scope_{s}, context_{context},
536 forElementalFunctionResult_{forElementalFunctionResult} {}
537 using Base::operator();
538
539 Result operator()(const CoarrayRef &) const { return "coindexed reference"; }
540
541 Result operator()(const semantics::Symbol &symbol) const {
542 const auto &ultimate{symbol.GetUltimate()};
543 const auto *object{ultimate.detailsIf<semantics::ObjectEntityDetails>()};
544 bool isInitialized{semantics::IsSaved(ultimate) &&
545 !IsAllocatable(ultimate) && object &&
546 (ultimate.test(Symbol::Flag::InDataStmt) ||
547 object->init().has_value())};
548 bool hasHostAssociation{
549 &symbol.owner() != &scope_ || &ultimate.owner() != &scope_};
550 if (const auto *assoc{
551 ultimate.detailsIf<semantics::AssocEntityDetails>()}) {
552 return (*this)(assoc->expr());
553 } else if (semantics::IsNamedConstant(ultimate) ||
554 ultimate.owner().IsModule() || ultimate.owner().IsSubmodule()) {
555 return std::nullopt;
556 } else if (scope_.IsDerivedType() &&
557 IsVariableName(ultimate)) { // C750, C754
558 return "derived type component or type parameter value not allowed to "
559 "reference variable '"s +
560 ultimate.name().ToString() + "'";
561 } else if (IsDummy(ultimate)) {
562 if (!inInquiry_ && forElementalFunctionResult_) {
563 return "dependence on value of dummy argument '"s +
564 ultimate.name().ToString() + "'";
565 } else if (ultimate.attrs().test(semantics::Attr::OPTIONAL)) {
566 return "reference to OPTIONAL dummy argument '"s +
567 ultimate.name().ToString() + "'";
568 } else if (!inInquiry_ && !hasHostAssociation &&
569 ultimate.attrs().test(semantics::Attr::INTENT_OUT)) {
570 return "reference to INTENT(OUT) dummy argument '"s +
571 ultimate.name().ToString() + "'";
572 } else if (!ultimate.has<semantics::ObjectEntityDetails>()) {
573 return "dummy procedure argument";
574 } else {
575 // Sketchy case: some compilers allow an INTENT(OUT) dummy argument
576 // to be used in a specification expression if it is host-associated.
577 // The arguments raised in support this usage, however, depend on
578 // a reading of the standard that would also accept an OPTIONAL
579 // host-associated dummy argument, and that doesn't seem like a
580 // good idea.
581 if (!inInquiry_ && hasHostAssociation &&
582 ultimate.attrs().test(semantics::Attr::INTENT_OUT) &&
583 context_.languageFeatures().ShouldWarn(
584 common::UsageWarning::HostAssociatedIntentOutInSpecExpr)) {
585 context_.messages().Say(
586 "specification expression refers to host-associated INTENT(OUT) dummy argument '%s'"_port_en_US,
587 ultimate.name());
588 }
589 return std::nullopt;
590 }
591 } else if (hasHostAssociation) {
592 return std::nullopt; // host association is in play
593 } else if (isInitialized &&
594 context_.languageFeatures().IsEnabled(
595 common::LanguageFeature::SavedLocalInSpecExpr)) {
596 if (!scope_.IsModuleFile() &&
597 context_.languageFeatures().ShouldWarn(
598 common::LanguageFeature::SavedLocalInSpecExpr)) {
599 context_.messages().Say(common::LanguageFeature::SavedLocalInSpecExpr,
600 "specification expression refers to local object '%s' (initialized and saved)"_port_en_US,
601 ultimate.name());
602 }
603 return std::nullopt;
604 } else if (const auto *object{
605 ultimate.detailsIf<semantics::ObjectEntityDetails>()}) {
606 if (object->commonBlock()) {
607 return std::nullopt;
608 }
609 }
610 if (inInquiry_) {
611 return std::nullopt;
612 } else {
613 return "reference to local entity '"s + ultimate.name().ToString() + "'";
614 }
615 }
616
617 Result operator()(const Component &x) const {
618 // Don't look at the component symbol.
619 return (*this)(x.base());
620 }
621 Result operator()(const ArrayRef &x) const {
622 if (auto result{(*this)(x.base())}) {
623 return result;
624 }
625 // The subscripts don't get special protection for being in a
626 // specification inquiry context;
627 auto restorer{common::ScopedSet(inInquiry_, false)};
628 return (*this)(x.subscript());
629 }
630 Result operator()(const Substring &x) const {
631 if (auto result{(*this)(x.parent())}) {
632 return result;
633 }
634 // The bounds don't get special protection for being in a
635 // specification inquiry context;
636 auto restorer{common::ScopedSet(inInquiry_, false)};
637 if (auto result{(*this)(x.lower())}) {
638 return result;
639 }
640 return (*this)(x.upper());
641 }
642 Result operator()(const DescriptorInquiry &x) const {
643 // Many uses of SIZE(), LBOUND(), &c. that are valid in specification
644 // expressions will have been converted to expressions over descriptor
645 // inquiries by Fold().
646 // Catch REAL, ALLOCATABLE :: X(:); REAL :: Y(SIZE(X))
647 if (IsPermissibleInquiry(
648 x.base().GetFirstSymbol(), x.base().GetLastSymbol(), x.field())) {
649 auto restorer{common::ScopedSet(inInquiry_, true)};
650 return (*this)(x.base());
651 } else if (IsConstantExpr(x)) {
652 return std::nullopt;
653 } else {
654 return "non-constant descriptor inquiry not allowed for local object";
655 }
656 }
657
658 Result operator()(const TypeParamInquiry &inq) const {
659 if (scope_.IsDerivedType()) {
660 if (!IsConstantExpr(inq) &&
661 inq.base() /* X%T, not local T */) { // C750, C754
662 return "non-constant reference to a type parameter inquiry not allowed "
663 "for derived type components or type parameter values";
664 }
665 } else if (inq.base() &&
666 IsInquiryAlwaysPermissible(inq.base()->GetFirstSymbol())) {
667 auto restorer{common::ScopedSet(inInquiry_, true)};
668 return (*this)(inq.base());
669 } else if (!IsConstantExpr(inq)) {
670 return "non-constant type parameter inquiry not allowed for local object";
671 }
672 return std::nullopt;
673 }
674
675 Result operator()(const ProcedureRef &x) const {
676 if (const auto *symbol{x.proc().GetSymbol()}) {
677 const Symbol &ultimate{symbol->GetUltimate()};
678 if (!semantics::IsPureProcedure(ultimate)) {
679 return "reference to impure function '"s + ultimate.name().ToString() +
680 "'";
681 }
682 if (semantics::IsStmtFunction(ultimate)) {
683 return "reference to statement function '"s +
684 ultimate.name().ToString() + "'";
685 }
686 if (scope_.IsDerivedType()) { // C750, C754
687 return "reference to function '"s + ultimate.name().ToString() +
688 "' not allowed for derived type components or type parameter"
689 " values";
690 }
691 if (auto procChars{characteristics::Procedure::Characterize(
692 x.proc(), context_, /*emitError=*/true)}) {
693 const auto iter{std::find_if(procChars->dummyArguments.begin(),
694 procChars->dummyArguments.end(),
695 [](const characteristics::DummyArgument &dummy) {
696 return std::holds_alternative<characteristics::DummyProcedure>(
697 dummy.u);
698 })};
699 if (iter != procChars->dummyArguments.end() &&
700 ultimate.name().ToString() != "__builtin_c_funloc") {
701 return "reference to function '"s + ultimate.name().ToString() +
702 "' with dummy procedure argument '" + iter->name + '\'';
703 }
704 }
705 // References to internal functions are caught in expression semantics.
706 // TODO: other checks for standard module procedures
707 auto restorer{common::ScopedSet(inInquiry_, false)};
708 return (*this)(x.arguments());
709 } else { // intrinsic
710 const SpecificIntrinsic &intrin{DEREF(x.proc().GetSpecificIntrinsic())};
711 bool inInquiry{context_.intrinsics().GetIntrinsicClass(intrin.name) ==
712 IntrinsicClass::inquiryFunction};
713 if (scope_.IsDerivedType()) { // C750, C754
714 if ((context_.intrinsics().IsIntrinsic(intrin.name) &&
715 badIntrinsicsForComponents_.find(intrin.name) !=
716 badIntrinsicsForComponents_.end())) {
717 return "reference to intrinsic '"s + intrin.name +
718 "' not allowed for derived type components or type parameter"
719 " values";
720 }
721 if (inInquiry && !IsConstantExpr(x)) {
722 return "non-constant reference to inquiry intrinsic '"s +
723 intrin.name +
724 "' not allowed for derived type components or type"
725 " parameter values";
726 }
727 }
728 // Type-determined inquiries (DIGITS, HUGE, &c.) will have already been
729 // folded and won't arrive here. Inquiries that are represented with
730 // DescriptorInquiry operations (LBOUND) are checked elsewhere. If a
731 // call that makes it to here satisfies the requirements of a constant
732 // expression (as Fortran defines it), it's fine.
733 if (IsConstantExpr(x)) {
734 return std::nullopt;
735 }
736 if (intrin.name == "present") {
737 return std::nullopt; // always ok
738 }
739 const auto &proc{intrin.characteristics.value()};
740 std::size_t j{0};
741 for (const auto &arg : x.arguments()) {
742 bool checkArg{true};
743 if (const auto *dataDummy{j < proc.dummyArguments.size()
744 ? std::get_if<characteristics::DummyDataObject>(
745 &proc.dummyArguments[j].u)
746 : nullptr}) {
747 if (dataDummy->attrs.test(characteristics::DummyDataObject::Attr::
748 OnlyIntrinsicInquiry)) {
749 checkArg = false; // value unused, e.g. IEEE_SUPPORT_FLAG(,,,. X)
750 }
751 }
752 if (arg && checkArg) {
753 // Catch CHARACTER(:), ALLOCATABLE :: X; CHARACTER(LEN(X)) :: Y
754 if (inInquiry) {
755 if (auto dataRef{ExtractDataRef(*arg, true, true)}) {
756 if (intrin.name == "allocated" || intrin.name == "associated" ||
757 intrin.name == "is_contiguous") { // ok
758 } else if (intrin.name == "len" &&
759 IsPermissibleInquiry(dataRef->GetFirstSymbol(),
760 dataRef->GetLastSymbol(),
761 DescriptorInquiry::Field::Len)) { // ok
762 } else if (intrin.name == "lbound" &&
763 IsPermissibleInquiry(dataRef->GetFirstSymbol(),
764 dataRef->GetLastSymbol(),
765 DescriptorInquiry::Field::LowerBound)) { // ok
766 } else if ((intrin.name == "shape" || intrin.name == "size" ||
767 intrin.name == "sizeof" ||
768 intrin.name == "storage_size" ||
769 intrin.name == "ubound") &&
770 IsPermissibleInquiry(dataRef->GetFirstSymbol(),
771 dataRef->GetLastSymbol(),
772 DescriptorInquiry::Field::Extent)) { // ok
773 } else {
774 return "non-constant inquiry function '"s + intrin.name +
775 "' not allowed for local object";
776 }
777 }
778 }
779 auto restorer{common::ScopedSet(inInquiry_, inInquiry)};
780 if (auto err{(*this)(*arg)}) {
781 return err;
782 }
783 }
784 ++j;
785 }
786 return std::nullopt;
787 }
788 }
789
790private:
791 const semantics::Scope &scope_;
792 FoldingContext &context_;
793 // Contextual information: this flag is true when in an argument to
794 // an inquiry intrinsic like SIZE().
795 mutable bool inInquiry_{false};
796 bool forElementalFunctionResult_{false}; // F'2023 C15121
797 const std::set<std::string> badIntrinsicsForComponents_{
798 "allocated", "associated", "extends_type_of", "present", "same_type_as"};
799
800 bool IsInquiryAlwaysPermissible(const semantics::Symbol &) const;
801 bool IsPermissibleInquiry(const semantics::Symbol &firstSymbol,
802 const semantics::Symbol &lastSymbol,
803 DescriptorInquiry::Field field) const;
804};
805
806bool CheckSpecificationExprHelper::IsInquiryAlwaysPermissible(
807 const semantics::Symbol &symbol) const {
808 if (&symbol.owner() != &scope_ || symbol.has<semantics::UseDetails>() ||
809 symbol.owner().kind() == semantics::Scope::Kind::Module ||
810 semantics::FindCommonBlockContaining(symbol) ||
811 symbol.has<semantics::HostAssocDetails>()) {
812 return true; // it's nonlocal
813 } else if (semantics::IsDummy(symbol) && !forElementalFunctionResult_) {
814 return true;
815 } else {
816 return false;
817 }
818}
819
820bool CheckSpecificationExprHelper::IsPermissibleInquiry(
821 const semantics::Symbol &firstSymbol, const semantics::Symbol &lastSymbol,
822 DescriptorInquiry::Field field) const {
823 if (IsInquiryAlwaysPermissible(firstSymbol)) {
824 return true;
825 }
826 // Inquiries on local objects may not access a deferred bound or length.
827 // (This code used to be a switch, but it proved impossible to write it
828 // thus without running afoul of bogus warnings from different C++
829 // compilers.)
830 if (field == DescriptorInquiry::Field::Rank) {
831 return true; // always known
832 }
833 const auto *object{lastSymbol.detailsIf<semantics::ObjectEntityDetails>()};
834 if (field == DescriptorInquiry::Field::LowerBound ||
835 field == DescriptorInquiry::Field::Extent ||
836 field == DescriptorInquiry::Field::Stride) {
837 return object && !object->shape().CanBeDeferredShape();
838 }
839 if (field == DescriptorInquiry::Field::Len) {
840 return object && object->type() &&
841 object->type()->category() == semantics::DeclTypeSpec::Character &&
842 !object->type()->characterTypeSpec().length().isDeferred();
843 }
844 return false;
845}
846
847template <typename A>
848void CheckSpecificationExpr(const A &x, const semantics::Scope &scope,
849 FoldingContext &context, bool forElementalFunctionResult) {
850 CheckSpecificationExprHelper errors{
851 scope, context, forElementalFunctionResult};
852 if (auto why{errors(x)}) {
853 context.messages().Say("Invalid specification expression%s: %s"_err_en_US,
854 forElementalFunctionResult ? " for elemental function result" : "",
855 *why);
856 }
857}
858
859template void CheckSpecificationExpr(const Expr<SomeType> &,
860 const semantics::Scope &, FoldingContext &,
861 bool forElementalFunctionResult);
862template void CheckSpecificationExpr(const Expr<SomeInteger> &,
863 const semantics::Scope &, FoldingContext &,
864 bool forElementalFunctionResult);
865template void CheckSpecificationExpr(const Expr<SubscriptInteger> &,
866 const semantics::Scope &, FoldingContext &,
867 bool forElementalFunctionResult);
868template void CheckSpecificationExpr(const std::optional<Expr<SomeType>> &,
869 const semantics::Scope &, FoldingContext &,
870 bool forElementalFunctionResult);
871template void CheckSpecificationExpr(const std::optional<Expr<SomeInteger>> &,
872 const semantics::Scope &, FoldingContext &,
873 bool forElementalFunctionResult);
874template void CheckSpecificationExpr(
875 const std::optional<Expr<SubscriptInteger>> &, const semantics::Scope &,
876 FoldingContext &, bool forElementalFunctionResult);
877
878// IsContiguous() -- 9.5.4
879class IsContiguousHelper
880 : public AnyTraverse<IsContiguousHelper, std::optional<bool>> {
881public:
882 using Result = std::optional<bool>; // tri-state
883 using Base = AnyTraverse<IsContiguousHelper, Result>;
884 explicit IsContiguousHelper(FoldingContext &c,
885 bool namedConstantSectionsAreContiguous,
886 bool firstDimensionStride1 = false)
887 : Base{*this}, context_{c},
888 namedConstantSectionsAreContiguous_{namedConstantSectionsAreContiguous},
889 firstDimensionStride1_{firstDimensionStride1} {}
890 using Base::operator();
891
892 template <typename T> Result operator()(const Constant<T> &) const {
893 return true;
894 }
895 Result operator()(const StaticDataObject &) const { return true; }
896 Result operator()(const semantics::Symbol &symbol) const {
897 const auto &ultimate{symbol.GetUltimate()};
898 if (ultimate.attrs().test(semantics::Attr::CONTIGUOUS)) {
899 return true;
900 } else if (!IsVariable(symbol)) {
901 return true;
902 } else if (ultimate.Rank() == 0) {
903 // Extension: accept scalars as a degenerate case of
904 // simple contiguity to allow their use in contexts like
905 // data targets in pointer assignments with remapping.
906 return true;
907 } else if (const auto *details{
908 ultimate.detailsIf<semantics::AssocEntityDetails>()}) {
909 // RANK(*) associating entity is contiguous.
910 if (details->IsAssumedSize()) {
911 return true;
912 } else if (!IsVariable(details->expr()) &&
913 (namedConstantSectionsAreContiguous_ ||
914 !ExtractDataRef(details->expr(), true, true))) {
915 // Selector is associated to an expression value.
916 return true;
917 } else {
918 return Base::operator()(ultimate); // use expr
919 }
920 } else if (semantics::IsPointer(ultimate) ||
921 semantics::IsAssumedShape(ultimate) || IsAssumedRank(ultimate)) {
922 return std::nullopt;
923 } else if (ultimate.has<semantics::ObjectEntityDetails>()) {
924 return true;
925 } else {
926 return Base::operator()(ultimate);
927 }
928 }
929
930 Result operator()(const ArrayRef &x) const {
931 if (x.Rank() == 0) {
932 return true; // scalars considered contiguous
933 }
934 int subscriptRank{0};
935 auto baseLbounds{GetLBOUNDs(context_, x.base())};
936 auto baseUbounds{GetUBOUNDs(context_, x.base())};
937 auto subscripts{CheckSubscripts(
938 x.subscript(), subscriptRank, &baseLbounds, &baseUbounds)};
939 if (!subscripts.value_or(false)) {
940 return subscripts; // subscripts not known to be contiguous
941 } else if (subscriptRank > 0) {
942 // a(1)%b(:,:) is contiguous if and only if a(1)%b is contiguous.
943 return (*this)(x.base());
944 } else {
945 // a(:)%b(1,1) is (probably) not contiguous.
946 return std::nullopt;
947 }
948 }
949 Result operator()(const CoarrayRef &x) const { return (*this)(x.base()); }
950 Result operator()(const Component &x) const {
951 if (x.base().Rank() == 0) {
952 return (*this)(x.GetLastSymbol());
953 } else {
954 if (Result baseIsContiguous{(*this)(x.base())}) {
955 if (!*baseIsContiguous) {
956 return false;
957 }
958 // TODO: should be true if base is contiguous and this is only
959 // component, or when the base has at most one element
960 }
961 return std::nullopt;
962 }
963 }
964 Result operator()(const ComplexPart &x) const {
965 // TODO: should be true when base is empty array, too
966 return x.complex().Rank() == 0;
967 }
968 Result operator()(const Substring &x) const {
969 if (x.Rank() == 0) {
970 return true; // scalar substring always contiguous
971 }
972 // Substrings with rank must have DataRefs as their parents
973 const DataRef &parentDataRef{DEREF(x.GetParentIf<DataRef>())};
974 std::optional<std::int64_t> len;
975 if (auto lenExpr{parentDataRef.LEN()}) {
976 len = ToInt64(Fold(context_, std::move(*lenExpr)));
977 if (len) {
978 if (*len <= 0) {
979 return true; // empty substrings
980 } else if (*len == 1) {
981 // Substrings can't be incomplete; is base array contiguous?
982 return (*this)(parentDataRef);
983 }
984 }
985 }
986 std::optional<std::int64_t> upper;
987 bool upperIsLen{false};
988 if (auto upperExpr{x.upper()}) {
989 upper = ToInt64(Fold(context_, common::Clone(*upperExpr)));
990 if (upper) {
991 if (*upper < 1) {
992 return true; // substring(n:0) empty
993 }
994 upperIsLen = len && *upper >= *len;
995 } else if (const auto *inquiry{
996 UnwrapConvertedExpr<DescriptorInquiry>(*upperExpr)};
997 inquiry && inquiry->field() == DescriptorInquiry::Field::Len) {
998 upperIsLen =
999 &parentDataRef.GetLastSymbol() == &inquiry->base().GetLastSymbol();
1000 }
1001 } else {
1002 upperIsLen = true; // substring(n:)
1003 }
1004 if (auto lower{ToInt64(Fold(context_, x.lower()))}) {
1005 if (*lower == 1 && upperIsLen) {
1006 // known complete substring; is base contiguous?
1007 return (*this)(parentDataRef);
1008 } else if (upper) {
1009 if (*upper < *lower) {
1010 return true; // empty substring(3:2)
1011 } else if (*lower > 1) {
1012 return false; // known incomplete substring
1013 } else if (len && *upper < *len) {
1014 return false; // known incomplete substring
1015 }
1016 }
1017 }
1018 return std::nullopt; // contiguity not known
1019 }
1020
1021 Result operator()(const ProcedureRef &x) const {
1022 if (auto chars{characteristics::Procedure::Characterize(
1023 x.proc(), context_, /*emitError=*/true)}) {
1024 if (chars->functionResult) {
1025 const auto &result{*chars->functionResult};
1026 if (!result.IsProcedurePointer()) {
1027 if (result.attrs.test(
1028 characteristics::FunctionResult::Attr::Contiguous)) {
1029 return true;
1030 }
1031 if (!result.attrs.test(
1032 characteristics::FunctionResult::Attr::Pointer)) {
1033 return true;
1034 }
1035 if (const auto *type{result.GetTypeAndShape()};
1036 type && type->Rank() == 0) {
1037 return true; // pointer to scalar
1038 }
1039 // Must be non-CONTIGUOUS pointer to array
1040 }
1041 }
1042 }
1043 return std::nullopt;
1044 }
1045
1046 Result operator()(const NullPointer &) const { return true; }
1047
1048private:
1049 // Returns "true" for a provably empty or simply contiguous array section;
1050 // return "false" for a provably nonempty discontiguous section or for use
1051 // of a vector subscript.
1052 std::optional<bool> CheckSubscripts(const std::vector<Subscript> &subscript,
1053 int &rank, const Shape *baseLbounds = nullptr,
1054 const Shape *baseUbounds = nullptr) const {
1055 bool anyTriplet{false};
1056 rank = 0;
1057 // Detect any provably empty dimension in this array section, which would
1058 // render the whole section empty and therefore vacuously contiguous.
1059 std::optional<bool> result;
1060 bool mayBeEmpty{false};
1061 auto dims{subscript.size()};
1062 std::vector<bool> knownPartialSlice(dims, false);
1063 for (auto j{dims}; j-- > 0;) {
1064 if (j == 0 && firstDimensionStride1_ && !result.value_or(true)) {
1065 result.reset(); // ignore problems on later dimensions
1066 }
1067 std::optional<ConstantSubscript> dimLbound;
1068 std::optional<ConstantSubscript> dimUbound;
1069 std::optional<ConstantSubscript> dimExtent;
1070 if (baseLbounds && j < baseLbounds->size()) {
1071 if (const auto &lb{baseLbounds->at(j)}) {
1072 dimLbound = ToInt64(Fold(context_, Expr<SubscriptInteger>{*lb}));
1073 }
1074 }
1075 if (baseUbounds && j < baseUbounds->size()) {
1076 if (const auto &ub{baseUbounds->at(j)}) {
1077 dimUbound = ToInt64(Fold(context_, Expr<SubscriptInteger>{*ub}));
1078 }
1079 }
1080 if (dimLbound && dimUbound) {
1081 if (*dimLbound <= *dimUbound) {
1082 dimExtent = *dimUbound - *dimLbound + 1;
1083 } else {
1084 // This is an empty dimension.
1085 result = true;
1086 dimExtent = 0;
1087 }
1088 }
1089 if (const auto *triplet{std::get_if<Triplet>(&subscript[j].u)}) {
1090 ++rank;
1091 const Expr<SubscriptInteger> *lowerBound{triplet->GetLower()};
1092 const Expr<SubscriptInteger> *upperBound{triplet->GetUpper()};
1093 std::optional<ConstantSubscript> lowerVal{lowerBound
1094 ? ToInt64(Fold(context_, Expr<SubscriptInteger>{*lowerBound}))
1095 : dimLbound};
1096 std::optional<ConstantSubscript> upperVal{upperBound
1097 ? ToInt64(Fold(context_, Expr<SubscriptInteger>{*upperBound}))
1098 : dimUbound};
1099 if (auto stride{ToInt64(triplet->stride())}) {
1100 if (j == 0 && *stride == 1 && firstDimensionStride1_) {
1101 result = *stride == 1; // contiguous or empty if so
1102 }
1103 if (lowerVal && upperVal) {
1104 if (*lowerVal < *upperVal) {
1105 if (*stride < 0) {
1106 result = true; // empty dimension
1107 } else if (!result && *stride > 1 &&
1108 *lowerVal + *stride <= *upperVal) {
1109 result = false; // discontiguous if not empty
1110 }
1111 } else if (*lowerVal > *upperVal) {
1112 if (*stride > 0) {
1113 result = true; // empty dimension
1114 } else if (!result && *stride < 0 &&
1115 *lowerVal + *stride >= *upperVal) {
1116 result = false; // discontiguous if not empty
1117 }
1118 } else { // bounds known and equal
1119 if (j == 0 && firstDimensionStride1_) {
1120 result = true; // stride doesn't matter
1121 }
1122 }
1123 } else { // bounds not both known
1124 mayBeEmpty = true;
1125 }
1126 } else { // stride not known
1127 if (lowerVal && upperVal && *lowerVal == *upperVal) {
1128 // stride doesn't matter when bounds are equal
1129 if (j == 0 && firstDimensionStride1_) {
1130 result = true;
1131 }
1132 } else {
1133 mayBeEmpty = true;
1134 }
1135 }
1136 } else if (subscript[j].Rank() > 0) { // vector subscript
1137 ++rank;
1138 if (!result) {
1139 result = false;
1140 }
1141 mayBeEmpty = true;
1142 } else { // scalar subscript
1143 if (dimExtent && *dimExtent > 1) {
1144 knownPartialSlice[j] = true;
1145 }
1146 }
1147 }
1148 if (rank == 0) {
1149 result = true; // scalar
1150 }
1151 if (result) {
1152 return result;
1153 }
1154 // Not provably contiguous or discontiguous at this point.
1155 // Return "true" if simply contiguous, otherwise nullopt.
1156 for (auto j{subscript.size()}; j-- > 0;) {
1157 if (const auto *triplet{std::get_if<Triplet>(&subscript[j].u)}) {
1158 auto stride{ToInt64(triplet->stride())};
1159 if (!stride || stride != 1) {
1160 return std::nullopt;
1161 } else if (anyTriplet) {
1162 if (triplet->GetLower() || triplet->GetUpper()) {
1163 // all triplets before the last one must be just ":" for
1164 // simple contiguity
1165 return std::nullopt;
1166 }
1167 } else {
1168 anyTriplet = true;
1169 }
1170 ++rank;
1171 } else if (anyTriplet) {
1172 // If the section cannot be empty, and this dimension's
1173 // scalar subscript is known not to cover the whole
1174 // dimension, then the array section is provably
1175 // discontiguous.
1176 return (mayBeEmpty || !knownPartialSlice[j])
1177 ? std::nullopt
1178 : std::make_optional(false);
1179 }
1180 }
1181 return true; // simply contiguous
1182 }
1183
1184 FoldingContext &context_;
1185 bool namedConstantSectionsAreContiguous_{false};
1186 bool firstDimensionStride1_{false};
1187};
1188
1189template <typename A>
1190std::optional<bool> IsContiguous(const A &x, FoldingContext &context,
1191 bool namedConstantSectionsAreContiguous, bool firstDimensionStride1) {
1192 if (!IsVariable(x) &&
1193 (namedConstantSectionsAreContiguous || !ExtractDataRef(x, true, true))) {
1194 return true;
1195 } else {
1196 return IsContiguousHelper{
1197 context, namedConstantSectionsAreContiguous, firstDimensionStride1}(x);
1198 }
1199}
1200
1201template std::optional<bool> IsContiguous(const Expr<SomeType> &,
1202 FoldingContext &, bool namedConstantSectionsAreContiguous,
1203 bool firstDimensionStride1);
1204template std::optional<bool> IsContiguous(const ArrayRef &, FoldingContext &,
1205 bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);
1206template std::optional<bool> IsContiguous(const Substring &, FoldingContext &,
1207 bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);
1208template std::optional<bool> IsContiguous(const Component &, FoldingContext &,
1209 bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);
1210template std::optional<bool> IsContiguous(const ComplexPart &, FoldingContext &,
1211 bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);
1212template std::optional<bool> IsContiguous(const CoarrayRef &, FoldingContext &,
1213 bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);
1214template std::optional<bool> IsContiguous(const Symbol &, FoldingContext &,
1215 bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);
1216
1217// IsErrorExpr()
1218struct IsErrorExprHelper : public AnyTraverse<IsErrorExprHelper, bool> {
1219 using Result = bool;
1220 using Base = AnyTraverse<IsErrorExprHelper, Result>;
1221 IsErrorExprHelper() : Base{*this} {}
1222 using Base::operator();
1223
1224 bool operator()(const SpecificIntrinsic &x) {
1225 return x.name == IntrinsicProcTable::InvalidName;
1226 }
1227};
1228
1229template <typename A> bool IsErrorExpr(const A &x) {
1230 return IsErrorExprHelper{}(x);
1231}
1232
1233template bool IsErrorExpr(const Expr<SomeType> &);
1234
1235// C1577
1236// TODO: Also check C1579 & C1582 here
1237class StmtFunctionChecker
1238 : public AnyTraverse<StmtFunctionChecker, std::optional<parser::Message>> {
1239public:
1240 using Result = std::optional<parser::Message>;
1241 using Base = AnyTraverse<StmtFunctionChecker, Result>;
1242
1243 static constexpr auto feature{
1244 common::LanguageFeature::StatementFunctionExtensions};
1245
1246 StmtFunctionChecker(const Symbol &sf, FoldingContext &context)
1247 : Base{*this}, sf_{sf}, context_{context} {
1248 if (!context_.languageFeatures().IsEnabled(feature)) {
1249 severity_ = parser::Severity::Error;
1250 } else if (context_.languageFeatures().ShouldWarn(feature)) {
1251 severity_ = parser::Severity::Portability;
1252 }
1253 }
1254 using Base::operator();
1255
1256 Result Return(parser::Message &&msg) const {
1257 if (severity_) {
1258 msg.set_severity(*severity_);
1259 if (*severity_ != parser::Severity::Error) {
1260 msg.set_languageFeature(feature);
1261 }
1262 }
1263 return std::move(msg);
1264 }
1265
1266 template <typename T> Result operator()(const ArrayConstructor<T> &) const {
1267 if (severity_) {
1268 return Return(parser::Message{sf_.name(),
1269 "Statement function '%s' should not contain an array constructor"_port_en_US,
1270 sf_.name()});
1271 } else {
1272 return std::nullopt;
1273 }
1274 }
1275 Result operator()(const StructureConstructor &) const {
1276 if (severity_) {
1277 return Return(parser::Message{sf_.name(),
1278 "Statement function '%s' should not contain a structure constructor"_port_en_US,
1279 sf_.name()});
1280 } else {
1281 return std::nullopt;
1282 }
1283 }
1284 Result operator()(const TypeParamInquiry &) const {
1285 if (severity_) {
1286 return Return(parser::Message{sf_.name(),
1287 "Statement function '%s' should not contain a type parameter inquiry"_port_en_US,
1288 sf_.name()});
1289 } else {
1290 return std::nullopt;
1291 }
1292 }
1293 Result operator()(const ProcedureDesignator &proc) const {
1294 if (const Symbol * symbol{proc.GetSymbol()}) {
1295 const Symbol &ultimate{symbol->GetUltimate()};
1296 if (const auto *subp{
1297 ultimate.detailsIf<semantics::SubprogramDetails>()}) {
1298 if (subp->stmtFunction() && &ultimate.owner() == &sf_.owner()) {
1299 if (ultimate.name().begin() > sf_.name().begin()) {
1300 return parser::Message{sf_.name(),
1301 "Statement function '%s' may not reference another statement function '%s' that is defined later"_err_en_US,
1302 sf_.name(), ultimate.name()};
1303 }
1304 }
1305 }
1306 if (auto chars{characteristics::Procedure::Characterize(
1307 proc, context_, /*emitError=*/true)}) {
1308 if (!chars->CanBeCalledViaImplicitInterface()) {
1309 if (severity_) {
1310 return Return(parser::Message{sf_.name(),
1311 "Statement function '%s' should not reference function '%s' that requires an explicit interface"_port_en_US,
1312 sf_.name(), symbol->name()});
1313 }
1314 }
1315 }
1316 }
1317 if (proc.Rank() > 0) {
1318 if (severity_) {
1319 return Return(parser::Message{sf_.name(),
1320 "Statement function '%s' should not reference a function that returns an array"_port_en_US,
1321 sf_.name()});
1322 }
1323 }
1324 return std::nullopt;
1325 }
1326 Result operator()(const ActualArgument &arg) const {
1327 if (const auto *expr{arg.UnwrapExpr()}) {
1328 if (auto result{(*this)(*expr)}) {
1329 return result;
1330 }
1331 if (expr->Rank() > 0 && !UnwrapWholeSymbolOrComponentDataRef(*expr)) {
1332 if (severity_) {
1333 return Return(parser::Message{sf_.name(),
1334 "Statement function '%s' should not pass an array argument that is not a whole array"_port_en_US,
1335 sf_.name()});
1336 }
1337 }
1338 }
1339 return std::nullopt;
1340 }
1341
1342private:
1343 const Symbol &sf_;
1344 FoldingContext &context_;
1345 std::optional<parser::Severity> severity_;
1346};
1347
1348std::optional<parser::Message> CheckStatementFunction(
1349 const Symbol &sf, const Expr<SomeType> &expr, FoldingContext &context) {
1350 return StmtFunctionChecker{sf, context}(expr);
1351}
1352
1353} // namespace Fortran::evaluate
1354

source code of flang/lib/Evaluate/check-expression.cpp