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