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 const auto *object{lastSymbol.detailsIf<semantics::ObjectEntityDetails>()}; 498 switch (field) { 499 case DescriptorInquiry::Field::LowerBound: 500 case DescriptorInquiry::Field::Extent: 501 case DescriptorInquiry::Field::Stride: 502 return object && !object->shape().CanBeDeferredShape(); 503 case DescriptorInquiry::Field::Rank: 504 return true; // always known 505 case DescriptorInquiry::Field::Len: 506 return object && object->type() && 507 object->type()->category() == semantics::DeclTypeSpec::Character && 508 !object->type()->characterTypeSpec().length().isDeferred(); 509 } 510 // TODO: Handle non-deferred LEN type parameters of PDTs 511 return false; 512 } 513 514 // Specification expression validation (10.1.11(2), C1010) 515 class CheckSpecificationExprHelper 516 : public AnyTraverse<CheckSpecificationExprHelper, 517 std::optional<std::string>> { 518 public: 519 using Result = std::optional<std::string>; 520 using Base = AnyTraverse<CheckSpecificationExprHelper, Result>; 521 explicit CheckSpecificationExprHelper( 522 const semantics::Scope &s, FoldingContext &context) 523 : Base{*this}, scope_{s}, context_{context} {} 524 using Base::operator(); 525 526 Result operator()(const CoarrayRef &) const { return "coindexed reference"; } 527 528 Result operator()(const semantics::Symbol &symbol) const { 529 const auto &ultimate{symbol.GetUltimate()}; 530 if (const auto *assoc{ 531 ultimate.detailsIf<semantics::AssocEntityDetails>()}) { 532 return (*this)(assoc->expr()); 533 } else if (semantics::IsNamedConstant(ultimate) || 534 ultimate.owner().IsModule() || ultimate.owner().IsSubmodule()) { 535 return std::nullopt; 536 } else if (scope_.IsDerivedType() && 537 IsVariableName(ultimate)) { // C750, C754 538 return "derived type component or type parameter value not allowed to " 539 "reference variable '"s + 540 ultimate.name().ToString() + "'"; 541 } else if (IsDummy(ultimate)) { 542 if (ultimate.attrs().test(semantics::Attr::OPTIONAL)) { 543 return "reference to OPTIONAL dummy argument '"s + 544 ultimate.name().ToString() + "'"; 545 } else if (!inInquiry_ && 546 ultimate.attrs().test(semantics::Attr::INTENT_OUT)) { 547 return "reference to INTENT(OUT) dummy argument '"s + 548 ultimate.name().ToString() + "'"; 549 } else if (ultimate.has<semantics::ObjectEntityDetails>()) { 550 return std::nullopt; 551 } else { 552 return "dummy procedure argument"; 553 } 554 } else if (&symbol.owner() != &scope_ || &ultimate.owner() != &scope_) { 555 return std::nullopt; // host association is in play 556 } else if (const auto *object{ 557 ultimate.detailsIf<semantics::ObjectEntityDetails>()}) { 558 if (object->commonBlock()) { 559 return std::nullopt; 560 } 561 } 562 if (inInquiry_) { 563 return std::nullopt; 564 } else { 565 return "reference to local entity '"s + ultimate.name().ToString() + "'"; 566 } 567 } 568 569 Result operator()(const Component &x) const { 570 // Don't look at the component symbol. 571 return (*this)(x.base()); 572 } 573 Result operator()(const ArrayRef &x) const { 574 if (auto result{(*this)(x.base())}) { 575 return result; 576 } 577 // The subscripts don't get special protection for being in a 578 // specification inquiry context; 579 auto restorer{common::ScopedSet(inInquiry_, false)}; 580 return (*this)(x.subscript()); 581 } 582 Result operator()(const Substring &x) const { 583 if (auto result{(*this)(x.parent())}) { 584 return result; 585 } 586 // The bounds don't get special protection for being in a 587 // specification inquiry context; 588 auto restorer{common::ScopedSet(inInquiry_, false)}; 589 if (auto result{(*this)(x.lower())}) { 590 return result; 591 } 592 return (*this)(x.upper()); 593 } 594 Result operator()(const DescriptorInquiry &x) const { 595 // Many uses of SIZE(), LBOUND(), &c. that are valid in specification 596 // expressions will have been converted to expressions over descriptor 597 // inquiries by Fold(). 598 // Catch REAL, ALLOCATABLE :: X(:); REAL :: Y(SIZE(X)) 599 if (IsPermissibleInquiry(x.base().GetFirstSymbol(), 600 x.base().GetLastSymbol(), x.field(), scope_)) { 601 auto restorer{common::ScopedSet(inInquiry_, true)}; 602 return (*this)(x.base()); 603 } else if (IsConstantExpr(x)) { 604 return std::nullopt; 605 } else { 606 return "non-constant descriptor inquiry not allowed for local object"; 607 } 608 } 609 610 Result operator()(const TypeParamInquiry &inq) const { 611 if (scope_.IsDerivedType() && !IsConstantExpr(inq) && 612 inq.base() /* X%T, not local T */) { // C750, C754 613 return "non-constant reference to a type parameter inquiry not " 614 "allowed for derived type components or type parameter values"; 615 } 616 return std::nullopt; 617 } 618 619 Result operator()(const ProcedureRef &x) const { 620 bool inInquiry{false}; 621 if (const auto *symbol{x.proc().GetSymbol()}) { 622 const Symbol &ultimate{symbol->GetUltimate()}; 623 if (!semantics::IsPureProcedure(ultimate)) { 624 return "reference to impure function '"s + ultimate.name().ToString() + 625 "'"; 626 } 627 if (semantics::IsStmtFunction(ultimate)) { 628 return "reference to statement function '"s + 629 ultimate.name().ToString() + "'"; 630 } 631 if (scope_.IsDerivedType()) { // C750, C754 632 return "reference to function '"s + ultimate.name().ToString() + 633 "' not allowed for derived type components or type parameter" 634 " values"; 635 } 636 if (auto procChars{ 637 characteristics::Procedure::Characterize(x.proc(), context_)}) { 638 const auto iter{std::find_if(procChars->dummyArguments.begin(), 639 procChars->dummyArguments.end(), 640 [](const characteristics::DummyArgument &dummy) { 641 return std::holds_alternative<characteristics::DummyProcedure>( 642 dummy.u); 643 })}; 644 if (iter != procChars->dummyArguments.end()) { 645 return "reference to function '"s + ultimate.name().ToString() + 646 "' with dummy procedure argument '" + iter->name + '\''; 647 } 648 } 649 // References to internal functions are caught in expression semantics. 650 // TODO: other checks for standard module procedures 651 } else { // intrinsic 652 const SpecificIntrinsic &intrin{DEREF(x.proc().GetSpecificIntrinsic())}; 653 inInquiry = context_.intrinsics().GetIntrinsicClass(intrin.name) == 654 IntrinsicClass::inquiryFunction; 655 if (scope_.IsDerivedType()) { // C750, C754 656 if ((context_.intrinsics().IsIntrinsic(intrin.name) && 657 badIntrinsicsForComponents_.find(intrin.name) != 658 badIntrinsicsForComponents_.end())) { 659 return "reference to intrinsic '"s + intrin.name + 660 "' not allowed for derived type components or type parameter" 661 " values"; 662 } 663 if (inInquiry && !IsConstantExpr(x)) { 664 return "non-constant reference to inquiry intrinsic '"s + 665 intrin.name + 666 "' not allowed for derived type components or type" 667 " parameter values"; 668 } 669 } 670 // Type-determined inquiries (DIGITS, HUGE, &c.) will have already been 671 // folded and won't arrive here. Inquiries that are represented with 672 // DescriptorInquiry operations (LBOUND) are checked elsewhere. If a 673 // call that makes it to here satisfies the requirements of a constant 674 // expression (as Fortran defines it), it's fine. 675 if (IsConstantExpr(x)) { 676 return std::nullopt; 677 } 678 if (intrin.name == "present") { 679 return std::nullopt; // always ok 680 } 681 // Catch CHARACTER(:), ALLOCATABLE :: X; CHARACTER(LEN(X)) :: Y 682 if (inInquiry && x.arguments().size() >= 1) { 683 if (const auto &arg{x.arguments().at(0)}) { 684 if (auto dataRef{ExtractDataRef(*arg, true, true)}) { 685 if (intrin.name == "allocated" || intrin.name == "associated" || 686 intrin.name == "is_contiguous") { // ok 687 } else if (intrin.name == "len" && 688 IsPermissibleInquiry(dataRef->GetFirstSymbol(), 689 dataRef->GetLastSymbol(), DescriptorInquiry::Field::Len, 690 scope_)) { // ok 691 } else if (intrin.name == "lbound" && 692 IsPermissibleInquiry(dataRef->GetFirstSymbol(), 693 dataRef->GetLastSymbol(), 694 DescriptorInquiry::Field::LowerBound, scope_)) { // ok 695 } else if ((intrin.name == "shape" || intrin.name == "size" || 696 intrin.name == "sizeof" || 697 intrin.name == "storage_size" || 698 intrin.name == "ubound") && 699 IsPermissibleInquiry(dataRef->GetFirstSymbol(), 700 dataRef->GetLastSymbol(), DescriptorInquiry::Field::Extent, 701 scope_)) { // ok 702 } else { 703 return "non-constant inquiry function '"s + intrin.name + 704 "' not allowed for local object"; 705 } 706 } 707 } 708 } 709 } 710 auto restorer{common::ScopedSet(inInquiry_, inInquiry)}; 711 return (*this)(x.arguments()); 712 } 713 714 private: 715 const semantics::Scope &scope_; 716 FoldingContext &context_; 717 // Contextual information: this flag is true when in an argument to 718 // an inquiry intrinsic like SIZE(). 719 mutable bool inInquiry_{false}; 720 const std::set<std::string> badIntrinsicsForComponents_{ 721 "allocated", "associated", "extends_type_of", "present", "same_type_as"}; 722 }; 723 724 template <typename A> 725 void CheckSpecificationExpr( 726 const A &x, const semantics::Scope &scope, FoldingContext &context) { 727 if (auto why{CheckSpecificationExprHelper{scope, context}(x)}) { 728 context.messages().Say( 729 "Invalid specification expression: %s"_err_en_US, *why); 730 } 731 } 732 733 template void CheckSpecificationExpr( 734 const Expr<SomeType> &, const semantics::Scope &, FoldingContext &); 735 template void CheckSpecificationExpr( 736 const Expr<SomeInteger> &, const semantics::Scope &, FoldingContext &); 737 template void CheckSpecificationExpr( 738 const Expr<SubscriptInteger> &, const semantics::Scope &, FoldingContext &); 739 template void CheckSpecificationExpr(const std::optional<Expr<SomeType>> &, 740 const semantics::Scope &, FoldingContext &); 741 template void CheckSpecificationExpr(const std::optional<Expr<SomeInteger>> &, 742 const semantics::Scope &, FoldingContext &); 743 template void CheckSpecificationExpr( 744 const std::optional<Expr<SubscriptInteger>> &, const semantics::Scope &, 745 FoldingContext &); 746 747 // IsContiguous() -- 9.5.4 748 class IsContiguousHelper 749 : public AnyTraverse<IsContiguousHelper, std::optional<bool>> { 750 public: 751 using Result = std::optional<bool>; // tri-state 752 using Base = AnyTraverse<IsContiguousHelper, Result>; 753 explicit IsContiguousHelper(FoldingContext &c) : Base{*this}, context_{c} {} 754 using Base::operator(); 755 756 Result operator()(const semantics::Symbol &symbol) const { 757 const auto &ultimate{symbol.GetUltimate()}; 758 if (ultimate.attrs().test(semantics::Attr::CONTIGUOUS)) { 759 return true; 760 } else if (ultimate.Rank() == 0) { 761 // Extension: accept scalars as a degenerate case of 762 // simple contiguity to allow their use in contexts like 763 // data targets in pointer assignments with remapping. 764 return true; 765 } else if (semantics::IsPointer(ultimate) || 766 semantics::IsAssumedShape(ultimate)) { 767 return std::nullopt; 768 } else if (const auto *details{ 769 ultimate.detailsIf<semantics::ObjectEntityDetails>()}) { 770 return !details->IsAssumedRank(); 771 } else { 772 return Base::operator()(ultimate); 773 } 774 } 775 776 Result operator()(const ArrayRef &x) const { 777 if (x.Rank() == 0) { 778 return true; // scalars considered contiguous 779 } 780 int subscriptRank{0}; 781 auto baseLbounds{GetLBOUNDs(context_, x.base())}; 782 auto baseUbounds{GetUBOUNDs(context_, x.base())}; 783 auto subscripts{CheckSubscripts( 784 x.subscript(), subscriptRank, &baseLbounds, &baseUbounds)}; 785 if (!subscripts.value_or(false)) { 786 return subscripts; // subscripts not known to be contiguous 787 } else if (subscriptRank > 0) { 788 // a(1)%b(:,:) is contiguous if and only if a(1)%b is contiguous. 789 return (*this)(x.base()); 790 } else { 791 // a(:)%b(1,1) is (probably) not contiguous. 792 return std::nullopt; 793 } 794 } 795 Result operator()(const CoarrayRef &x) const { 796 int rank{0}; 797 return CheckSubscripts(x.subscript(), rank).has_value(); 798 } 799 Result operator()(const Component &x) const { 800 if (x.base().Rank() == 0) { 801 return (*this)(x.GetLastSymbol()); 802 } else { 803 // TODO could be true if base contiguous and this is only component, or 804 // if base has only one element? 805 return std::nullopt; 806 } 807 } 808 Result operator()(const ComplexPart &x) const { 809 return x.complex().Rank() == 0; 810 } 811 Result operator()(const Substring &) const { return std::nullopt; } 812 813 Result operator()(const ProcedureRef &x) const { 814 if (auto chars{ 815 characteristics::Procedure::Characterize(x.proc(), context_)}) { 816 if (chars->functionResult) { 817 const auto &result{*chars->functionResult}; 818 return !result.IsProcedurePointer() && 819 result.attrs.test(characteristics::FunctionResult::Attr::Pointer) && 820 result.attrs.test( 821 characteristics::FunctionResult::Attr::Contiguous); 822 } 823 } 824 return std::nullopt; 825 } 826 827 Result operator()(const NullPointer &) const { return true; } 828 829 private: 830 // Returns "true" for a provably empty or simply contiguous array section; 831 // return "false" for a provably nonempty discontiguous section or for use 832 // of a vector subscript. 833 std::optional<bool> CheckSubscripts(const std::vector<Subscript> &subscript, 834 int &rank, const Shape *baseLbounds = nullptr, 835 const Shape *baseUbounds = nullptr) const { 836 bool anyTriplet{false}; 837 rank = 0; 838 // Detect any provably empty dimension in this array section, which would 839 // render the whole section empty and therefore vacuously contiguous. 840 std::optional<bool> result; 841 for (auto j{subscript.size()}; j-- > 0;) { 842 if (const auto *triplet{std::get_if<Triplet>(&subscript[j].u)}) { 843 ++rank; 844 if (auto stride{ToInt64(triplet->stride())}) { 845 const Expr<SubscriptInteger> *lowerBound{triplet->GetLower()}; 846 if (!lowerBound && baseLbounds && j < baseLbounds->size()) { 847 lowerBound = common::GetPtrFromOptional(baseLbounds->at(j)); 848 } 849 const Expr<SubscriptInteger> *upperBound{triplet->GetUpper()}; 850 if (!upperBound && baseUbounds && j < baseUbounds->size()) { 851 upperBound = common::GetPtrFromOptional(baseUbounds->at(j)); 852 } 853 std::optional<ConstantSubscript> lowerVal{lowerBound 854 ? ToInt64(Fold(context_, Expr<SubscriptInteger>{*lowerBound})) 855 : std::nullopt}; 856 std::optional<ConstantSubscript> upperVal{upperBound 857 ? ToInt64(Fold(context_, Expr<SubscriptInteger>{*upperBound})) 858 : std::nullopt}; 859 if (lowerVal && upperVal) { 860 if (*lowerVal < *upperVal) { 861 if (*stride < 0) { 862 result = true; // empty dimension 863 } else if (!result && *stride > 1 && 864 *lowerVal + *stride <= *upperVal) { 865 result = false; // discontiguous if not empty 866 } 867 } else if (*lowerVal > *upperVal) { 868 if (*stride > 0) { 869 result = true; // empty dimension 870 } else if (!result && *stride < 0 && 871 *lowerVal + *stride >= *upperVal) { 872 result = false; // discontiguous if not empty 873 } 874 } 875 } 876 } 877 } else if (subscript[j].Rank() > 0) { 878 ++rank; 879 if (!result) { 880 result = false; // vector subscript 881 } 882 } 883 } 884 if (rank == 0) { 885 result = true; // scalar 886 } 887 if (result) { 888 return result; 889 } 890 // Not provably discontiguous at this point. 891 // Return "true" if simply contiguous, otherwise nullopt. 892 for (auto j{subscript.size()}; j-- > 0;) { 893 if (const auto *triplet{std::get_if<Triplet>(&subscript[j].u)}) { 894 auto stride{ToInt64(triplet->stride())}; 895 if (!stride || stride != 1) { 896 return std::nullopt; 897 } else if (anyTriplet) { 898 if (triplet->GetLower() || triplet->GetUpper()) { 899 // all triplets before the last one must be just ":" for 900 // simple contiguity 901 return std::nullopt; 902 } 903 } else { 904 anyTriplet = true; 905 } 906 ++rank; 907 } else if (anyTriplet) { 908 return std::nullopt; 909 } 910 } 911 return true; // simply contiguous 912 } 913 914 FoldingContext &context_; 915 }; 916 917 template <typename A> 918 std::optional<bool> IsContiguous(const A &x, FoldingContext &context) { 919 if (IsVariable(x)) { 920 return IsContiguousHelper{context}(x); 921 } else { 922 return true; // not a variable 923 } 924 } 925 926 template std::optional<bool> IsContiguous( 927 const Expr<SomeType> &, FoldingContext &); 928 template std::optional<bool> IsContiguous(const ArrayRef &, FoldingContext &); 929 template std::optional<bool> IsContiguous(const Substring &, FoldingContext &); 930 template std::optional<bool> IsContiguous(const Component &, FoldingContext &); 931 template std::optional<bool> IsContiguous( 932 const ComplexPart &, FoldingContext &); 933 template std::optional<bool> IsContiguous(const CoarrayRef &, FoldingContext &); 934 935 // IsErrorExpr() 936 struct IsErrorExprHelper : public AnyTraverse<IsErrorExprHelper, bool> { 937 using Result = bool; 938 using Base = AnyTraverse<IsErrorExprHelper, Result>; 939 IsErrorExprHelper() : Base{*this} {} 940 using Base::operator(); 941 942 bool operator()(const SpecificIntrinsic &x) { 943 return x.name == IntrinsicProcTable::InvalidName; 944 } 945 }; 946 947 template <typename A> bool IsErrorExpr(const A &x) { 948 return IsErrorExprHelper{}(x); 949 } 950 951 template bool IsErrorExpr(const Expr<SomeType> &); 952 953 // C1577 954 // TODO: Also check C1579 & C1582 here 955 class StmtFunctionChecker 956 : public AnyTraverse<StmtFunctionChecker, std::optional<parser::Message>> { 957 public: 958 using Result = std::optional<parser::Message>; 959 using Base = AnyTraverse<StmtFunctionChecker, Result>; 960 StmtFunctionChecker(const Symbol &sf, FoldingContext &context) 961 : Base{*this}, sf_{sf}, context_{context} {} 962 using Base::operator(); 963 964 template <typename T> Result operator()(const ArrayConstructor<T> &) const { 965 return parser::Message{sf_.name(), 966 "Statement function '%s' should not contain an array constructor"_port_en_US, 967 sf_.name()}; 968 } 969 Result operator()(const StructureConstructor &) const { 970 return parser::Message{sf_.name(), 971 "Statement function '%s' should not contain a structure constructor"_port_en_US, 972 sf_.name()}; 973 } 974 Result operator()(const TypeParamInquiry &) const { 975 return parser::Message{sf_.name(), 976 "Statement function '%s' should not contain a type parameter inquiry"_port_en_US, 977 sf_.name()}; 978 } 979 Result operator()(const ProcedureDesignator &proc) const { 980 if (const Symbol * symbol{proc.GetSymbol()}) { 981 const Symbol &ultimate{symbol->GetUltimate()}; 982 if (const auto *subp{ 983 ultimate.detailsIf<semantics::SubprogramDetails>()}) { 984 if (subp->stmtFunction() && &ultimate.owner() == &sf_.owner()) { 985 if (ultimate.name().begin() > sf_.name().begin()) { 986 return parser::Message{sf_.name(), 987 "Statement function '%s' may not reference another statement function '%s' that is defined later"_err_en_US, 988 sf_.name(), ultimate.name()}; 989 } 990 } 991 } 992 if (auto chars{ 993 characteristics::Procedure::Characterize(proc, context_)}) { 994 if (!chars->CanBeCalledViaImplicitInterface()) { 995 return parser::Message(sf_.name(), 996 "Statement function '%s' should not reference function '%s' that requires an explicit interface"_port_en_US, 997 sf_.name(), symbol->name()); 998 } 999 } 1000 } 1001 if (proc.Rank() > 0) { 1002 return parser::Message(sf_.name(), 1003 "Statement function '%s' should not reference a function that returns an array"_port_en_US, 1004 sf_.name()); 1005 } 1006 return std::nullopt; 1007 } 1008 Result operator()(const ActualArgument &arg) const { 1009 if (const auto *expr{arg.UnwrapExpr()}) { 1010 if (auto result{(*this)(*expr)}) { 1011 return result; 1012 } 1013 if (expr->Rank() > 0 && !UnwrapWholeSymbolOrComponentDataRef(*expr)) { 1014 return parser::Message(sf_.name(), 1015 "Statement function '%s' should not pass an array argument that is not a whole array"_port_en_US, 1016 sf_.name()); 1017 } 1018 } 1019 return std::nullopt; 1020 } 1021 1022 private: 1023 const Symbol &sf_; 1024 FoldingContext &context_; 1025 }; 1026 1027 std::optional<parser::Message> CheckStatementFunction( 1028 const Symbol &sf, const Expr<SomeType> &expr, FoldingContext &context) { 1029 return StmtFunctionChecker{sf, context}(expr); 1030 } 1031 1032 } // namespace Fortran::evaluate 1033