885 lines · cpp
1//===-- lib/Semantics/resolve-names-utils.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 "resolve-names-utils.h"10#include "flang/Common/idioms.h"11#include "flang/Common/indirection.h"12#include "flang/Evaluate/fold.h"13#include "flang/Evaluate/tools.h"14#include "flang/Evaluate/traverse.h"15#include "flang/Evaluate/type.h"16#include "flang/Parser/char-block.h"17#include "flang/Parser/parse-tree.h"18#include "flang/Semantics/expression.h"19#include "flang/Semantics/semantics.h"20#include "flang/Semantics/tools.h"21#include "flang/Support/Fortran-features.h"22#include "flang/Support/Fortran.h"23#include <initializer_list>24#include <variant>25 26namespace Fortran::semantics {27 28using common::LanguageFeature;29using common::LogicalOperator;30using common::NumericOperator;31using common::RelationalOperator;32using IntrinsicOperator = parser::DefinedOperator::IntrinsicOperator;33 34static GenericKind MapIntrinsicOperator(IntrinsicOperator);35 36Symbol *Resolve(const parser::Name &name, Symbol *symbol) {37 if (symbol && !name.symbol) {38 name.symbol = symbol;39 }40 return symbol;41}42Symbol &Resolve(const parser::Name &name, Symbol &symbol) {43 return *Resolve(name, &symbol);44}45 46parser::MessageFixedText WithSeverity(47 const parser::MessageFixedText &msg, parser::Severity severity) {48 return parser::MessageFixedText{49 msg.text().begin(), msg.text().size(), severity};50}51 52bool IsIntrinsicOperator(53 const SemanticsContext &context, const SourceName &name) {54 std::string str{name.ToString()};55 for (int i{0}; i != common::LogicalOperator_enumSize; ++i) {56 auto names{context.languageFeatures().GetNames(LogicalOperator{i})};57 if (llvm::is_contained(names, str)) {58 return true;59 }60 }61 for (int i{0}; i != common::RelationalOperator_enumSize; ++i) {62 auto names{context.languageFeatures().GetNames(RelationalOperator{i})};63 if (llvm::is_contained(names, str)) {64 return true;65 }66 }67 return false;68}69 70bool IsLogicalConstant(71 const SemanticsContext &context, const SourceName &name) {72 std::string str{name.ToString()};73 return str == ".true." || str == ".false." ||74 (context.IsEnabled(LanguageFeature::LogicalAbbreviations) &&75 (str == ".t" || str == ".f."));76}77 78void GenericSpecInfo::Resolve(Symbol *symbol) const {79 if (symbol) {80 if (auto *details{symbol->detailsIf<GenericDetails>()}) {81 details->set_kind(kind_);82 }83 if (parseName_) {84 semantics::Resolve(*parseName_, symbol);85 }86 }87}88 89void GenericSpecInfo::Analyze(const parser::DefinedOpName &name) {90 kind_ = GenericKind::OtherKind::DefinedOp;91 parseName_ = &name.v;92 symbolName_ = name.v.source;93}94 95void GenericSpecInfo::Analyze(const parser::GenericSpec &x) {96 symbolName_ = x.source;97 kind_ = common::visit(98 common::visitors{99 [&](const parser::Name &y) -> GenericKind {100 parseName_ = &y;101 symbolName_ = y.source;102 return GenericKind::OtherKind::Name;103 },104 [&](const parser::DefinedOperator &y) {105 return common::visit(106 common::visitors{107 [&](const parser::DefinedOpName &z) -> GenericKind {108 Analyze(z);109 return GenericKind::OtherKind::DefinedOp;110 },111 [&](const IntrinsicOperator &z) {112 return MapIntrinsicOperator(z);113 },114 },115 y.u);116 },117 [&](const parser::GenericSpec::Assignment &) -> GenericKind {118 return GenericKind::OtherKind::Assignment;119 },120 [&](const parser::GenericSpec::ReadFormatted &) -> GenericKind {121 return common::DefinedIo::ReadFormatted;122 },123 [&](const parser::GenericSpec::ReadUnformatted &) -> GenericKind {124 return common::DefinedIo::ReadUnformatted;125 },126 [&](const parser::GenericSpec::WriteFormatted &) -> GenericKind {127 return common::DefinedIo::WriteFormatted;128 },129 [&](const parser::GenericSpec::WriteUnformatted &) -> GenericKind {130 return common::DefinedIo::WriteUnformatted;131 },132 },133 x.u);134}135 136llvm::raw_ostream &operator<<(137 llvm::raw_ostream &os, const GenericSpecInfo &info) {138 os << "GenericSpecInfo: kind=" << info.kind_.ToString();139 os << " parseName="140 << (info.parseName_ ? info.parseName_->ToString() : "null");141 os << " symbolName="142 << (info.symbolName_ ? info.symbolName_->ToString() : "null");143 return os;144}145 146// parser::DefinedOperator::IntrinsicOperator -> GenericKind147static GenericKind MapIntrinsicOperator(IntrinsicOperator op) {148 switch (op) {149 SWITCH_COVERS_ALL_CASES150 case IntrinsicOperator::Concat:151 return GenericKind::OtherKind::Concat;152 case IntrinsicOperator::Power:153 return NumericOperator::Power;154 case IntrinsicOperator::Multiply:155 return NumericOperator::Multiply;156 case IntrinsicOperator::Divide:157 return NumericOperator::Divide;158 case IntrinsicOperator::Add:159 return NumericOperator::Add;160 case IntrinsicOperator::Subtract:161 return NumericOperator::Subtract;162 case IntrinsicOperator::AND:163 return LogicalOperator::And;164 case IntrinsicOperator::OR:165 return LogicalOperator::Or;166 case IntrinsicOperator::EQV:167 return LogicalOperator::Eqv;168 case IntrinsicOperator::NEQV:169 return LogicalOperator::Neqv;170 case IntrinsicOperator::NOT:171 return LogicalOperator::Not;172 case IntrinsicOperator::LT:173 return RelationalOperator::LT;174 case IntrinsicOperator::LE:175 return RelationalOperator::LE;176 case IntrinsicOperator::EQ:177 return RelationalOperator::EQ;178 case IntrinsicOperator::NE:179 return RelationalOperator::NE;180 case IntrinsicOperator::GE:181 return RelationalOperator::GE;182 case IntrinsicOperator::GT:183 return RelationalOperator::GT;184 }185}186 187class ArraySpecAnalyzer {188public:189 ArraySpecAnalyzer(SemanticsContext &context) : context_{context} {}190 ArraySpec Analyze(const parser::ArraySpec &);191 ArraySpec AnalyzeDeferredShapeSpecList(const parser::DeferredShapeSpecList &);192 ArraySpec Analyze(const parser::ComponentArraySpec &);193 ArraySpec Analyze(const parser::CoarraySpec &);194 195private:196 SemanticsContext &context_;197 ArraySpec arraySpec_;198 199 template <typename T> void Analyze(const std::list<T> &list) {200 for (const auto &elem : list) {201 Analyze(elem);202 }203 }204 void Analyze(const parser::AssumedShapeSpec &);205 void Analyze(const parser::ExplicitShapeSpec &);206 void Analyze(const parser::AssumedImpliedSpec &);207 void Analyze(const parser::DeferredShapeSpecList &);208 void Analyze(const parser::AssumedRankSpec &);209 void MakeExplicit(const std::optional<parser::SpecificationExpr> &,210 const parser::SpecificationExpr &);211 void MakeImplied(const std::optional<parser::SpecificationExpr> &);212 void MakeDeferred(int);213 Bound GetBound(const std::optional<parser::SpecificationExpr> &);214 Bound GetBound(const parser::SpecificationExpr &);215};216 217ArraySpec AnalyzeArraySpec(218 SemanticsContext &context, const parser::ArraySpec &arraySpec) {219 return ArraySpecAnalyzer{context}.Analyze(arraySpec);220}221ArraySpec AnalyzeArraySpec(222 SemanticsContext &context, const parser::ComponentArraySpec &arraySpec) {223 return ArraySpecAnalyzer{context}.Analyze(arraySpec);224}225ArraySpec AnalyzeDeferredShapeSpecList(SemanticsContext &context,226 const parser::DeferredShapeSpecList &deferredShapeSpecs) {227 return ArraySpecAnalyzer{context}.AnalyzeDeferredShapeSpecList(228 deferredShapeSpecs);229}230ArraySpec AnalyzeCoarraySpec(231 SemanticsContext &context, const parser::CoarraySpec &coarraySpec) {232 return ArraySpecAnalyzer{context}.Analyze(coarraySpec);233}234 235ArraySpec ArraySpecAnalyzer::Analyze(const parser::ComponentArraySpec &x) {236 common::visit([this](const auto &y) { Analyze(y); }, x.u);237 CHECK(!arraySpec_.empty());238 return arraySpec_;239}240ArraySpec ArraySpecAnalyzer::Analyze(const parser::ArraySpec &x) {241 common::visit(common::visitors{242 [&](const parser::AssumedSizeSpec &y) {243 Analyze(244 std::get<std::list<parser::ExplicitShapeSpec>>(y.t));245 Analyze(std::get<parser::AssumedImpliedSpec>(y.t));246 },247 [&](const parser::ImpliedShapeSpec &y) { Analyze(y.v); },248 [&](const auto &y) { Analyze(y); },249 },250 x.u);251 CHECK(!arraySpec_.empty());252 return arraySpec_;253}254ArraySpec ArraySpecAnalyzer::AnalyzeDeferredShapeSpecList(255 const parser::DeferredShapeSpecList &x) {256 Analyze(x);257 CHECK(!arraySpec_.empty());258 return arraySpec_;259}260ArraySpec ArraySpecAnalyzer::Analyze(const parser::CoarraySpec &x) {261 common::visit(262 common::visitors{263 [&](const parser::DeferredCoshapeSpecList &y) { MakeDeferred(y.v); },264 [&](const parser::ExplicitCoshapeSpec &y) {265 Analyze(std::get<std::list<parser::ExplicitShapeSpec>>(y.t));266 MakeImplied(267 std::get<std::optional<parser::SpecificationExpr>>(y.t));268 },269 },270 x.u);271 CHECK(!arraySpec_.empty());272 return arraySpec_;273}274 275void ArraySpecAnalyzer::Analyze(const parser::AssumedShapeSpec &x) {276 arraySpec_.push_back(ShapeSpec::MakeAssumedShape(GetBound(x.v)));277}278void ArraySpecAnalyzer::Analyze(const parser::ExplicitShapeSpec &x) {279 MakeExplicit(std::get<std::optional<parser::SpecificationExpr>>(x.t),280 std::get<parser::SpecificationExpr>(x.t));281}282void ArraySpecAnalyzer::Analyze(const parser::AssumedImpliedSpec &x) {283 MakeImplied(x.v);284}285void ArraySpecAnalyzer::Analyze(const parser::DeferredShapeSpecList &x) {286 MakeDeferred(x.v);287}288void ArraySpecAnalyzer::Analyze(const parser::AssumedRankSpec &) {289 arraySpec_.push_back(ShapeSpec::MakeAssumedRank());290}291 292void ArraySpecAnalyzer::MakeExplicit(293 const std::optional<parser::SpecificationExpr> &lb,294 const parser::SpecificationExpr &ub) {295 arraySpec_.push_back(ShapeSpec::MakeExplicit(GetBound(lb), GetBound(ub)));296}297void ArraySpecAnalyzer::MakeImplied(298 const std::optional<parser::SpecificationExpr> &lb) {299 arraySpec_.push_back(ShapeSpec::MakeImplied(GetBound(lb)));300}301void ArraySpecAnalyzer::MakeDeferred(int n) {302 for (int i = 0; i < n; ++i) {303 arraySpec_.push_back(ShapeSpec::MakeDeferred());304 }305}306 307Bound ArraySpecAnalyzer::GetBound(308 const std::optional<parser::SpecificationExpr> &x) {309 return x ? GetBound(*x) : Bound{1};310}311Bound ArraySpecAnalyzer::GetBound(const parser::SpecificationExpr &x) {312 MaybeSubscriptIntExpr expr;313 if (MaybeExpr maybeExpr{AnalyzeExpr(context_, x.v)}) {314 if (auto *intExpr{evaluate::UnwrapExpr<SomeIntExpr>(*maybeExpr)}) {315 expr = evaluate::Fold(context_.foldingContext(),316 evaluate::ConvertToType<evaluate::SubscriptInteger>(317 std::move(*intExpr)));318 }319 }320 return Bound{std::move(expr)};321}322 323// If src is SAVE (explicitly or implicitly),324// set SAVE attribute on all members of dst.325static void PropagateSaveAttr(326 const EquivalenceObject &src, EquivalenceSet &dst) {327 if (IsSaved(src.symbol)) {328 for (auto &obj : dst) {329 if (!obj.symbol.attrs().test(Attr::SAVE)) {330 obj.symbol.attrs().set(Attr::SAVE);331 // If the other equivalenced symbol itself is not SAVE,332 // then adding SAVE here implies that it has to be implicit.333 obj.symbol.implicitAttrs().set(Attr::SAVE);334 }335 }336 }337}338static void PropagateSaveAttr(const EquivalenceSet &src, EquivalenceSet &dst) {339 if (!src.empty()) {340 PropagateSaveAttr(src.front(), dst);341 }342}343 344void EquivalenceSets::AddToSet(const parser::Designator &designator) {345 if (CheckDesignator(designator)) {346 if (Symbol * symbol{currObject_.symbol}) {347 if (!currSet_.empty()) {348 // check this symbol against first of set for compatibility349 Symbol &first{currSet_.front().symbol};350 CheckCanEquivalence(designator.source, first, *symbol) &&351 CheckCanEquivalence(designator.source, *symbol, first);352 }353 auto subscripts{currObject_.subscripts};354 if (subscripts.empty()) {355 if (const ArraySpec * shape{symbol->GetShape()};356 shape && shape->IsExplicitShape()) {357 // record a whole array as its first element358 for (const ShapeSpec &spec : *shape) {359 if (auto lbound{spec.lbound().GetExplicit()}) {360 if (auto lbValue{evaluate::ToInt64(*lbound)}) {361 subscripts.push_back(*lbValue);362 continue;363 }364 }365 subscripts.clear(); // error recovery366 break;367 }368 }369 }370 auto substringStart{currObject_.substringStart};371 currSet_.emplace_back(372 *symbol, subscripts, substringStart, designator.source);373 PropagateSaveAttr(currSet_.back(), currSet_);374 }375 }376 currObject_ = {};377}378 379void EquivalenceSets::FinishSet(const parser::CharBlock &source) {380 std::set<std::size_t> existing; // indices of sets intersecting this one381 for (auto &obj : currSet_) {382 auto it{objectToSet_.find(obj)};383 if (it != objectToSet_.end()) {384 existing.insert(it->second); // symbol already in this set385 }386 }387 if (existing.empty()) {388 sets_.push_back({}); // create a new equivalence set389 MergeInto(source, currSet_, sets_.size() - 1);390 } else {391 auto it{existing.begin()};392 std::size_t dstIndex{*it};393 MergeInto(source, currSet_, dstIndex);394 while (++it != existing.end()) {395 MergeInto(source, sets_[*it], dstIndex);396 }397 }398 currSet_.clear();399}400 401// Report an error or warning if sym1 and sym2 cannot be in the same equivalence402// set.403bool EquivalenceSets::CheckCanEquivalence(404 const parser::CharBlock &source, const Symbol &sym1, const Symbol &sym2) {405 std::optional<common::LanguageFeature> feature;406 std::optional<parser::MessageFixedText> msg;407 const DeclTypeSpec *type1{sym1.GetType()};408 const DeclTypeSpec *type2{sym2.GetType()};409 bool isDefaultNum1{IsDefaultNumericSequenceType(type1)};410 bool isAnyNum1{IsAnyNumericSequenceType(type1)};411 bool isDefaultNum2{IsDefaultNumericSequenceType(type2)};412 bool isAnyNum2{IsAnyNumericSequenceType(type2)};413 bool isChar1{IsCharacterSequenceType(type1)};414 bool isChar2{IsCharacterSequenceType(type2)};415 if (sym1.attrs().test(Attr::PROTECTED) &&416 !sym2.attrs().test(Attr::PROTECTED)) { // C8114417 msg = "Equivalence set cannot contain '%s'"418 " with PROTECTED attribute and '%s' without"_err_en_US;419 } else if ((isDefaultNum1 && isDefaultNum2) || (isChar1 && isChar2)) {420 // ok & standard conforming421 } else if (!(isAnyNum1 || isChar1) &&422 !(isAnyNum2 || isChar2)) { // C8110 - C8113423 if (AreTkCompatibleTypes(type1, type2)) {424 msg =425 "nonstandard: Equivalence set contains '%s' and '%s' with same type that is neither numeric nor character sequence type"_port_en_US;426 feature = LanguageFeature::EquivalenceSameNonSequence;427 } else {428 msg = "Equivalence set cannot contain '%s' and '%s' with distinct types "429 "that are not both numeric or character sequence types"_err_en_US;430 }431 } else if (isAnyNum1) {432 if (isChar2) {433 msg =434 "nonstandard: Equivalence set contains '%s' that is numeric sequence type and '%s' that is character"_port_en_US;435 feature = LanguageFeature::EquivalenceNumericWithCharacter;436 } else if (isAnyNum2) {437 if (isDefaultNum1) {438 msg =439 "nonstandard: Equivalence set contains '%s' that is a default "440 "numeric sequence type and '%s' that is numeric with non-default kind"_port_en_US;441 } else if (!isDefaultNum2) {442 msg = "nonstandard: Equivalence set contains '%s' and '%s' that are "443 "numeric sequence types with non-default kinds"_port_en_US;444 }445 feature = LanguageFeature::EquivalenceNonDefaultNumeric;446 }447 }448 if (msg) {449 if (feature) {450 context_.Warn(451 *feature, source, std::move(*msg), sym1.name(), sym2.name());452 } else {453 context_.Say(source, std::move(*msg), sym1.name(), sym2.name());454 }455 return false;456 }457 return true;458}459 460// Move objects from src to sets_[dstIndex]461void EquivalenceSets::MergeInto(const parser::CharBlock &source,462 EquivalenceSet &src, std::size_t dstIndex) {463 EquivalenceSet &dst{sets_[dstIndex]};464 PropagateSaveAttr(dst, src);465 for (const auto &obj : src) {466 dst.push_back(obj);467 objectToSet_[obj] = dstIndex;468 }469 PropagateSaveAttr(src, dst);470 src.clear();471}472 473// If set has an object with this symbol, return it.474const EquivalenceObject *EquivalenceSets::Find(475 const EquivalenceSet &set, const Symbol &symbol) {476 for (const auto &obj : set) {477 if (obj.symbol == symbol) {478 return &obj;479 }480 }481 return nullptr;482}483 484bool EquivalenceSets::CheckDesignator(const parser::Designator &designator) {485 return common::visit(486 common::visitors{487 [&](const parser::DataRef &x) {488 return CheckDataRef(designator.source, x);489 },490 [&](const parser::Substring &x) {491 const auto &dataRef{std::get<parser::DataRef>(x.t)};492 const auto &range{std::get<parser::SubstringRange>(x.t)};493 bool ok{CheckDataRef(designator.source, dataRef)};494 if (const auto &lb{std::get<0>(range.t)}) {495 ok &= CheckSubstringBound(496 parser::UnwrapRef<parser::Expr>(lb), true);497 } else {498 currObject_.substringStart = 1;499 }500 if (const auto &ub{std::get<1>(range.t)}) {501 ok &= CheckSubstringBound(502 parser::UnwrapRef<parser::Expr>(ub), false);503 }504 return ok;505 },506 },507 designator.u);508}509 510bool EquivalenceSets::CheckDataRef(511 const parser::CharBlock &source, const parser::DataRef &x) {512 return common::visit(513 common::visitors{514 [&](const parser::Name &name) { return CheckObject(name); },515 [&](const common::Indirection<parser::StructureComponent> &) {516 context_.Say(source, // C8107517 "Derived type component '%s' is not allowed in an equivalence set"_err_en_US,518 source);519 return false;520 },521 [&](const common::Indirection<parser::ArrayElement> &elem) {522 bool ok{CheckDataRef(source, elem.value().base)};523 for (const auto &subscript : elem.value().subscripts) {524 ok &= common::visit(525 common::visitors{526 [&](const parser::SubscriptTriplet &) {527 context_.Say(source, // C924, R872528 "Array section '%s' is not allowed in an equivalence set"_err_en_US,529 source);530 return false;531 },532 [&](const parser::IntExpr &y) {533 return CheckArrayBound(534 parser::UnwrapRef<parser::Expr>(y));535 },536 },537 subscript.u);538 }539 return ok;540 },541 [&](const common::Indirection<parser::CoindexedNamedObject> &) {542 context_.Say(source, // C924 (R872)543 "Coindexed object '%s' is not allowed in an equivalence set"_err_en_US,544 source);545 return false;546 },547 },548 x.u);549}550 551bool EquivalenceSets::CheckObject(const parser::Name &name) {552 currObject_.symbol = name.symbol;553 return currObject_.symbol != nullptr;554}555 556bool EquivalenceSets::CheckArrayBound(const parser::Expr &bound) {557 MaybeExpr expr{558 evaluate::Fold(context_.foldingContext(), AnalyzeExpr(context_, bound))};559 if (!expr) {560 return false;561 }562 if (expr->Rank() > 0) {563 context_.Say(bound.source, // C924, R872564 "Array with vector subscript '%s' is not allowed in an equivalence set"_err_en_US,565 bound.source);566 return false;567 }568 auto subscript{evaluate::ToInt64(*expr)};569 if (!subscript) {570 context_.Say(bound.source, // C8109571 "Array with nonconstant subscript '%s' is not allowed in an equivalence set"_err_en_US,572 bound.source);573 return false;574 }575 currObject_.subscripts.push_back(*subscript);576 return true;577}578 579bool EquivalenceSets::CheckSubstringBound(580 const parser::Expr &bound, bool isStart) {581 MaybeExpr expr{582 evaluate::Fold(context_.foldingContext(), AnalyzeExpr(context_, bound))};583 if (!expr) {584 return false;585 }586 auto subscript{evaluate::ToInt64(*expr)};587 if (!subscript) {588 context_.Say(bound.source, // C8109589 "Substring with nonconstant bound '%s' is not allowed in an equivalence set"_err_en_US,590 bound.source);591 return false;592 }593 if (!isStart) {594 auto start{currObject_.substringStart};595 if (*subscript < (start ? *start : 1)) {596 context_.Say(bound.source, // C8116597 "Substring with zero length is not allowed in an equivalence set"_err_en_US);598 return false;599 }600 } else if (*subscript != 1) {601 currObject_.substringStart = *subscript;602 }603 return true;604}605 606bool EquivalenceSets::IsCharacterSequenceType(const DeclTypeSpec *type) {607 return IsSequenceType(type, [&](const IntrinsicTypeSpec &type) {608 auto kind{evaluate::ToInt64(type.kind())};609 return type.category() == TypeCategory::Character && kind &&610 kind.value() == context_.GetDefaultKind(TypeCategory::Character);611 });612}613 614// Numeric or logical type of default kind or DOUBLE PRECISION or DOUBLE COMPLEX615bool EquivalenceSets::IsDefaultKindNumericType(const IntrinsicTypeSpec &type) {616 if (auto kind{evaluate::ToInt64(type.kind())}) {617 switch (type.category()) {618 case TypeCategory::Integer:619 case TypeCategory::Logical:620 return *kind == context_.GetDefaultKind(TypeCategory::Integer);621 case TypeCategory::Real:622 case TypeCategory::Complex:623 return *kind == context_.GetDefaultKind(TypeCategory::Real) ||624 *kind == context_.doublePrecisionKind();625 default:626 return false;627 }628 }629 return false;630}631 632bool EquivalenceSets::IsDefaultNumericSequenceType(const DeclTypeSpec *type) {633 return IsSequenceType(type, [&](const IntrinsicTypeSpec &type) {634 return IsDefaultKindNumericType(type);635 });636}637 638bool EquivalenceSets::IsAnyNumericSequenceType(const DeclTypeSpec *type) {639 return IsSequenceType(type, [&](const IntrinsicTypeSpec &type) {640 return type.category() == TypeCategory::Logical ||641 common::IsNumericTypeCategory(type.category());642 });643}644 645// Is type an intrinsic type that satisfies predicate or a sequence type646// whose components do.647bool EquivalenceSets::IsSequenceType(const DeclTypeSpec *type,648 std::function<bool(const IntrinsicTypeSpec &)> predicate) {649 if (!type) {650 return false;651 } else if (const IntrinsicTypeSpec * intrinsic{type->AsIntrinsic()}) {652 return predicate(*intrinsic);653 } else if (const DerivedTypeSpec * derived{type->AsDerived()}) {654 for (const auto &pair : *derived->typeSymbol().scope()) {655 const Symbol &component{*pair.second};656 if (IsAllocatableOrPointer(component) ||657 !IsSequenceType(component.GetType(), predicate)) {658 return false;659 }660 }661 return true;662 } else {663 return false;664 }665}666 667// MapSubprogramToNewSymbols() relies on the following recursive symbol/scope668// copying infrastructure to duplicate an interface's symbols and map all669// of the symbol references in their contained expressions and interfaces670// to the new symbols.671 672struct SymbolAndTypeMappings {673 std::map<const Symbol *, const Symbol *> symbolMap;674 std::map<const DeclTypeSpec *, const DeclTypeSpec *> typeMap;675};676 677class SymbolMapper : public evaluate::AnyTraverse<SymbolMapper, bool> {678public:679 using Base = evaluate::AnyTraverse<SymbolMapper, bool>;680 SymbolMapper(Scope &scope, SymbolAndTypeMappings &map)681 : Base{*this}, scope_{scope}, map_{map} {}682 using Base::operator();683 bool operator()(const SymbolRef &ref) {684 if (const Symbol *mapped{MapSymbol(*ref)}) {685 const_cast<SymbolRef &>(ref) = *mapped;686 } else if (ref->has<UseDetails>()) {687 CopySymbol(&*ref);688 }689 return false;690 }691 bool operator()(const Symbol &x) {692 if (MapSymbol(x)) {693 DIE("SymbolMapper hit symbol outside SymbolRef");694 }695 return false;696 }697 void MapSymbolExprs(Symbol &);698 Symbol *CopySymbol(const Symbol *);699 700private:701 void MapParamValue(ParamValue ¶m) { (*this)(param.GetExplicit()); }702 void MapBound(Bound &bound) { (*this)(bound.GetExplicit()); }703 void MapShapeSpec(ShapeSpec &spec) {704 MapBound(spec.lbound());705 MapBound(spec.ubound());706 }707 const Symbol *MapSymbol(const Symbol &) const;708 const Symbol *MapSymbol(const Symbol *) const;709 const DeclTypeSpec *MapType(const DeclTypeSpec &);710 const DeclTypeSpec *MapType(const DeclTypeSpec *);711 const Symbol *MapInterface(const Symbol *);712 713 Scope &scope_;714 SymbolAndTypeMappings &map_;715};716 717Symbol *SymbolMapper::CopySymbol(const Symbol *symbol) {718 if (symbol) {719 if (auto *subp{symbol->detailsIf<SubprogramDetails>()}) {720 if (subp->isInterface()) {721 if (auto pair{scope_.try_emplace(symbol->name(), symbol->attrs())};722 pair.second) {723 Symbol ©{*pair.first->second};724 map_.symbolMap[symbol] = ©725 copy.set(symbol->test(Symbol::Flag::Subroutine)726 ? Symbol::Flag::Subroutine727 : Symbol::Flag::Function);728 Scope &newScope{scope_.MakeScope(Scope::Kind::Subprogram, ©)};729 copy.set_scope(&newScope);730 copy.set_details(SubprogramDetails{});731 auto &newSubp{copy.get<SubprogramDetails>()};732 newSubp.set_isInterface(true);733 newSubp.set_isDummy(subp->isDummy());734 newSubp.set_defaultIgnoreTKR(subp->defaultIgnoreTKR());735 MapSubprogramToNewSymbols(*symbol, copy, newScope, &map_);736 return ©737 }738 }739 } else if (Symbol * copy{scope_.CopySymbol(*symbol)}) {740 map_.symbolMap[symbol] = copy;741 return copy;742 }743 }744 return nullptr;745}746 747void SymbolMapper::MapSymbolExprs(Symbol &symbol) {748 common::visit(749 common::visitors{[&](ObjectEntityDetails &object) {750 if (const DeclTypeSpec * type{object.type()}) {751 if (const DeclTypeSpec * newType{MapType(*type)}) {752 object.ReplaceType(*newType);753 }754 }755 for (ShapeSpec &spec : object.shape()) {756 MapShapeSpec(spec);757 }758 for (ShapeSpec &spec : object.coshape()) {759 MapShapeSpec(spec);760 }761 },762 [&](ProcEntityDetails &proc) {763 if (const Symbol *764 mappedSymbol{MapInterface(proc.rawProcInterface())}) {765 proc.set_procInterfaces(766 *mappedSymbol, BypassGeneric(mappedSymbol->GetUltimate()));767 } else if (const DeclTypeSpec * mappedType{MapType(proc.type())}) {768 if (proc.type()) {769 CHECK(*proc.type() == *mappedType);770 } else {771 proc.set_type(*mappedType);772 }773 }774 if (proc.init()) {775 if (const Symbol * mapped{MapSymbol(*proc.init())}) {776 proc.set_init(*mapped);777 }778 }779 },780 [&](const HostAssocDetails &hostAssoc) {781 if (const Symbol * mapped{MapSymbol(hostAssoc.symbol())}) {782 symbol.set_details(HostAssocDetails{*mapped});783 }784 },785 [](const auto &) {}},786 symbol.details());787}788 789const Symbol *SymbolMapper::MapSymbol(const Symbol &symbol) const {790 if (auto iter{map_.symbolMap.find(&symbol)}; iter != map_.symbolMap.end()) {791 return iter->second;792 }793 return nullptr;794}795 796const Symbol *SymbolMapper::MapSymbol(const Symbol *symbol) const {797 return symbol ? MapSymbol(*symbol) : nullptr;798}799 800const DeclTypeSpec *SymbolMapper::MapType(const DeclTypeSpec &type) {801 if (auto iter{map_.typeMap.find(&type)}; iter != map_.typeMap.end()) {802 return iter->second;803 }804 const DeclTypeSpec *newType{nullptr};805 if (type.category() == DeclTypeSpec::Category::Character) {806 const CharacterTypeSpec &charType{type.characterTypeSpec()};807 if (charType.length().GetExplicit()) {808 ParamValue newLen{charType.length()};809 (*this)(newLen.GetExplicit());810 newType = &scope_.MakeCharacterType(811 std::move(newLen), KindExpr{charType.kind()});812 }813 } else if (const DerivedTypeSpec *derived{type.AsDerived()}) {814 if (!derived->parameters().empty()) {815 DerivedTypeSpec newDerived{derived->name(), derived->typeSymbol()};816 newDerived.CookParameters(scope_.context().foldingContext());817 for (const auto &[paramName, paramValue] : derived->parameters()) {818 ParamValue newParamValue{paramValue};819 MapParamValue(newParamValue);820 newDerived.AddParamValue(paramName, std::move(newParamValue));821 }822 // Scope::InstantiateDerivedTypes() instantiates it later.823 newType = &scope_.MakeDerivedType(type.category(), std::move(newDerived));824 }825 }826 if (newType) {827 map_.typeMap[&type] = newType;828 }829 return newType;830}831 832const DeclTypeSpec *SymbolMapper::MapType(const DeclTypeSpec *type) {833 return type ? MapType(*type) : nullptr;834}835 836const Symbol *SymbolMapper::MapInterface(const Symbol *interface) {837 if (const Symbol *mapped{MapSymbol(interface)}) {838 return mapped;839 }840 if (interface) {841 if (&interface->owner() != &scope_) {842 return interface;843 } else if (const auto *subp{interface->detailsIf<SubprogramDetails>()};844 subp && subp->isInterface()) {845 return CopySymbol(interface);846 }847 }848 return nullptr;849}850 851void MapSubprogramToNewSymbols(const Symbol &oldSymbol, Symbol &newSymbol,852 Scope &newScope, SymbolAndTypeMappings *mappings) {853 SymbolAndTypeMappings newMappings;854 if (!mappings) {855 mappings = &newMappings;856 }857 mappings->symbolMap[&oldSymbol] = &newSymbol;858 const auto &oldDetails{oldSymbol.get<SubprogramDetails>()};859 auto &newDetails{newSymbol.get<SubprogramDetails>()};860 SymbolMapper mapper{newScope, *mappings};861 for (const Symbol *dummyArg : oldDetails.dummyArgs()) {862 if (!dummyArg) {863 newDetails.add_alternateReturn();864 } else if (Symbol * copy{mapper.CopySymbol(dummyArg)}) {865 copy->set(Symbol::Flag::Implicit, false);866 newDetails.add_dummyArg(*copy);867 mappings->symbolMap[dummyArg] = copy;868 }869 }870 if (oldDetails.isFunction()) {871 newScope.erase(newSymbol.name());872 const Symbol &result{oldDetails.result()};873 if (Symbol * copy{mapper.CopySymbol(&result)}) {874 newDetails.set_result(*copy);875 mappings->symbolMap[&result] = copy;876 }877 }878 for (auto &[_, ref] : newScope) {879 mapper.MapSymbolExprs(*ref);880 }881 newScope.InstantiateDerivedTypes();882}883 884} // namespace Fortran::semantics885