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

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