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 GenericKind MapIntrinsicOperator(IntrinsicOperator);
  35
  36 Symbol *Resolve(const parser::Name &name, Symbol *symbol) {
  37   if (symbol && !name.symbol) {
  38     name.symbol = symbol;
  39   }
  40   return symbol;
  41 }
  42 Symbol &Resolve(const parser::Name &name, Symbol &symbol) {
  43   return *Resolve(name, &symbol);
  44 }
  45
  46 parser::MessageFixedText WithSeverity(
  47     const parser::MessageFixedText &msg, parser::Severity severity) {
  48   return parser::MessageFixedText{
  49       msg.text().begin(), msg.text().size(), severity};
  50 }
  51
  52 bool 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
  70 bool 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
  78 void 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
  89 void GenericSpecInfo::Analyze(const parser::DefinedOpName &name) {
  90   kind_ = GenericKind::OtherKind::DefinedOp;
  91   parseName_ = &name.v;
  92   symbolName_ = name.v.source;
  93 }
  94
  95 void 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
 136 llvm::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 -> GenericKind
 147 static GenericKind MapIntrinsicOperator(IntrinsicOperator op) {
 148   switch (op) {
 149     SWITCH_COVERS_ALL_CASES
 150   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
 187 class ArraySpecAnalyzer {
 188 public:
 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
 195 private:
 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
 217 ArraySpec AnalyzeArraySpec(
 218     SemanticsContext &context, const parser::ArraySpec &arraySpec) {
 219   return ArraySpecAnalyzer{context}.Analyze(arraySpec);
 220 }
 221 ArraySpec AnalyzeArraySpec(
 222     SemanticsContext &context, const parser::ComponentArraySpec &arraySpec) {
 223   return ArraySpecAnalyzer{context}.Analyze(arraySpec);
 224 }
 225 ArraySpec AnalyzeDeferredShapeSpecList(SemanticsContext &context,
 226     const parser::DeferredShapeSpecList &deferredShapeSpecs) {
 227   return ArraySpecAnalyzer{context}.AnalyzeDeferredShapeSpecList(
 228       deferredShapeSpecs);
 229 }
 230 ArraySpec AnalyzeCoarraySpec(
 231     SemanticsContext &context, const parser::CoarraySpec &coarraySpec) {
 232   return ArraySpecAnalyzer{context}.Analyze(coarraySpec);
 233 }
 234
 235 ArraySpec 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 }
 240 ArraySpec 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 }
 254 ArraySpec ArraySpecAnalyzer::AnalyzeDeferredShapeSpecList(
 255     const parser::DeferredShapeSpecList &x) {
 256   Analyze(x);
 257   CHECK(!arraySpec_.empty());
 258   return arraySpec_;
 259 }
 260 ArraySpec 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
 275 void ArraySpecAnalyzer::Analyze(const parser::AssumedShapeSpec &x) {
 276   arraySpec_.push_back(ShapeSpec::MakeAssumedShape(GetBound(x.v)));
 277 }
 278 void ArraySpecAnalyzer::Analyze(const parser::ExplicitShapeSpec &x) {
 279   MakeExplicit(std::get<std::optional<parser::SpecificationExpr>>(x.t),
 280       std::get<parser::SpecificationExpr>(x.t));
 281 }
 282 void ArraySpecAnalyzer::Analyze(const parser::AssumedImpliedSpec &x) {
 283   MakeImplied(x.v);
 284 }
 285 void ArraySpecAnalyzer::Analyze(const parser::DeferredShapeSpecList &x) {
 286   MakeDeferred(x.v);
 287 }
 288 void ArraySpecAnalyzer::Analyze(const parser::AssumedRankSpec &) {
 289   arraySpec_.push_back(ShapeSpec::MakeAssumedRank());
 290 }
 291
 292 void 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 }
 297 void ArraySpecAnalyzer::MakeImplied(
 298     const std::optional<parser::SpecificationExpr> &lb) {
 299   arraySpec_.push_back(ShapeSpec::MakeImplied(GetBound(lb)));
 300 }
 301 void ArraySpecAnalyzer::MakeDeferred(int n) {
 302   for (int i = 0; i < n; ++i) {
 303     arraySpec_.push_back(ShapeSpec::MakeDeferred());
 304   }
 305 }
 306
 307 Bound ArraySpecAnalyzer::GetBound(
 308     const std::optional<parser::SpecificationExpr> &x) {
 309   return x ? GetBound(*x) : Bound{1};
 310 }
 311 Bound 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.
 325 static 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 }
 338 static void PropagateSaveAttr(const EquivalenceSet &src, EquivalenceSet &dst) {
 339   if (!src.empty()) {
 340     PropagateSaveAttr(src.front(), dst);
 341   }
 342 }
 343
 344 void 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 compatibility
 349         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 element
 358           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 recovery
 366             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
 379 void EquivalenceSets::FinishSet(const parser::CharBlock &source) {
 380   std::set<std::size_t> existing; // indices of sets intersecting this one
 381   for (auto &obj : currSet_) {
 382     auto it{objectToSet_.find(obj)};
 383     if (it != objectToSet_.end()) {
 384       existing.insert(it->second); // symbol already in this set
 385     }
 386   }
 387   if (existing.empty()) {
 388     sets_.push_back({}); // create a new equivalence set
 389     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 equivalence
 402 // set.
 403 bool 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)) { // C8114
 417     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 conforming
 421   } else if (!(isAnyNum1 || isChar1) &&
 422       !(isAnyNum2 || isChar2)) { // C8110 - C8113
 423     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]
 461 void 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.
 474 const 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
 484 bool 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(lb->thing.thing.value(), true);
 496             } else {
 497               currObject_.substringStart = 1;
 498             }
 499             if (const auto &ub{std::get<1>(range.t)}) {
 500               ok &= CheckSubstringBound(ub->thing.thing.value(), false);
 501             }
 502             return ok;
 503           },
 504       },
 505       designator.u);
 506 }
 507
 508 bool EquivalenceSets::CheckDataRef(
 509     const parser::CharBlock &source, const parser::DataRef &x) {
 510   return common::visit(
 511       common::visitors{
 512           [&](const parser::Name &name) { return CheckObject(name); },
 513           [&](const common::Indirection<parser::StructureComponent> &) {
 514             context_.Say(source, // C8107
 515                 "Derived type component '%s' is not allowed in an equivalence set"_err_en_US,
 516                 source);
 517             return false;
 518           },
 519           [&](const common::Indirection<parser::ArrayElement> &elem) {
 520             bool ok{CheckDataRef(source, elem.value().base)};
 521             for (const auto &subscript : elem.value().subscripts) {
 522               ok &= common::visit(
 523                   common::visitors{
 524                       [&](const parser::SubscriptTriplet &) {
 525                         context_.Say(source, // C924, R872
 526                             "Array section '%s' is not allowed in an equivalence set"_err_en_US,
 527                             source);
 528                         return false;
 529                       },
 530                       [&](const parser::IntExpr &y) {
 531                         return CheckArrayBound(y.thing.value());
 532                       },
 533                   },
 534                   subscript.u);
 535             }
 536             return ok;
 537           },
 538           [&](const common::Indirection<parser::CoindexedNamedObject> &) {
 539             context_.Say(source, // C924 (R872)
 540                 "Coindexed object '%s' is not allowed in an equivalence set"_err_en_US,
 541                 source);
 542             return false;
 543           },
 544       },
 545       x.u);
 546 }
 547
 548 bool EquivalenceSets::CheckObject(const parser::Name &name) {
 549   currObject_.symbol = name.symbol;
 550   return currObject_.symbol != nullptr;
 551 }
 552
 553 bool EquivalenceSets::CheckArrayBound(const parser::Expr &bound) {
 554   MaybeExpr expr{
 555       evaluate::Fold(context_.foldingContext(), AnalyzeExpr(context_, bound))};
 556   if (!expr) {
 557     return false;
 558   }
 559   if (expr->Rank() > 0) {
 560     context_.Say(bound.source, // C924, R872
 561         "Array with vector subscript '%s' is not allowed in an equivalence set"_err_en_US,
 562         bound.source);
 563     return false;
 564   }
 565   auto subscript{evaluate::ToInt64(*expr)};
 566   if (!subscript) {
 567     context_.Say(bound.source, // C8109
 568         "Array with nonconstant subscript '%s' is not allowed in an equivalence set"_err_en_US,
 569         bound.source);
 570     return false;
 571   }
 572   currObject_.subscripts.push_back(*subscript);
 573   return true;
 574 }
 575
 576 bool EquivalenceSets::CheckSubstringBound(
 577     const parser::Expr &bound, bool isStart) {
 578   MaybeExpr expr{
 579       evaluate::Fold(context_.foldingContext(), AnalyzeExpr(context_, bound))};
 580   if (!expr) {
 581     return false;
 582   }
 583   auto subscript{evaluate::ToInt64(*expr)};
 584   if (!subscript) {
 585     context_.Say(bound.source, // C8109
 586         "Substring with nonconstant bound '%s' is not allowed in an equivalence set"_err_en_US,
 587         bound.source);
 588     return false;
 589   }
 590   if (!isStart) {
 591     auto start{currObject_.substringStart};
 592     if (*subscript < (start ? *start : 1)) {
 593       context_.Say(bound.source, // C8116
 594           "Substring with zero length is not allowed in an equivalence set"_err_en_US);
 595       return false;
 596     }
 597   } else if (*subscript != 1) {
 598     currObject_.substringStart = *subscript;
 599   }
 600   return true;
 601 }
 602
 603 bool EquivalenceSets::IsCharacterSequenceType(const DeclTypeSpec *type) {
 604   return IsSequenceType(type, [&](const IntrinsicTypeSpec &type) {
 605     auto kind{evaluate::ToInt64(type.kind())};
 606     return type.category() == TypeCategory::Character && kind &&
 607         kind.value() == context_.GetDefaultKind(TypeCategory::Character);
 608   });
 609 }
 610
 611 // Numeric or logical type of default kind or DOUBLE PRECISION or DOUBLE COMPLEX
 612 bool EquivalenceSets::IsDefaultKindNumericType(const IntrinsicTypeSpec &type) {
 613   if (auto kind{evaluate::ToInt64(type.kind())}) {
 614     switch (type.category()) {
 615     case TypeCategory::Integer:
 616     case TypeCategory::Logical:
 617       return *kind == context_.GetDefaultKind(TypeCategory::Integer);
 618     case TypeCategory::Real:
 619     case TypeCategory::Complex:
 620       return *kind == context_.GetDefaultKind(TypeCategory::Real) ||
 621           *kind == context_.doublePrecisionKind();
 622     default:
 623       return false;
 624     }
 625   }
 626   return false;
 627 }
 628
 629 bool EquivalenceSets::IsDefaultNumericSequenceType(const DeclTypeSpec *type) {
 630   return IsSequenceType(type, [&](const IntrinsicTypeSpec &type) {
 631     return IsDefaultKindNumericType(type);
 632   });
 633 }
 634
 635 bool EquivalenceSets::IsAnyNumericSequenceType(const DeclTypeSpec *type) {
 636   return IsSequenceType(type, [&](const IntrinsicTypeSpec &type) {
 637     return type.category() == TypeCategory::Logical ||
 638         common::IsNumericTypeCategory(type.category());
 639   });
 640 }
 641
 642 // Is type an intrinsic type that satisfies predicate or a sequence type
 643 // whose components do.
 644 bool EquivalenceSets::IsSequenceType(const DeclTypeSpec *type,
 645     std::function<bool(const IntrinsicTypeSpec &)> predicate) {
 646   if (!type) {
 647     return false;
 648   } else if (const IntrinsicTypeSpec * intrinsic{type->AsIntrinsic()}) {
 649     return predicate(*intrinsic);
 650   } else if (const DerivedTypeSpec * derived{type->AsDerived()}) {
 651     for (const auto &pair : *derived->typeSymbol().scope()) {
 652       const Symbol &component{*pair.second};
 653       if (IsAllocatableOrPointer(component) ||
 654           !IsSequenceType(component.GetType(), predicate)) {
 655         return false;
 656       }
 657     }
 658     return true;
 659   } else {
 660     return false;
 661   }
 662 }
 663
 664 // MapSubprogramToNewSymbols() relies on the following recursive symbol/scope
 665 // copying infrastructure to duplicate an interface's symbols and map all
 666 // of the symbol references in their contained expressions and interfaces
 667 // to the new symbols.
 668
 669 struct SymbolAndTypeMappings {
 670   std::map<const Symbol *, const Symbol *> symbolMap;
 671   std::map<const DeclTypeSpec *, const DeclTypeSpec *> typeMap;
 672 };
 673
 674 class SymbolMapper : public evaluate::AnyTraverse<SymbolMapper, bool> {
 675 public:
 676   using Base = evaluate::AnyTraverse<SymbolMapper, bool>;
 677   SymbolMapper(Scope &scope, SymbolAndTypeMappings &map)
 678       : Base{*this}, scope_{scope}, map_{map} {}
 679   using Base::operator();
 680   bool operator()(const SymbolRef &ref) {
 681     if (const Symbol *mapped{MapSymbol(*ref)}) {
 682       const_cast<SymbolRef &>(ref) = *mapped;
 683     } else if (ref->has<UseDetails>()) {
 684       CopySymbol(&*ref);
 685     }
 686     return false;
 687   }
 688   bool operator()(const Symbol &x) {
 689     if (MapSymbol(x)) {
 690       DIE("SymbolMapper hit symbol outside SymbolRef");
 691     }
 692     return false;
 693   }
 694   void MapSymbolExprs(Symbol &);
 695   Symbol *CopySymbol(const Symbol *);
 696
 697 private:
 698   void MapParamValue(ParamValue &param) { (*this)(param.GetExplicit()); }
 699   void MapBound(Bound &bound) { (*this)(bound.GetExplicit()); }
 700   void MapShapeSpec(ShapeSpec &spec) {
 701     MapBound(spec.lbound());
 702     MapBound(spec.ubound());
 703   }
 704   const Symbol *MapSymbol(const Symbol &) const;
 705   const Symbol *MapSymbol(const Symbol *) const;
 706   const DeclTypeSpec *MapType(const DeclTypeSpec &);
 707   const DeclTypeSpec *MapType(const DeclTypeSpec *);
 708   const Symbol *MapInterface(const Symbol *);
 709
 710   Scope &scope_;
 711   SymbolAndTypeMappings &map_;
 712 };
 713
 714 Symbol *SymbolMapper::CopySymbol(const Symbol *symbol) {
 715   if (symbol) {
 716     if (auto *subp{symbol->detailsIf<SubprogramDetails>()}) {
 717       if (subp->isInterface()) {
 718         if (auto pair{scope_.try_emplace(symbol->name(), symbol->attrs())};
 719             pair.second) {
 720           Symbol &copy{*pair.first->second};
 721           map_.symbolMap[symbol] = &copy;
 722           copy.set(symbol->test(Symbol::Flag::Subroutine)
 723                   ? Symbol::Flag::Subroutine
 724                   : Symbol::Flag::Function);
 725           Scope &newScope{scope_.MakeScope(Scope::Kind::Subprogram, &copy)};
 726           copy.set_scope(&newScope);
 727           copy.set_details(SubprogramDetails{});
 728           auto &newSubp{copy.get<SubprogramDetails>()};
 729           newSubp.set_isInterface(true);
 730           newSubp.set_isDummy(subp->isDummy());
 731           newSubp.set_defaultIgnoreTKR(subp->defaultIgnoreTKR());
 732           MapSubprogramToNewSymbols(*symbol, copy, newScope, &map_);
 733           return &copy;
 734         }
 735       }
 736     } else if (Symbol * copy{scope_.CopySymbol(*symbol)}) {
 737       map_.symbolMap[symbol] = copy;
 738       return copy;
 739     }
 740   }
 741   return nullptr;
 742 }
 743
 744 void SymbolMapper::MapSymbolExprs(Symbol &symbol) {
 745   common::visit(
 746       common::visitors{[&](ObjectEntityDetails &object) {
 747                          if (const DeclTypeSpec * type{object.type()}) {
 748                            if (const DeclTypeSpec * newType{MapType(*type)}) {
 749                              object.ReplaceType(*newType);
 750                            }
 751                          }
 752                          for (ShapeSpec &spec : object.shape()) {
 753                            MapShapeSpec(spec);
 754                          }
 755                          for (ShapeSpec &spec : object.coshape()) {
 756                            MapShapeSpec(spec);
 757                          }
 758                        },
 759           [&](ProcEntityDetails &proc) {
 760             if (const Symbol *
 761                 mappedSymbol{MapInterface(proc.rawProcInterface())}) {
 762               proc.set_procInterfaces(
 763                   *mappedSymbol, BypassGeneric(mappedSymbol->GetUltimate()));
 764             } else if (const DeclTypeSpec * mappedType{MapType(proc.type())}) {
 765               proc.set_type(*mappedType);
 766             }
 767             if (proc.init()) {
 768               if (const Symbol * mapped{MapSymbol(*proc.init())}) {
 769                 proc.set_init(*mapped);
 770               }
 771             }
 772           },
 773           [&](const HostAssocDetails &hostAssoc) {
 774             if (const Symbol * mapped{MapSymbol(hostAssoc.symbol())}) {
 775               symbol.set_details(HostAssocDetails{*mapped});
 776             }
 777           },
 778           [](const auto &) {}},
 779       symbol.details());
 780 }
 781
 782 const Symbol *SymbolMapper::MapSymbol(const Symbol &symbol) const {
 783   if (auto iter{map_.symbolMap.find(&symbol)}; iter != map_.symbolMap.end()) {
 784     return iter->second;
 785   }
 786   return nullptr;
 787 }
 788
 789 const Symbol *SymbolMapper::MapSymbol(const Symbol *symbol) const {
 790   return symbol ? MapSymbol(*symbol) : nullptr;
 791 }
 792
 793 const DeclTypeSpec *SymbolMapper::MapType(const DeclTypeSpec &type) {
 794   if (auto iter{map_.typeMap.find(&type)}; iter != map_.typeMap.end()) {
 795     return iter->second;
 796   }
 797   const DeclTypeSpec *newType{nullptr};
 798   if (type.category() == DeclTypeSpec::Category::Character) {
 799     const CharacterTypeSpec &charType{type.characterTypeSpec()};
 800     if (charType.length().GetExplicit()) {
 801       ParamValue newLen{charType.length()};
 802       (*this)(newLen.GetExplicit());
 803       newType = &scope_.MakeCharacterType(
 804           std::move(newLen), KindExpr{charType.kind()});
 805     }
 806   } else if (const DerivedTypeSpec *derived{type.AsDerived()}) {
 807     if (!derived->parameters().empty()) {
 808       DerivedTypeSpec newDerived{derived->name(), derived->typeSymbol()};
 809       newDerived.CookParameters(scope_.context().foldingContext());
 810       for (const auto &[paramName, paramValue] : derived->parameters()) {
 811         ParamValue newParamValue{paramValue};
 812         MapParamValue(newParamValue);
 813         newDerived.AddParamValue(paramName, std::move(newParamValue));
 814       }
 815       // Scope::InstantiateDerivedTypes() instantiates it later.
 816       newType = &scope_.MakeDerivedType(type.category(), std::move(newDerived));
 817     }
 818   }
 819   if (newType) {
 820     map_.typeMap[&type] = newType;
 821   }
 822   return newType;
 823 }
 824
 825 const DeclTypeSpec *SymbolMapper::MapType(const DeclTypeSpec *type) {
 826   return type ? MapType(*type) : nullptr;
 827 }
 828
 829 const Symbol *SymbolMapper::MapInterface(const Symbol *interface) {
 830   if (const Symbol *mapped{MapSymbol(interface)}) {
 831     return mapped;
 832   }
 833   if (interface) {
 834     if (&interface->owner() != &scope_) {
 835       return interface;
 836     } else if (const auto *subp{interface->detailsIf<SubprogramDetails>()};
 837                subp && subp->isInterface()) {
 838       return CopySymbol(interface);
 839     }
 840   }
 841   return nullptr;
 842 }
 843
 844 void MapSubprogramToNewSymbols(const Symbol &oldSymbol, Symbol &newSymbol,
 845     Scope &newScope, SymbolAndTypeMappings *mappings) {
 846   SymbolAndTypeMappings newMappings;
 847   if (!mappings) {
 848     mappings = &newMappings;
 849   }
 850   mappings->symbolMap[&oldSymbol] = &newSymbol;
 851   const auto &oldDetails{oldSymbol.get<SubprogramDetails>()};
 852   auto &newDetails{newSymbol.get<SubprogramDetails>()};
 853   SymbolMapper mapper{newScope, *mappings};
 854   for (const Symbol *dummyArg : oldDetails.dummyArgs()) {
 855     if (!dummyArg) {
 856       newDetails.add_alternateReturn();
 857     } else if (Symbol * copy{mapper.CopySymbol(dummyArg)}) {
 858       copy->set(Symbol::Flag::Implicit, false);
 859       newDetails.add_dummyArg(*copy);
 860       mappings->symbolMap[dummyArg] = copy;
 861     }
 862   }
 863   if (oldDetails.isFunction()) {
 864     newScope.erase(newSymbol.name());
 865     const Symbol &result{oldDetails.result()};
 866     if (Symbol * copy{mapper.CopySymbol(&result)}) {
 867       newDetails.set_result(*copy);
 868       mappings->symbolMap[&result] = copy;
 869     }
 870   }
 871   for (auto &[_, ref] : newScope) {
 872     mapper.MapSymbolExprs(*ref);
 873   }
 874   newScope.InstantiateDerivedTypes();
 875 }
 876
 877 } // namespace Fortran::semantics