1 //===-- lib/Semantics/tools.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/Parser/tools.h" 10 #include "flang/Common/Fortran.h" 11 #include "flang/Common/indirection.h" 12 #include "flang/Parser/dump-parse-tree.h" 13 #include "flang/Parser/message.h" 14 #include "flang/Parser/parse-tree.h" 15 #include "flang/Semantics/scope.h" 16 #include "flang/Semantics/semantics.h" 17 #include "flang/Semantics/symbol.h" 18 #include "flang/Semantics/tools.h" 19 #include "flang/Semantics/type.h" 20 #include "llvm/Support/raw_ostream.h" 21 #include <algorithm> 22 #include <set> 23 #include <variant> 24 25 namespace Fortran::semantics { 26 27 // Find this or containing scope that matches predicate 28 static const Scope *FindScopeContaining( 29 const Scope &start, std::function<bool(const Scope &)> predicate) { 30 for (const Scope *scope{&start};; scope = &scope->parent()) { 31 if (predicate(*scope)) { 32 return scope; 33 } 34 if (scope->IsGlobal()) { 35 return nullptr; 36 } 37 } 38 } 39 40 const Scope &GetTopLevelUnitContaining(const Scope &start) { 41 CHECK(!start.IsGlobal()); 42 return DEREF(FindScopeContaining( 43 start, [](const Scope &scope) { return scope.parent().IsGlobal(); })); 44 } 45 46 const Scope &GetTopLevelUnitContaining(const Symbol &symbol) { 47 return GetTopLevelUnitContaining(symbol.owner()); 48 } 49 50 const Scope *FindModuleContaining(const Scope &start) { 51 return FindScopeContaining( 52 start, [](const Scope &scope) { return scope.IsModule(); }); 53 } 54 55 const Scope &GetProgramUnitContaining(const Scope &start) { 56 CHECK(!start.IsGlobal()); 57 return DEREF(FindScopeContaining(start, [](const Scope &scope) { 58 switch (scope.kind()) { 59 case Scope::Kind::Module: 60 case Scope::Kind::MainProgram: 61 case Scope::Kind::Subprogram: 62 case Scope::Kind::BlockData: 63 return true; 64 default: 65 return false; 66 } 67 })); 68 } 69 70 const Scope &GetProgramUnitContaining(const Symbol &symbol) { 71 return GetProgramUnitContaining(symbol.owner()); 72 } 73 74 const Scope *FindPureProcedureContaining(const Scope &start) { 75 // N.B. We only need to examine the innermost containing program unit 76 // because an internal subprogram of a pure subprogram must also 77 // be pure (C1592). 78 const Scope &scope{GetProgramUnitContaining(start)}; 79 return IsPureProcedure(scope) ? &scope : nullptr; 80 } 81 82 Tristate IsDefinedAssignment( 83 const std::optional<evaluate::DynamicType> &lhsType, int lhsRank, 84 const std::optional<evaluate::DynamicType> &rhsType, int rhsRank) { 85 if (!lhsType || !rhsType) { 86 return Tristate::No; // error or rhs is untyped 87 } 88 TypeCategory lhsCat{lhsType->category()}; 89 TypeCategory rhsCat{rhsType->category()}; 90 if (rhsRank > 0 && lhsRank != rhsRank) { 91 return Tristate::Yes; 92 } else if (lhsCat != TypeCategory::Derived) { 93 return ToTristate(lhsCat != rhsCat && 94 (!IsNumericTypeCategory(lhsCat) || !IsNumericTypeCategory(rhsCat))); 95 } else { 96 const auto *lhsDerived{evaluate::GetDerivedTypeSpec(lhsType)}; 97 const auto *rhsDerived{evaluate::GetDerivedTypeSpec(rhsType)}; 98 if (lhsDerived && rhsDerived && *lhsDerived == *rhsDerived) { 99 return Tristate::Maybe; // TYPE(t) = TYPE(t) can be defined or 100 // intrinsic 101 } else { 102 return Tristate::Yes; 103 } 104 } 105 } 106 107 bool IsIntrinsicRelational(common::RelationalOperator opr, 108 const evaluate::DynamicType &type0, int rank0, 109 const evaluate::DynamicType &type1, int rank1) { 110 if (!evaluate::AreConformable(rank0, rank1)) { 111 return false; 112 } else { 113 auto cat0{type0.category()}; 114 auto cat1{type1.category()}; 115 if (IsNumericTypeCategory(cat0) && IsNumericTypeCategory(cat1)) { 116 // numeric types: EQ/NE always ok, others ok for non-complex 117 return opr == common::RelationalOperator::EQ || 118 opr == common::RelationalOperator::NE || 119 (cat0 != TypeCategory::Complex && cat1 != TypeCategory::Complex); 120 } else { 121 // not both numeric: only Character is ok 122 return cat0 == TypeCategory::Character && cat1 == TypeCategory::Character; 123 } 124 } 125 } 126 127 bool IsIntrinsicNumeric(const evaluate::DynamicType &type0) { 128 return IsNumericTypeCategory(type0.category()); 129 } 130 bool IsIntrinsicNumeric(const evaluate::DynamicType &type0, int rank0, 131 const evaluate::DynamicType &type1, int rank1) { 132 return evaluate::AreConformable(rank0, rank1) && 133 IsNumericTypeCategory(type0.category()) && 134 IsNumericTypeCategory(type1.category()); 135 } 136 137 bool IsIntrinsicLogical(const evaluate::DynamicType &type0) { 138 return type0.category() == TypeCategory::Logical; 139 } 140 bool IsIntrinsicLogical(const evaluate::DynamicType &type0, int rank0, 141 const evaluate::DynamicType &type1, int rank1) { 142 return evaluate::AreConformable(rank0, rank1) && 143 type0.category() == TypeCategory::Logical && 144 type1.category() == TypeCategory::Logical; 145 } 146 147 bool IsIntrinsicConcat(const evaluate::DynamicType &type0, int rank0, 148 const evaluate::DynamicType &type1, int rank1) { 149 return evaluate::AreConformable(rank0, rank1) && 150 type0.category() == TypeCategory::Character && 151 type1.category() == TypeCategory::Character && 152 type0.kind() == type1.kind(); 153 } 154 155 bool IsGenericDefinedOp(const Symbol &symbol) { 156 const Symbol &ultimate{symbol.GetUltimate()}; 157 if (const auto *generic{ultimate.detailsIf<GenericDetails>()}) { 158 return generic->kind().IsDefinedOperator(); 159 } else if (const auto *misc{ultimate.detailsIf<MiscDetails>()}) { 160 return misc->kind() == MiscDetails::Kind::TypeBoundDefinedOp; 161 } else { 162 return false; 163 } 164 } 165 166 bool IsDefinedOperator(SourceName name) { 167 const char *begin{name.begin()}; 168 const char *end{name.end()}; 169 return begin != end && begin[0] == '.' && end[-1] == '.'; 170 } 171 172 std::string MakeOpName(SourceName name) { 173 std::string result{name.ToString()}; 174 return IsDefinedOperator(name) ? "OPERATOR(" + result + ")" 175 : result.find("operator(", 0) == 0 ? parser::ToUpperCaseLetters(result) 176 : result; 177 } 178 179 bool IsCommonBlockContaining(const Symbol &block, const Symbol &object) { 180 const auto &objects{block.get<CommonBlockDetails>().objects()}; 181 auto found{std::find(objects.begin(), objects.end(), object)}; 182 return found != objects.end(); 183 } 184 185 bool IsUseAssociated(const Symbol &symbol, const Scope &scope) { 186 const Scope &owner{GetProgramUnitContaining(symbol.GetUltimate().owner())}; 187 return owner.kind() == Scope::Kind::Module && 188 owner != GetProgramUnitContaining(scope); 189 } 190 191 bool DoesScopeContain( 192 const Scope *maybeAncestor, const Scope &maybeDescendent) { 193 return maybeAncestor && !maybeDescendent.IsGlobal() && 194 FindScopeContaining(maybeDescendent.parent(), 195 [&](const Scope &scope) { return &scope == maybeAncestor; }); 196 } 197 198 bool DoesScopeContain(const Scope *maybeAncestor, const Symbol &symbol) { 199 return DoesScopeContain(maybeAncestor, symbol.owner()); 200 } 201 202 static const Symbol &FollowHostAssoc(const Symbol &symbol) { 203 for (const Symbol *s{&symbol};;) { 204 const auto *details{s->detailsIf<HostAssocDetails>()}; 205 if (!details) { 206 return *s; 207 } 208 s = &details->symbol(); 209 } 210 } 211 212 bool IsHostAssociated(const Symbol &symbol, const Scope &scope) { 213 const Scope &subprogram{GetProgramUnitContaining(scope)}; 214 return DoesScopeContain( 215 &GetProgramUnitContaining(FollowHostAssoc(symbol)), subprogram); 216 } 217 218 bool IsInStmtFunction(const Symbol &symbol) { 219 if (const Symbol * function{symbol.owner().symbol()}) { 220 return IsStmtFunction(*function); 221 } 222 return false; 223 } 224 225 bool IsStmtFunctionDummy(const Symbol &symbol) { 226 return IsDummy(symbol) && IsInStmtFunction(symbol); 227 } 228 229 bool IsStmtFunctionResult(const Symbol &symbol) { 230 return IsFunctionResult(symbol) && IsInStmtFunction(symbol); 231 } 232 233 bool IsPointerDummy(const Symbol &symbol) { 234 return IsPointer(symbol) && IsDummy(symbol); 235 } 236 237 // proc-name 238 bool IsProcName(const Symbol &symbol) { 239 return symbol.GetUltimate().has<ProcEntityDetails>(); 240 } 241 242 bool IsBindCProcedure(const Symbol &symbol) { 243 if (const auto *procDetails{symbol.detailsIf<ProcEntityDetails>()}) { 244 if (const Symbol * procInterface{procDetails->interface().symbol()}) { 245 // procedure component with a BIND(C) interface 246 return IsBindCProcedure(*procInterface); 247 } 248 } 249 return symbol.attrs().test(Attr::BIND_C) && IsProcedure(symbol); 250 } 251 252 bool IsBindCProcedure(const Scope &scope) { 253 if (const Symbol * symbol{scope.GetSymbol()}) { 254 return IsBindCProcedure(*symbol); 255 } else { 256 return false; 257 } 258 } 259 260 static const Symbol *FindPointerComponent( 261 const Scope &scope, std::set<const Scope *> &visited) { 262 if (!scope.IsDerivedType()) { 263 return nullptr; 264 } 265 if (!visited.insert(&scope).second) { 266 return nullptr; 267 } 268 // If there's a top-level pointer component, return it for clearer error 269 // messaging. 270 for (const auto &pair : scope) { 271 const Symbol &symbol{*pair.second}; 272 if (IsPointer(symbol)) { 273 return &symbol; 274 } 275 } 276 for (const auto &pair : scope) { 277 const Symbol &symbol{*pair.second}; 278 if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) { 279 if (const DeclTypeSpec * type{details->type()}) { 280 if (const DerivedTypeSpec * derived{type->AsDerived()}) { 281 if (const Scope * nested{derived->scope()}) { 282 if (const Symbol * 283 pointer{FindPointerComponent(*nested, visited)}) { 284 return pointer; 285 } 286 } 287 } 288 } 289 } 290 } 291 return nullptr; 292 } 293 294 const Symbol *FindPointerComponent(const Scope &scope) { 295 std::set<const Scope *> visited; 296 return FindPointerComponent(scope, visited); 297 } 298 299 const Symbol *FindPointerComponent(const DerivedTypeSpec &derived) { 300 if (const Scope * scope{derived.scope()}) { 301 return FindPointerComponent(*scope); 302 } else { 303 return nullptr; 304 } 305 } 306 307 const Symbol *FindPointerComponent(const DeclTypeSpec &type) { 308 if (const DerivedTypeSpec * derived{type.AsDerived()}) { 309 return FindPointerComponent(*derived); 310 } else { 311 return nullptr; 312 } 313 } 314 315 const Symbol *FindPointerComponent(const DeclTypeSpec *type) { 316 return type ? FindPointerComponent(*type) : nullptr; 317 } 318 319 const Symbol *FindPointerComponent(const Symbol &symbol) { 320 return IsPointer(symbol) ? &symbol : FindPointerComponent(symbol.GetType()); 321 } 322 323 // C1594 specifies several ways by which an object might be globally visible. 324 const Symbol *FindExternallyVisibleObject( 325 const Symbol &object, const Scope &scope) { 326 // TODO: Storage association with any object for which this predicate holds, 327 // once EQUIVALENCE is supported. 328 if (IsUseAssociated(object, scope) || IsHostAssociated(object, scope) || 329 (IsPureProcedure(scope) && IsPointerDummy(object)) || 330 (IsIntentIn(object) && IsDummy(object))) { 331 return &object; 332 } else if (const Symbol * block{FindCommonBlockContaining(object)}) { 333 return block; 334 } else { 335 return nullptr; 336 } 337 } 338 339 bool ExprHasTypeCategory( 340 const SomeExpr &expr, const common::TypeCategory &type) { 341 auto dynamicType{expr.GetType()}; 342 return dynamicType && dynamicType->category() == type; 343 } 344 345 bool ExprTypeKindIsDefault( 346 const SomeExpr &expr, const SemanticsContext &context) { 347 auto dynamicType{expr.GetType()}; 348 return dynamicType && 349 dynamicType->category() != common::TypeCategory::Derived && 350 dynamicType->kind() == context.GetDefaultKind(dynamicType->category()); 351 } 352 353 // If an analyzed expr or assignment is missing, dump the node and die. 354 template <typename T> 355 static void CheckMissingAnalysis(bool absent, const T &x) { 356 if (absent) { 357 std::string buf; 358 llvm::raw_string_ostream ss{buf}; 359 ss << "node has not been analyzed:\n"; 360 parser::DumpTree(ss, x); 361 common::die(ss.str().c_str()); 362 } 363 } 364 365 const SomeExpr *GetExprHelper::Get(const parser::Expr &x) { 366 CheckMissingAnalysis(!x.typedExpr, x); 367 return common::GetPtrFromOptional(x.typedExpr->v); 368 } 369 const SomeExpr *GetExprHelper::Get(const parser::Variable &x) { 370 CheckMissingAnalysis(!x.typedExpr, x); 371 return common::GetPtrFromOptional(x.typedExpr->v); 372 } 373 const SomeExpr *GetExprHelper::Get(const parser::DataStmtConstant &x) { 374 CheckMissingAnalysis(!x.typedExpr, x); 375 return common::GetPtrFromOptional(x.typedExpr->v); 376 } 377 378 const evaluate::Assignment *GetAssignment(const parser::AssignmentStmt &x) { 379 CheckMissingAnalysis(!x.typedAssignment, x); 380 return common::GetPtrFromOptional(x.typedAssignment->v); 381 } 382 const evaluate::Assignment *GetAssignment( 383 const parser::PointerAssignmentStmt &x) { 384 CheckMissingAnalysis(!x.typedAssignment, x); 385 return common::GetPtrFromOptional(x.typedAssignment->v); 386 } 387 388 const Symbol *FindInterface(const Symbol &symbol) { 389 return std::visit( 390 common::visitors{ 391 [](const ProcEntityDetails &details) { 392 return details.interface().symbol(); 393 }, 394 [](const ProcBindingDetails &details) { return &details.symbol(); }, 395 [](const auto &) -> const Symbol * { return nullptr; }, 396 }, 397 symbol.details()); 398 } 399 400 const Symbol *FindSubprogram(const Symbol &symbol) { 401 return std::visit( 402 common::visitors{ 403 [&](const ProcEntityDetails &details) -> const Symbol * { 404 if (const Symbol * interface{details.interface().symbol()}) { 405 return FindSubprogram(*interface); 406 } else { 407 return &symbol; 408 } 409 }, 410 [](const ProcBindingDetails &details) { 411 return FindSubprogram(details.symbol()); 412 }, 413 [&](const SubprogramDetails &) { return &symbol; }, 414 [](const UseDetails &details) { 415 return FindSubprogram(details.symbol()); 416 }, 417 [](const HostAssocDetails &details) { 418 return FindSubprogram(details.symbol()); 419 }, 420 [](const auto &) -> const Symbol * { return nullptr; }, 421 }, 422 symbol.details()); 423 } 424 425 const Symbol *FindFunctionResult(const Symbol &symbol) { 426 if (const Symbol * subp{FindSubprogram(symbol)}) { 427 if (const auto &subpDetails{subp->detailsIf<SubprogramDetails>()}) { 428 if (subpDetails->isFunction()) { 429 return &subpDetails->result(); 430 } 431 } 432 } 433 return nullptr; 434 } 435 436 const Symbol *FindOverriddenBinding(const Symbol &symbol) { 437 if (symbol.has<ProcBindingDetails>()) { 438 if (const DeclTypeSpec * parentType{FindParentTypeSpec(symbol.owner())}) { 439 if (const DerivedTypeSpec * parentDerived{parentType->AsDerived()}) { 440 if (const Scope * parentScope{parentDerived->typeSymbol().scope()}) { 441 return parentScope->FindComponent(symbol.name()); 442 } 443 } 444 } 445 } 446 return nullptr; 447 } 448 449 const DeclTypeSpec *FindParentTypeSpec(const DerivedTypeSpec &derived) { 450 return FindParentTypeSpec(derived.typeSymbol()); 451 } 452 453 const DeclTypeSpec *FindParentTypeSpec(const DeclTypeSpec &decl) { 454 if (const DerivedTypeSpec * derived{decl.AsDerived()}) { 455 return FindParentTypeSpec(*derived); 456 } else { 457 return nullptr; 458 } 459 } 460 461 const DeclTypeSpec *FindParentTypeSpec(const Scope &scope) { 462 if (scope.kind() == Scope::Kind::DerivedType) { 463 if (const auto *symbol{scope.symbol()}) { 464 return FindParentTypeSpec(*symbol); 465 } 466 } 467 return nullptr; 468 } 469 470 const DeclTypeSpec *FindParentTypeSpec(const Symbol &symbol) { 471 if (const Scope * scope{symbol.scope()}) { 472 if (const auto *details{symbol.detailsIf<DerivedTypeDetails>()}) { 473 if (const Symbol * parent{details->GetParentComponent(*scope)}) { 474 return parent->GetType(); 475 } 476 } 477 } 478 return nullptr; 479 } 480 481 bool IsExtensibleType(const DerivedTypeSpec *derived) { 482 return derived && !IsIsoCType(derived) && 483 !derived->typeSymbol().attrs().test(Attr::BIND_C) && 484 !derived->typeSymbol().get<DerivedTypeDetails>().sequence(); 485 } 486 487 bool IsBuiltinDerivedType(const DerivedTypeSpec *derived, const char *name) { 488 if (!derived) { 489 return false; 490 } else { 491 const auto &symbol{derived->typeSymbol()}; 492 return symbol.owner().IsModule() && 493 (symbol.owner().GetName().value() == "__fortran_builtins" || 494 symbol.owner().GetName().value() == "__fortran_type_info") && 495 symbol.name() == "__builtin_"s + name; 496 } 497 } 498 499 bool IsIsoCType(const DerivedTypeSpec *derived) { 500 return IsBuiltinDerivedType(derived, "c_ptr") || 501 IsBuiltinDerivedType(derived, "c_funptr"); 502 } 503 504 bool IsTeamType(const DerivedTypeSpec *derived) { 505 return IsBuiltinDerivedType(derived, "team_type"); 506 } 507 508 bool IsEventTypeOrLockType(const DerivedTypeSpec *derivedTypeSpec) { 509 return IsBuiltinDerivedType(derivedTypeSpec, "event_type") || 510 IsBuiltinDerivedType(derivedTypeSpec, "lock_type"); 511 } 512 513 bool IsOrContainsEventOrLockComponent(const Symbol &symbol) { 514 if (const Symbol * root{GetAssociationRoot(symbol)}) { 515 if (const auto *details{root->detailsIf<ObjectEntityDetails>()}) { 516 if (const DeclTypeSpec * type{details->type()}) { 517 if (const DerivedTypeSpec * derived{type->AsDerived()}) { 518 return IsEventTypeOrLockType(derived) || 519 FindEventOrLockPotentialComponent(*derived); 520 } 521 } 522 } 523 } 524 return false; 525 } 526 527 // Check this symbol suitable as a type-bound procedure - C769 528 bool CanBeTypeBoundProc(const Symbol *symbol) { 529 if (!symbol || IsDummy(*symbol) || IsProcedurePointer(*symbol)) { 530 return false; 531 } else if (symbol->has<SubprogramNameDetails>()) { 532 return symbol->owner().kind() == Scope::Kind::Module; 533 } else if (auto *details{symbol->detailsIf<SubprogramDetails>()}) { 534 return symbol->owner().kind() == Scope::Kind::Module || 535 details->isInterface(); 536 } else if (const auto *proc{symbol->detailsIf<ProcEntityDetails>()}) { 537 return !symbol->attrs().test(Attr::INTRINSIC) && 538 proc->HasExplicitInterface(); 539 } else { 540 return false; 541 } 542 } 543 544 bool IsInitialized(const Symbol &symbol, bool ignoreDATAstatements, 545 const Symbol *derivedTypeSymbol) { 546 if (!ignoreDATAstatements && symbol.test(Symbol::Flag::InDataStmt)) { 547 return true; 548 } else if (IsNamedConstant(symbol)) { 549 return false; 550 } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) { 551 if (object->init()) { 552 return true; 553 } else if (object->isDummy() || IsFunctionResult(symbol)) { 554 return false; 555 } else if (IsAllocatable(symbol)) { 556 return true; 557 } else if (!IsPointer(symbol) && object->type()) { 558 if (const auto *derived{object->type()->AsDerived()}) { 559 if (&derived->typeSymbol() == derivedTypeSymbol) { 560 // error recovery: avoid infinite recursion on invalid 561 // recursive usage of a derived type 562 } else if (derived->HasDefaultInitialization()) { 563 return true; 564 } 565 } 566 } 567 } else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) { 568 return proc->init().has_value(); 569 } 570 return false; 571 } 572 573 bool HasIntrinsicTypeName(const Symbol &symbol) { 574 std::string name{symbol.name().ToString()}; 575 if (name == "doubleprecision") { 576 return true; 577 } else if (name == "derived") { 578 return false; 579 } else { 580 for (int i{0}; i != common::TypeCategory_enumSize; ++i) { 581 if (name == parser::ToLowerCaseLetters(EnumToString(TypeCategory{i}))) { 582 return true; 583 } 584 } 585 return false; 586 } 587 } 588 589 bool IsSeparateModuleProcedureInterface(const Symbol *symbol) { 590 if (symbol && symbol->attrs().test(Attr::MODULE)) { 591 if (auto *details{symbol->detailsIf<SubprogramDetails>()}) { 592 return details->isInterface(); 593 } 594 } 595 return false; 596 } 597 598 // 3.11 automatic data object 599 bool IsAutomatic(const Symbol &symbol) { 600 if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) { 601 if (!object->isDummy() && !IsAllocatable(symbol) && !IsPointer(symbol)) { 602 if (const DeclTypeSpec * type{symbol.GetType()}) { 603 // If a type parameter value is not a constant expression, the 604 // object is automatic. 605 if (type->category() == DeclTypeSpec::Character) { 606 if (const auto &length{ 607 type->characterTypeSpec().length().GetExplicit()}) { 608 if (!evaluate::IsConstantExpr(*length)) { 609 return true; 610 } 611 } 612 } else if (const DerivedTypeSpec * derived{type->AsDerived()}) { 613 for (const auto &pair : derived->parameters()) { 614 if (const auto &value{pair.second.GetExplicit()}) { 615 if (!evaluate::IsConstantExpr(*value)) { 616 return true; 617 } 618 } 619 } 620 } 621 } 622 // If an array bound is not a constant expression, the object is 623 // automatic. 624 for (const ShapeSpec &dim : object->shape()) { 625 if (const auto &lb{dim.lbound().GetExplicit()}) { 626 if (!evaluate::IsConstantExpr(*lb)) { 627 return true; 628 } 629 } 630 if (const auto &ub{dim.ubound().GetExplicit()}) { 631 if (!evaluate::IsConstantExpr(*ub)) { 632 return true; 633 } 634 } 635 } 636 } 637 } 638 return false; 639 } 640 641 bool IsFinalizable(const Symbol &symbol) { 642 if (IsPointer(symbol)) { 643 return false; 644 } 645 if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) { 646 if (object->isDummy() && !IsIntentOut(symbol)) { 647 return false; 648 } 649 const DeclTypeSpec *type{object->type()}; 650 const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr}; 651 return derived && IsFinalizable(*derived); 652 } 653 return false; 654 } 655 656 bool IsFinalizable(const DerivedTypeSpec &derived) { 657 if (!derived.typeSymbol().get<DerivedTypeDetails>().finals().empty()) { 658 return true; 659 } 660 DirectComponentIterator components{derived}; 661 return bool{std::find_if(components.begin(), components.end(), 662 [](const Symbol &component) { return IsFinalizable(component); })}; 663 } 664 665 bool HasImpureFinal(const DerivedTypeSpec &derived) { 666 if (const auto *details{ 667 derived.typeSymbol().detailsIf<DerivedTypeDetails>()}) { 668 const auto &finals{details->finals()}; 669 return std::any_of(finals.begin(), finals.end(), 670 [](const auto &x) { return !x.second->attrs().test(Attr::PURE); }); 671 } else { 672 return false; 673 } 674 } 675 676 bool IsCoarray(const Symbol &symbol) { return symbol.Corank() > 0; } 677 678 bool IsAutomaticObject(const Symbol &symbol) { 679 if (IsDummy(symbol) || IsPointer(symbol) || IsAllocatable(symbol)) { 680 return false; 681 } 682 if (const DeclTypeSpec * type{symbol.GetType()}) { 683 if (type->category() == DeclTypeSpec::Character) { 684 ParamValue length{type->characterTypeSpec().length()}; 685 if (length.isExplicit()) { 686 if (MaybeIntExpr lengthExpr{length.GetExplicit()}) { 687 if (!ToInt64(lengthExpr)) { 688 return true; 689 } 690 } 691 } 692 } 693 } 694 if (symbol.IsObjectArray()) { 695 for (const ShapeSpec &spec : symbol.get<ObjectEntityDetails>().shape()) { 696 auto &lbound{spec.lbound().GetExplicit()}; 697 auto &ubound{spec.ubound().GetExplicit()}; 698 if ((lbound && !evaluate::ToInt64(*lbound)) || 699 (ubound && !evaluate::ToInt64(*ubound))) { 700 return true; 701 } 702 } 703 } 704 return false; 705 } 706 707 bool IsAssumedLengthCharacter(const Symbol &symbol) { 708 if (const DeclTypeSpec * type{symbol.GetType()}) { 709 return type->category() == DeclTypeSpec::Character && 710 type->characterTypeSpec().length().isAssumed(); 711 } else { 712 return false; 713 } 714 } 715 716 bool IsInBlankCommon(const Symbol &symbol) { 717 const Symbol *block{FindCommonBlockContaining(symbol)}; 718 return block && block->name().empty(); 719 } 720 721 // C722 and C723: For a function to be assumed length, it must be external and 722 // of CHARACTER type 723 bool IsExternal(const Symbol &symbol) { 724 return ClassifyProcedure(symbol) == ProcedureDefinitionClass::External; 725 } 726 727 bool IsModuleProcedure(const Symbol &symbol) { 728 return ClassifyProcedure(symbol) == ProcedureDefinitionClass::Module; 729 } 730 const Symbol *IsExternalInPureContext( 731 const Symbol &symbol, const Scope &scope) { 732 if (const auto *pureProc{FindPureProcedureContaining(scope)}) { 733 if (const Symbol * root{GetAssociationRoot(symbol)}) { 734 if (const Symbol * 735 visible{FindExternallyVisibleObject(*root, *pureProc)}) { 736 return visible; 737 } 738 } 739 } 740 return nullptr; 741 } 742 743 PotentialComponentIterator::const_iterator FindPolymorphicPotentialComponent( 744 const DerivedTypeSpec &derived) { 745 PotentialComponentIterator potentials{derived}; 746 return std::find_if( 747 potentials.begin(), potentials.end(), [](const Symbol &component) { 748 if (const auto *details{component.detailsIf<ObjectEntityDetails>()}) { 749 const DeclTypeSpec *type{details->type()}; 750 return type && type->IsPolymorphic(); 751 } 752 return false; 753 }); 754 } 755 756 bool IsOrContainsPolymorphicComponent(const Symbol &symbol) { 757 if (const Symbol * root{GetAssociationRoot(symbol)}) { 758 if (const auto *details{root->detailsIf<ObjectEntityDetails>()}) { 759 if (const DeclTypeSpec * type{details->type()}) { 760 if (type->IsPolymorphic()) { 761 return true; 762 } 763 if (const DerivedTypeSpec * derived{type->AsDerived()}) { 764 return (bool)FindPolymorphicPotentialComponent(*derived); 765 } 766 } 767 } 768 } 769 return false; 770 } 771 772 bool InProtectedContext(const Symbol &symbol, const Scope ¤tScope) { 773 return IsProtected(symbol) && !IsHostAssociated(symbol, currentScope); 774 } 775 776 // C1101 and C1158 777 std::optional<parser::MessageFixedText> WhyNotModifiable( 778 const Symbol &symbol, const Scope &scope) { 779 const Symbol *root{GetAssociationRoot(symbol)}; 780 if (!root) { 781 return "'%s' is construct associated with an expression"_en_US; 782 } else if (InProtectedContext(*root, scope)) { 783 return "'%s' is protected in this scope"_en_US; 784 } else if (IsExternalInPureContext(*root, scope)) { 785 return "'%s' is externally visible and referenced in a pure" 786 " procedure"_en_US; 787 } else if (IsOrContainsEventOrLockComponent(*root)) { 788 return "'%s' is an entity with either an EVENT_TYPE or LOCK_TYPE"_en_US; 789 } else if (IsIntentIn(*root)) { 790 return "'%s' is an INTENT(IN) dummy argument"_en_US; 791 } else if (!IsVariableName(*root)) { 792 return "'%s' is not a variable"_en_US; 793 } else { 794 return std::nullopt; 795 } 796 } 797 798 std::optional<parser::Message> WhyNotModifiable(parser::CharBlock at, 799 const SomeExpr &expr, const Scope &scope, bool vectorSubscriptIsOk) { 800 if (!evaluate::IsVariable(expr)) { 801 return parser::Message{at, "Expression is not a variable"_en_US}; 802 } else if (auto dataRef{evaluate::ExtractDataRef(expr, true)}) { 803 if (!vectorSubscriptIsOk && evaluate::HasVectorSubscript(expr)) { 804 return parser::Message{at, "Variable has a vector subscript"_en_US}; 805 } 806 const Symbol &symbol{dataRef->GetFirstSymbol()}; 807 if (auto maybeWhy{WhyNotModifiable(symbol, scope)}) { 808 return parser::Message{symbol.name(), 809 parser::MessageFormattedText{std::move(*maybeWhy), symbol.name()}}; 810 } 811 } else { 812 // reference to function returning POINTER 813 } 814 return std::nullopt; 815 } 816 817 class ImageControlStmtHelper { 818 using ImageControlStmts = std::variant<parser::ChangeTeamConstruct, 819 parser::CriticalConstruct, parser::EventPostStmt, parser::EventWaitStmt, 820 parser::FormTeamStmt, parser::LockStmt, parser::StopStmt, 821 parser::SyncAllStmt, parser::SyncImagesStmt, parser::SyncMemoryStmt, 822 parser::SyncTeamStmt, parser::UnlockStmt>; 823 824 public: 825 template <typename T> bool operator()(const T &) { 826 return common::HasMember<T, ImageControlStmts>; 827 } 828 template <typename T> bool operator()(const common::Indirection<T> &x) { 829 return (*this)(x.value()); 830 } 831 bool operator()(const parser::AllocateStmt &stmt) { 832 const auto &allocationList{std::get<std::list<parser::Allocation>>(stmt.t)}; 833 for (const auto &allocation : allocationList) { 834 const auto &allocateObject{ 835 std::get<parser::AllocateObject>(allocation.t)}; 836 if (IsCoarrayObject(allocateObject)) { 837 return true; 838 } 839 } 840 return false; 841 } 842 bool operator()(const parser::DeallocateStmt &stmt) { 843 const auto &allocateObjectList{ 844 std::get<std::list<parser::AllocateObject>>(stmt.t)}; 845 for (const auto &allocateObject : allocateObjectList) { 846 if (IsCoarrayObject(allocateObject)) { 847 return true; 848 } 849 } 850 return false; 851 } 852 bool operator()(const parser::CallStmt &stmt) { 853 const auto &procedureDesignator{ 854 std::get<parser::ProcedureDesignator>(stmt.v.t)}; 855 if (auto *name{std::get_if<parser::Name>(&procedureDesignator.u)}) { 856 // TODO: also ensure that the procedure is, in fact, an intrinsic 857 if (name->source == "move_alloc") { 858 const auto &args{std::get<std::list<parser::ActualArgSpec>>(stmt.v.t)}; 859 if (!args.empty()) { 860 const parser::ActualArg &actualArg{ 861 std::get<parser::ActualArg>(args.front().t)}; 862 if (const auto *argExpr{ 863 std::get_if<common::Indirection<parser::Expr>>( 864 &actualArg.u)}) { 865 return HasCoarray(argExpr->value()); 866 } 867 } 868 } 869 } 870 return false; 871 } 872 bool operator()(const parser::Statement<parser::ActionStmt> &stmt) { 873 return std::visit(*this, stmt.statement.u); 874 } 875 876 private: 877 bool IsCoarrayObject(const parser::AllocateObject &allocateObject) { 878 const parser::Name &name{GetLastName(allocateObject)}; 879 return name.symbol && IsCoarray(*name.symbol); 880 } 881 }; 882 883 bool IsImageControlStmt(const parser::ExecutableConstruct &construct) { 884 return std::visit(ImageControlStmtHelper{}, construct.u); 885 } 886 887 std::optional<parser::MessageFixedText> GetImageControlStmtCoarrayMsg( 888 const parser::ExecutableConstruct &construct) { 889 if (const auto *actionStmt{ 890 std::get_if<parser::Statement<parser::ActionStmt>>(&construct.u)}) { 891 return std::visit( 892 common::visitors{ 893 [](const common::Indirection<parser::AllocateStmt> &) 894 -> std::optional<parser::MessageFixedText> { 895 return "ALLOCATE of a coarray is an image control" 896 " statement"_en_US; 897 }, 898 [](const common::Indirection<parser::DeallocateStmt> &) 899 -> std::optional<parser::MessageFixedText> { 900 return "DEALLOCATE of a coarray is an image control" 901 " statement"_en_US; 902 }, 903 [](const common::Indirection<parser::CallStmt> &) 904 -> std::optional<parser::MessageFixedText> { 905 return "MOVE_ALLOC of a coarray is an image control" 906 " statement "_en_US; 907 }, 908 [](const auto &) -> std::optional<parser::MessageFixedText> { 909 return std::nullopt; 910 }, 911 }, 912 actionStmt->statement.u); 913 } 914 return std::nullopt; 915 } 916 917 parser::CharBlock GetImageControlStmtLocation( 918 const parser::ExecutableConstruct &executableConstruct) { 919 return std::visit( 920 common::visitors{ 921 [](const common::Indirection<parser::ChangeTeamConstruct> 922 &construct) { 923 return std::get<parser::Statement<parser::ChangeTeamStmt>>( 924 construct.value().t) 925 .source; 926 }, 927 [](const common::Indirection<parser::CriticalConstruct> &construct) { 928 return std::get<parser::Statement<parser::CriticalStmt>>( 929 construct.value().t) 930 .source; 931 }, 932 [](const parser::Statement<parser::ActionStmt> &actionStmt) { 933 return actionStmt.source; 934 }, 935 [](const auto &) { return parser::CharBlock{}; }, 936 }, 937 executableConstruct.u); 938 } 939 940 bool HasCoarray(const parser::Expr &expression) { 941 if (const auto *expr{GetExpr(expression)}) { 942 for (const Symbol &symbol : evaluate::CollectSymbols(*expr)) { 943 if (const Symbol * root{GetAssociationRoot(symbol)}) { 944 if (IsCoarray(*root)) { 945 return true; 946 } 947 } 948 } 949 } 950 return false; 951 } 952 953 bool IsPolymorphic(const Symbol &symbol) { 954 if (const DeclTypeSpec * type{symbol.GetType()}) { 955 return type->IsPolymorphic(); 956 } 957 return false; 958 } 959 960 bool IsPolymorphicAllocatable(const Symbol &symbol) { 961 return IsAllocatable(symbol) && IsPolymorphic(symbol); 962 } 963 964 std::optional<parser::MessageFormattedText> CheckAccessibleComponent( 965 const Scope &scope, const Symbol &symbol) { 966 CHECK(symbol.owner().IsDerivedType()); // symbol must be a component 967 if (symbol.attrs().test(Attr::PRIVATE)) { 968 if (const Scope * moduleScope{FindModuleContaining(symbol.owner())}) { 969 if (!moduleScope->Contains(scope)) { 970 return parser::MessageFormattedText{ 971 "PRIVATE component '%s' is only accessible within module '%s'"_err_en_US, 972 symbol.name(), moduleScope->GetName().value()}; 973 } 974 } 975 } 976 return std::nullopt; 977 } 978 979 std::list<SourceName> OrderParameterNames(const Symbol &typeSymbol) { 980 std::list<SourceName> result; 981 if (const DerivedTypeSpec * spec{typeSymbol.GetParentTypeSpec()}) { 982 result = OrderParameterNames(spec->typeSymbol()); 983 } 984 const auto ¶mNames{typeSymbol.get<DerivedTypeDetails>().paramNames()}; 985 result.insert(result.end(), paramNames.begin(), paramNames.end()); 986 return result; 987 } 988 989 SymbolVector OrderParameterDeclarations(const Symbol &typeSymbol) { 990 SymbolVector result; 991 if (const DerivedTypeSpec * spec{typeSymbol.GetParentTypeSpec()}) { 992 result = OrderParameterDeclarations(spec->typeSymbol()); 993 } 994 const auto ¶mDecls{typeSymbol.get<DerivedTypeDetails>().paramDecls()}; 995 result.insert(result.end(), paramDecls.begin(), paramDecls.end()); 996 return result; 997 } 998 999 const DeclTypeSpec &FindOrInstantiateDerivedType(Scope &scope, 1000 DerivedTypeSpec &&spec, SemanticsContext &semanticsContext, 1001 DeclTypeSpec::Category category) { 1002 spec.EvaluateParameters(semanticsContext); 1003 if (const DeclTypeSpec * 1004 type{scope.FindInstantiatedDerivedType(spec, category)}) { 1005 return *type; 1006 } 1007 // Create a new instantiation of this parameterized derived type 1008 // for this particular distinct set of actual parameter values. 1009 DeclTypeSpec &type{scope.MakeDerivedType(category, std::move(spec))}; 1010 type.derivedTypeSpec().Instantiate(scope, semanticsContext); 1011 return type; 1012 } 1013 1014 const Symbol *FindSeparateModuleSubprogramInterface(const Symbol *proc) { 1015 if (proc) { 1016 if (const Symbol * submodule{proc->owner().symbol()}) { 1017 if (const auto *details{submodule->detailsIf<ModuleDetails>()}) { 1018 if (const Scope * ancestor{details->ancestor()}) { 1019 const Symbol *iface{ancestor->FindSymbol(proc->name())}; 1020 if (IsSeparateModuleProcedureInterface(iface)) { 1021 return iface; 1022 } 1023 } 1024 } 1025 } 1026 } 1027 return nullptr; 1028 } 1029 1030 ProcedureDefinitionClass ClassifyProcedure(const Symbol &symbol) { // 15.2.2 1031 const Symbol &ultimate{symbol.GetUltimate()}; 1032 if (ultimate.attrs().test(Attr::INTRINSIC)) { 1033 return ProcedureDefinitionClass::Intrinsic; 1034 } else if (ultimate.attrs().test(Attr::EXTERNAL)) { 1035 return ProcedureDefinitionClass::External; 1036 } else if (const auto *procDetails{ultimate.detailsIf<ProcEntityDetails>()}) { 1037 if (procDetails->isDummy()) { 1038 return ProcedureDefinitionClass::Dummy; 1039 } else if (IsPointer(ultimate)) { 1040 return ProcedureDefinitionClass::Pointer; 1041 } 1042 } else if (const Symbol * subp{FindSubprogram(symbol)}) { 1043 if (const auto *subpDetails{subp->detailsIf<SubprogramDetails>()}) { 1044 if (subpDetails->stmtFunction()) { 1045 return ProcedureDefinitionClass::StatementFunction; 1046 } 1047 } 1048 switch (ultimate.owner().kind()) { 1049 case Scope::Kind::Global: 1050 return ProcedureDefinitionClass::External; 1051 case Scope::Kind::Module: 1052 return ProcedureDefinitionClass::Module; 1053 case Scope::Kind::MainProgram: 1054 case Scope::Kind::Subprogram: 1055 return ProcedureDefinitionClass::Internal; 1056 default: 1057 break; 1058 } 1059 } 1060 return ProcedureDefinitionClass::None; 1061 } 1062 1063 // ComponentIterator implementation 1064 1065 template <ComponentKind componentKind> 1066 typename ComponentIterator<componentKind>::const_iterator 1067 ComponentIterator<componentKind>::const_iterator::Create( 1068 const DerivedTypeSpec &derived) { 1069 const_iterator it{}; 1070 it.componentPath_.emplace_back(derived); 1071 it.Increment(); // cue up first relevant component, if any 1072 return it; 1073 } 1074 1075 template <ComponentKind componentKind> 1076 const DerivedTypeSpec * 1077 ComponentIterator<componentKind>::const_iterator::PlanComponentTraversal( 1078 const Symbol &component) const { 1079 if (const auto *details{component.detailsIf<ObjectEntityDetails>()}) { 1080 if (const DeclTypeSpec * type{details->type()}) { 1081 if (const auto *derived{type->AsDerived()}) { 1082 bool traverse{false}; 1083 if constexpr (componentKind == ComponentKind::Ordered) { 1084 // Order Component (only visit parents) 1085 traverse = component.test(Symbol::Flag::ParentComp); 1086 } else if constexpr (componentKind == ComponentKind::Direct) { 1087 traverse = !IsAllocatableOrPointer(component); 1088 } else if constexpr (componentKind == ComponentKind::Ultimate) { 1089 traverse = !IsAllocatableOrPointer(component); 1090 } else if constexpr (componentKind == ComponentKind::Potential) { 1091 traverse = !IsPointer(component); 1092 } else if constexpr (componentKind == ComponentKind::Scope) { 1093 traverse = !IsAllocatableOrPointer(component); 1094 } 1095 if (traverse) { 1096 const Symbol &newTypeSymbol{derived->typeSymbol()}; 1097 // Avoid infinite loop if the type is already part of the types 1098 // being visited. It is possible to have "loops in type" because 1099 // C744 does not forbid to use not yet declared type for 1100 // ALLOCATABLE or POINTER components. 1101 for (const auto &node : componentPath_) { 1102 if (&newTypeSymbol == &node.GetTypeSymbol()) { 1103 return nullptr; 1104 } 1105 } 1106 return derived; 1107 } 1108 } 1109 } // intrinsic & unlimited polymorphic not traversable 1110 } 1111 return nullptr; 1112 } 1113 1114 template <ComponentKind componentKind> 1115 static bool StopAtComponentPre(const Symbol &component) { 1116 if constexpr (componentKind == ComponentKind::Ordered) { 1117 // Parent components need to be iterated upon after their 1118 // sub-components in structure constructor analysis. 1119 return !component.test(Symbol::Flag::ParentComp); 1120 } else if constexpr (componentKind == ComponentKind::Direct) { 1121 return true; 1122 } else if constexpr (componentKind == ComponentKind::Ultimate) { 1123 return component.has<ProcEntityDetails>() || 1124 IsAllocatableOrPointer(component) || 1125 (component.get<ObjectEntityDetails>().type() && 1126 component.get<ObjectEntityDetails>().type()->AsIntrinsic()); 1127 } else if constexpr (componentKind == ComponentKind::Potential) { 1128 return !IsPointer(component); 1129 } 1130 } 1131 1132 template <ComponentKind componentKind> 1133 static bool StopAtComponentPost(const Symbol &component) { 1134 return componentKind == ComponentKind::Ordered && 1135 component.test(Symbol::Flag::ParentComp); 1136 } 1137 1138 template <ComponentKind componentKind> 1139 void ComponentIterator<componentKind>::const_iterator::Increment() { 1140 while (!componentPath_.empty()) { 1141 ComponentPathNode &deepest{componentPath_.back()}; 1142 if (deepest.component()) { 1143 if (!deepest.descended()) { 1144 deepest.set_descended(true); 1145 if (const DerivedTypeSpec * 1146 derived{PlanComponentTraversal(*deepest.component())}) { 1147 componentPath_.emplace_back(*derived); 1148 continue; 1149 } 1150 } else if (!deepest.visited()) { 1151 deepest.set_visited(true); 1152 return; // this is the next component to visit, after descending 1153 } 1154 } 1155 auto &nameIterator{deepest.nameIterator()}; 1156 if (nameIterator == deepest.nameEnd()) { 1157 componentPath_.pop_back(); 1158 } else if constexpr (componentKind == ComponentKind::Scope) { 1159 deepest.set_component(*nameIterator++->second); 1160 deepest.set_descended(false); 1161 deepest.set_visited(true); 1162 return; // this is the next component to visit, before descending 1163 } else { 1164 const Scope &scope{deepest.GetScope()}; 1165 auto scopeIter{scope.find(*nameIterator++)}; 1166 if (scopeIter != scope.cend()) { 1167 const Symbol &component{*scopeIter->second}; 1168 deepest.set_component(component); 1169 deepest.set_descended(false); 1170 if (StopAtComponentPre<componentKind>(component)) { 1171 deepest.set_visited(true); 1172 return; // this is the next component to visit, before descending 1173 } else { 1174 deepest.set_visited(!StopAtComponentPost<componentKind>(component)); 1175 } 1176 } 1177 } 1178 } 1179 } 1180 1181 template <ComponentKind componentKind> 1182 std::string 1183 ComponentIterator<componentKind>::const_iterator::BuildResultDesignatorName() 1184 const { 1185 std::string designator{""}; 1186 for (const auto &node : componentPath_) { 1187 designator += "%" + DEREF(node.component()).name().ToString(); 1188 } 1189 return designator; 1190 } 1191 1192 template class ComponentIterator<ComponentKind::Ordered>; 1193 template class ComponentIterator<ComponentKind::Direct>; 1194 template class ComponentIterator<ComponentKind::Ultimate>; 1195 template class ComponentIterator<ComponentKind::Potential>; 1196 template class ComponentIterator<ComponentKind::Scope>; 1197 1198 UltimateComponentIterator::const_iterator FindCoarrayUltimateComponent( 1199 const DerivedTypeSpec &derived) { 1200 UltimateComponentIterator ultimates{derived}; 1201 return std::find_if(ultimates.begin(), ultimates.end(), IsCoarray); 1202 } 1203 1204 UltimateComponentIterator::const_iterator FindPointerUltimateComponent( 1205 const DerivedTypeSpec &derived) { 1206 UltimateComponentIterator ultimates{derived}; 1207 return std::find_if(ultimates.begin(), ultimates.end(), IsPointer); 1208 } 1209 1210 PotentialComponentIterator::const_iterator FindEventOrLockPotentialComponent( 1211 const DerivedTypeSpec &derived) { 1212 PotentialComponentIterator potentials{derived}; 1213 return std::find_if( 1214 potentials.begin(), potentials.end(), [](const Symbol &component) { 1215 if (const auto *details{component.detailsIf<ObjectEntityDetails>()}) { 1216 const DeclTypeSpec *type{details->type()}; 1217 return type && IsEventTypeOrLockType(type->AsDerived()); 1218 } 1219 return false; 1220 }); 1221 } 1222 1223 UltimateComponentIterator::const_iterator FindAllocatableUltimateComponent( 1224 const DerivedTypeSpec &derived) { 1225 UltimateComponentIterator ultimates{derived}; 1226 return std::find_if(ultimates.begin(), ultimates.end(), IsAllocatable); 1227 } 1228 1229 UltimateComponentIterator::const_iterator 1230 FindPolymorphicAllocatableUltimateComponent(const DerivedTypeSpec &derived) { 1231 UltimateComponentIterator ultimates{derived}; 1232 return std::find_if( 1233 ultimates.begin(), ultimates.end(), IsPolymorphicAllocatable); 1234 } 1235 1236 UltimateComponentIterator::const_iterator 1237 FindPolymorphicAllocatableNonCoarrayUltimateComponent( 1238 const DerivedTypeSpec &derived) { 1239 UltimateComponentIterator ultimates{derived}; 1240 return std::find_if(ultimates.begin(), ultimates.end(), [](const Symbol &x) { 1241 return IsPolymorphicAllocatable(x) && !IsCoarray(x); 1242 }); 1243 } 1244 1245 const Symbol *FindUltimateComponent(const DerivedTypeSpec &derived, 1246 const std::function<bool(const Symbol &)> &predicate) { 1247 UltimateComponentIterator ultimates{derived}; 1248 if (auto it{std::find_if(ultimates.begin(), ultimates.end(), 1249 [&predicate](const Symbol &component) -> bool { 1250 return predicate(component); 1251 })}) { 1252 return &*it; 1253 } 1254 return nullptr; 1255 } 1256 1257 const Symbol *FindUltimateComponent(const Symbol &symbol, 1258 const std::function<bool(const Symbol &)> &predicate) { 1259 if (predicate(symbol)) { 1260 return &symbol; 1261 } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) { 1262 if (const auto *type{object->type()}) { 1263 if (const auto *derived{type->AsDerived()}) { 1264 return FindUltimateComponent(*derived, predicate); 1265 } 1266 } 1267 } 1268 return nullptr; 1269 } 1270 1271 const Symbol *FindImmediateComponent(const DerivedTypeSpec &type, 1272 const std::function<bool(const Symbol &)> &predicate) { 1273 if (const Scope * scope{type.scope()}) { 1274 const Symbol *parent{nullptr}; 1275 for (const auto &pair : *scope) { 1276 const Symbol *symbol{&*pair.second}; 1277 if (predicate(*symbol)) { 1278 return symbol; 1279 } 1280 if (symbol->test(Symbol::Flag::ParentComp)) { 1281 parent = symbol; 1282 } 1283 } 1284 if (parent) { 1285 if (const auto *object{parent->detailsIf<ObjectEntityDetails>()}) { 1286 if (const auto *type{object->type()}) { 1287 if (const auto *derived{type->AsDerived()}) { 1288 return FindImmediateComponent(*derived, predicate); 1289 } 1290 } 1291 } 1292 } 1293 } 1294 return nullptr; 1295 } 1296 1297 bool IsFunctionResultWithSameNameAsFunction(const Symbol &symbol) { 1298 if (IsFunctionResult(symbol)) { 1299 if (const Symbol * function{symbol.owner().symbol()}) { 1300 return symbol.name() == function->name(); 1301 } 1302 } 1303 return false; 1304 } 1305 1306 void LabelEnforce::Post(const parser::GotoStmt &gotoStmt) { 1307 checkLabelUse(gotoStmt.v); 1308 } 1309 void LabelEnforce::Post(const parser::ComputedGotoStmt &computedGotoStmt) { 1310 for (auto &i : std::get<std::list<parser::Label>>(computedGotoStmt.t)) { 1311 checkLabelUse(i); 1312 } 1313 } 1314 1315 void LabelEnforce::Post(const parser::ArithmeticIfStmt &arithmeticIfStmt) { 1316 checkLabelUse(std::get<1>(arithmeticIfStmt.t)); 1317 checkLabelUse(std::get<2>(arithmeticIfStmt.t)); 1318 checkLabelUse(std::get<3>(arithmeticIfStmt.t)); 1319 } 1320 1321 void LabelEnforce::Post(const parser::AssignStmt &assignStmt) { 1322 checkLabelUse(std::get<parser::Label>(assignStmt.t)); 1323 } 1324 1325 void LabelEnforce::Post(const parser::AssignedGotoStmt &assignedGotoStmt) { 1326 for (auto &i : std::get<std::list<parser::Label>>(assignedGotoStmt.t)) { 1327 checkLabelUse(i); 1328 } 1329 } 1330 1331 void LabelEnforce::Post(const parser::AltReturnSpec &altReturnSpec) { 1332 checkLabelUse(altReturnSpec.v); 1333 } 1334 1335 void LabelEnforce::Post(const parser::ErrLabel &errLabel) { 1336 checkLabelUse(errLabel.v); 1337 } 1338 void LabelEnforce::Post(const parser::EndLabel &endLabel) { 1339 checkLabelUse(endLabel.v); 1340 } 1341 void LabelEnforce::Post(const parser::EorLabel &eorLabel) { 1342 checkLabelUse(eorLabel.v); 1343 } 1344 1345 void LabelEnforce::checkLabelUse(const parser::Label &labelUsed) { 1346 if (labels_.find(labelUsed) == labels_.end()) { 1347 SayWithConstruct(context_, currentStatementSourcePosition_, 1348 parser::MessageFormattedText{ 1349 "Control flow escapes from %s"_err_en_US, construct_}, 1350 constructSourcePosition_); 1351 } 1352 } 1353 1354 parser::MessageFormattedText LabelEnforce::GetEnclosingConstructMsg() { 1355 return {"Enclosing %s statement"_en_US, construct_}; 1356 } 1357 1358 void LabelEnforce::SayWithConstruct(SemanticsContext &context, 1359 parser::CharBlock stmtLocation, parser::MessageFormattedText &&message, 1360 parser::CharBlock constructLocation) { 1361 context.Say(stmtLocation, message) 1362 .Attach(constructLocation, GetEnclosingConstructMsg()); 1363 } 1364 1365 bool HasAlternateReturns(const Symbol &subprogram) { 1366 for (const auto *dummyArg : subprogram.get<SubprogramDetails>().dummyArgs()) { 1367 if (!dummyArg) { 1368 return true; 1369 } 1370 } 1371 return false; 1372 } 1373 1374 bool InCommonBlock(const Symbol &symbol) { 1375 const auto *details{symbol.detailsIf<ObjectEntityDetails>()}; 1376 return details && details->commonBlock(); 1377 } 1378 1379 const std::optional<parser::Name> &MaybeGetNodeName( 1380 const ConstructNode &construct) { 1381 return std::visit( 1382 common::visitors{ 1383 [&](const parser::BlockConstruct *blockConstruct) 1384 -> const std::optional<parser::Name> & { 1385 return std::get<0>(blockConstruct->t).statement.v; 1386 }, 1387 [&](const auto *a) -> const std::optional<parser::Name> & { 1388 return std::get<0>(std::get<0>(a->t).statement.t); 1389 }, 1390 }, 1391 construct); 1392 } 1393 1394 } // namespace Fortran::semantics 1395