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