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