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