flang/lib/Semantics/tools.cpp

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