flang/lib/Semantics/mod-file.cpp

   1 //===-- lib/Semantics/mod-file.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 "mod-file.h"
  10 #include "resolve-names.h"
  11 #include "flang/Common/restorer.h"
  12 #include "flang/Evaluate/tools.h"
  13 #include "flang/Parser/message.h"
  14 #include "flang/Parser/parsing.h"
  15 #include "flang/Parser/unparse.h"
  16 #include "flang/Semantics/scope.h"
  17 #include "flang/Semantics/semantics.h"
  18 #include "flang/Semantics/symbol.h"
  19 #include "flang/Semantics/tools.h"
  20 #include "llvm/Support/FileSystem.h"
  21 #include "llvm/Support/MemoryBuffer.h"
  22 #include "llvm/Support/raw_ostream.h"
  23 #include <algorithm>
  24 #include <fstream>
  25 #include <set>
  26 #include <string_view>
  27 #include <vector>
  28
  29 namespace Fortran::semantics {
  30
  31 using namespace parser::literals;
  32
  33 // The first line of a file that identifies it as a .mod file.
  34 // The first three bytes are a Unicode byte order mark that ensures
  35 // that the module file is decoded as UTF-8 even if source files
  36 // are using another encoding.
  37 struct ModHeader {
  38   static constexpr const char bom[3 + 1]{"\xef\xbb\xbf"};
  39   static constexpr int magicLen{13};
  40   static constexpr int sumLen{16};
  41   static constexpr const char magic[magicLen + 1]{"!mod$ v1 sum:"};
  42   static constexpr char terminator{'\n'};
  43   static constexpr int len{magicLen + 1 + sumLen};
  44 };
  45
  46 static std::optional<SourceName> GetSubmoduleParent(const parser::Program &);
  47 static void CollectSymbols(const Scope &, SymbolVector &, SymbolVector &,
  48     std::map<const Symbol *, SourceName> &);
  49 static void PutPassName(llvm::raw_ostream &, const std::optional<SourceName> &);
  50 static void PutInit(llvm::raw_ostream &, const Symbol &, const MaybeExpr &,
  51     const parser::Expr *, const std::map<const Symbol *, SourceName> &);
  52 static void PutInit(llvm::raw_ostream &, const MaybeIntExpr &);
  53 static void PutBound(llvm::raw_ostream &, const Bound &);
  54 static void PutShapeSpec(llvm::raw_ostream &, const ShapeSpec &);
  55 static void PutShape(
  56     llvm::raw_ostream &, const ArraySpec &, char open, char close);
  57
  58 static llvm::raw_ostream &PutAttr(llvm::raw_ostream &, Attr);
  59 static llvm::raw_ostream &PutType(llvm::raw_ostream &, const DeclTypeSpec &);
  60 static llvm::raw_ostream &PutLower(llvm::raw_ostream &, std::string_view);
  61 static std::error_code WriteFile(
  62     const std::string &, const std::string &, bool = true);
  63 static bool FileContentsMatch(
  64     const std::string &, const std::string &, const std::string &);
  65 static std::string CheckSum(const std::string_view &);
  66
  67 // Collect symbols needed for a subprogram interface
  68 class SubprogramSymbolCollector {
  69 public:
  70   SubprogramSymbolCollector(const Symbol &symbol, const Scope &scope)
  71       : symbol_{symbol}, scope_{scope} {}
  72   const SymbolVector &symbols() const { return need_; }
  73   const std::set<SourceName> &imports() const { return imports_; }
  74   void Collect();
  75
  76 private:
  77   const Symbol &symbol_;
  78   const Scope &scope_;
  79   bool isInterface_{false};
  80   SymbolVector need_; // symbols that are needed
  81   UnorderedSymbolSet needSet_; // symbols already in need_
  82   UnorderedSymbolSet useSet_; // use-associations that might be needed
  83   std::set<SourceName> imports_; // imports from host that are needed
  84
  85   void DoSymbol(const Symbol &);
  86   void DoSymbol(const SourceName &, const Symbol &);
  87   void DoType(const DeclTypeSpec *);
  88   void DoBound(const Bound &);
  89   void DoParamValue(const ParamValue &);
  90   bool NeedImport(const SourceName &, const Symbol &);
  91
  92   template <typename T> void DoExpr(evaluate::Expr<T> expr) {
  93     for (const Symbol &symbol : evaluate::CollectSymbols(expr)) {
  94       DoSymbol(symbol);
  95     }
  96   }
  97 };
  98
  99 bool ModFileWriter::WriteAll() {
 100   // this flag affects character literals: force it to be consistent
 101   auto restorer{
 102       common::ScopedSet(parser::useHexadecimalEscapeSequences, false)};
 103   WriteAll(context_.globalScope());
 104   return !context_.AnyFatalError();
 105 }
 106
 107 void ModFileWriter::WriteAll(const Scope &scope) {
 108   for (const auto &child : scope.children()) {
 109     WriteOne(child);
 110   }
 111 }
 112
 113 void ModFileWriter::WriteOne(const Scope &scope) {
 114   if (scope.kind() == Scope::Kind::Module) {
 115     auto *symbol{scope.symbol()};
 116     if (!symbol->test(Symbol::Flag::ModFile)) {
 117       Write(*symbol);
 118     }
 119     WriteAll(scope); // write out submodules
 120   }
 121 }
 122
 123 // Construct the name of a module file. Non-empty ancestorName means submodule.
 124 static std::string ModFileName(const SourceName &name,
 125     const std::string &ancestorName, const std::string &suffix) {
 126   std::string result{name.ToString() + suffix};
 127   return ancestorName.empty() ? result : ancestorName + '-' + result;
 128 }
 129
 130 // Write the module file for symbol, which must be a module or submodule.
 131 void ModFileWriter::Write(const Symbol &symbol) {
 132   auto *ancestor{symbol.get<ModuleDetails>().ancestor()};
 133   isSubmodule_ = ancestor != nullptr;
 134   auto ancestorName{ancestor ? ancestor->GetName().value().ToString() : ""s};
 135   auto path{context_.moduleDirectory() + '/' +
 136       ModFileName(symbol.name(), ancestorName, context_.moduleFileSuffix())};
 137   PutSymbols(DEREF(symbol.scope()));
 138   if (std::error_code error{
 139           WriteFile(path, GetAsString(symbol), context_.debugModuleWriter())}) {
 140     context_.Say(
 141         symbol.name(), "Error writing %s: %s"_err_en_US, path, error.message());
 142   }
 143 }
 144
 145 // Return the entire body of the module file
 146 // and clear saved uses, decls, and contains.
 147 std::string ModFileWriter::GetAsString(const Symbol &symbol) {
 148   std::string buf;
 149   llvm::raw_string_ostream all{buf};
 150   auto &details{symbol.get<ModuleDetails>()};
 151   if (!details.isSubmodule()) {
 152     all << "module " << symbol.name();
 153   } else {
 154     auto *parent{details.parent()->symbol()};
 155     auto *ancestor{details.ancestor()->symbol()};
 156     all << "submodule(" << ancestor->name();
 157     if (parent != ancestor) {
 158       all << ':' << parent->name();
 159     }
 160     all << ") " << symbol.name();
 161   }
 162   all << '\n' << uses_.str();
 163   uses_.str().clear();
 164   all << useExtraAttrs_.str();
 165   useExtraAttrs_.str().clear();
 166   all << decls_.str();
 167   decls_.str().clear();
 168   auto str{contains_.str()};
 169   contains_.str().clear();
 170   if (!str.empty()) {
 171     all << "contains\n" << str;
 172   }
 173   all << "end\n";
 174   return all.str();
 175 }
 176
 177 // Collect symbols from initializations that are being referenced directly
 178 // from other modules; they may require new USE associations.
 179 static void HarvestInitializerSymbols(
 180     SourceOrderedSymbolSet &set, const Scope &scope) {
 181   for (const auto &[_, symbol] : scope) {
 182     if (symbol->has<DerivedTypeDetails>()) {
 183       if (symbol->scope()) {
 184         HarvestInitializerSymbols(set, *symbol->scope());
 185       }
 186     } else if (IsNamedConstant(*symbol) || scope.IsDerivedType()) {
 187       if (const auto *object{symbol->detailsIf<ObjectEntityDetails>()}) {
 188         if (object->init()) {
 189           for (SymbolRef ref : evaluate::CollectSymbols(*object->init())) {
 190             set.emplace(*ref);
 191           }
 192         }
 193       } else if (const auto *proc{symbol->detailsIf<ProcEntityDetails>()}) {
 194         if (proc->init() && *proc->init()) {
 195           set.emplace(**proc->init());
 196         }
 197       }
 198     }
 199   }
 200 }
 201
 202 void ModFileWriter::PrepareRenamings(const Scope &scope) {
 203   SourceOrderedSymbolSet symbolsInInits;
 204   HarvestInitializerSymbols(symbolsInInits, scope);
 205   for (SymbolRef s : symbolsInInits) {
 206     const Scope *sMod{FindModuleContaining(s->owner())};
 207     if (!sMod) {
 208       continue;
 209     }
 210     SourceName rename{s->name()};
 211     if (const Symbol * found{scope.FindSymbol(s->name())}) {
 212       if (found == &*s) {
 213         continue; // available in scope
 214       }
 215       if (const auto *generic{found->detailsIf<GenericDetails>()}) {
 216         if (generic->derivedType() == &*s || generic->specific() == &*s) {
 217           continue;
 218         }
 219       } else if (found->has<UseDetails>()) {
 220         if (&found->GetUltimate() == &*s) {
 221           continue; // already use-associated with same name
 222         }
 223       }
 224       if (&s->owner() != &found->owner()) { // Symbol needs renaming
 225         rename = scope.context().SaveTempName(
 226             DEREF(sMod->symbol()).name().ToString() + "$" +
 227             s->name().ToString());
 228       }
 229     }
 230     // Symbol is used in this scope but not visible under its name
 231     if (sMod->parent().IsIntrinsicModules()) {
 232       uses_ << "use,intrinsic::";
 233     } else {
 234       uses_ << "use ";
 235     }
 236     uses_ << DEREF(sMod->symbol()).name() << ",only:";
 237     if (rename != s->name()) {
 238       uses_ << rename << "=>";
 239     }
 240     uses_ << s->name() << '\n';
 241     useExtraAttrs_ << "private::" << rename << '\n';
 242     renamings_.emplace(&*s, rename);
 243   }
 244 }
 245
 246 // Put out the visible symbols from scope.
 247 void ModFileWriter::PutSymbols(const Scope &scope) {
 248   SymbolVector sorted;
 249   SymbolVector uses;
 250   PrepareRenamings(scope);
 251   CollectSymbols(scope, sorted, uses, renamings_);
 252   std::string buf; // stuff after CONTAINS in derived type
 253   llvm::raw_string_ostream typeBindings{buf};
 254   for (const Symbol &symbol : sorted) {
 255     if (!symbol.test(Symbol::Flag::CompilerCreated)) {
 256       PutSymbol(typeBindings, symbol);
 257     }
 258   }
 259   for (const Symbol &symbol : uses) {
 260     PutUse(symbol);
 261   }
 262   for (const auto &set : scope.equivalenceSets()) {
 263     if (!set.empty() &&
 264         !set.front().symbol.test(Symbol::Flag::CompilerCreated)) {
 265       char punctuation{'('};
 266       decls_ << "equivalence";
 267       for (const auto &object : set) {
 268         decls_ << punctuation << object.AsFortran();
 269         punctuation = ',';
 270       }
 271       decls_ << ")\n";
 272     }
 273   }
 274   CHECK(typeBindings.str().empty());
 275 }
 276
 277 // Emit components in order
 278 bool ModFileWriter::PutComponents(const Symbol &typeSymbol) {
 279   const auto &scope{DEREF(typeSymbol.scope())};
 280   std::string buf; // stuff after CONTAINS in derived type
 281   llvm::raw_string_ostream typeBindings{buf};
 282   UnorderedSymbolSet emitted;
 283   SymbolVector symbols{scope.GetSymbols()};
 284   // Emit type parameters first
 285   for (const Symbol &symbol : symbols) {
 286     if (symbol.has<TypeParamDetails>()) {
 287       PutSymbol(typeBindings, symbol);
 288       emitted.emplace(symbol);
 289     }
 290   }
 291   // Emit components in component order.
 292   const auto &details{typeSymbol.get<DerivedTypeDetails>()};
 293   for (SourceName name : details.componentNames()) {
 294     auto iter{scope.find(name)};
 295     if (iter != scope.end()) {
 296       const Symbol &component{*iter->second};
 297       if (!component.test(Symbol::Flag::ParentComp)) {
 298         PutSymbol(typeBindings, component);
 299       }
 300       emitted.emplace(component);
 301     }
 302   }
 303   // Emit remaining symbols from the type's scope
 304   for (const Symbol &symbol : symbols) {
 305     if (emitted.find(symbol) == emitted.end()) {
 306       PutSymbol(typeBindings, symbol);
 307     }
 308   }
 309   if (auto str{typeBindings.str()}; !str.empty()) {
 310     CHECK(scope.IsDerivedType());
 311     decls_ << "contains\n" << str;
 312     return true;
 313   } else {
 314     return false;
 315   }
 316 }
 317
 318 // Return the symbol's attributes that should be written
 319 // into the mod file.
 320 static Attrs getSymbolAttrsToWrite(const Symbol &symbol) {
 321   // Is SAVE attribute is implicit, it should be omitted
 322   // to not violate F202x C862 for a common block member.
 323   return symbol.attrs() & ~(symbol.implicitAttrs() & Attrs{Attr::SAVE});
 324 }
 325
 326 static llvm::raw_ostream &PutGenericName(
 327     llvm::raw_ostream &os, const Symbol &symbol) {
 328   if (IsGenericDefinedOp(symbol)) {
 329     return os << "operator(" << symbol.name() << ')';
 330   } else {
 331     return os << symbol.name();
 332   }
 333 }
 334
 335 // Emit a symbol to decls_, except for bindings in a derived type (type-bound
 336 // procedures, type-bound generics, final procedures) which go to typeBindings.
 337 void ModFileWriter::PutSymbol(
 338     llvm::raw_ostream &typeBindings, const Symbol &symbol) {
 339   common::visit(
 340       common::visitors{
 341           [&](const ModuleDetails &) { /* should be current module */ },
 342           [&](const DerivedTypeDetails &) { PutDerivedType(symbol); },
 343           [&](const SubprogramDetails &) { PutSubprogram(symbol); },
 344           [&](const GenericDetails &x) {
 345             if (symbol.owner().IsDerivedType()) {
 346               // generic binding
 347               for (const Symbol &proc : x.specificProcs()) {
 348                 PutGenericName(typeBindings << "generic::", symbol)
 349                     << "=>" << proc.name() << '\n';
 350               }
 351             } else {
 352               PutGeneric(symbol);
 353             }
 354           },
 355           [&](const UseDetails &) { PutUse(symbol); },
 356           [](const UseErrorDetails &) {},
 357           [&](const ProcBindingDetails &x) {
 358             bool deferred{symbol.attrs().test(Attr::DEFERRED)};
 359             typeBindings << "procedure";
 360             if (deferred) {
 361               typeBindings << '(' << x.symbol().name() << ')';
 362             }
 363             PutPassName(typeBindings, x.passName());
 364             auto attrs{symbol.attrs()};
 365             if (x.passName()) {
 366               attrs.reset(Attr::PASS);
 367             }
 368             PutAttrs(typeBindings, attrs);
 369             typeBindings << "::" << symbol.name();
 370             if (!deferred && x.symbol().name() != symbol.name()) {
 371               typeBindings << "=>" << x.symbol().name();
 372             }
 373             typeBindings << '\n';
 374           },
 375           [&](const NamelistDetails &x) {
 376             decls_ << "namelist/" << symbol.name();
 377             char sep{'/'};
 378             for (const Symbol &object : x.objects()) {
 379               decls_ << sep << object.name();
 380               sep = ',';
 381             }
 382             decls_ << '\n';
 383             if (!isSubmodule_ && symbol.attrs().test(Attr::PRIVATE)) {
 384               decls_ << "private::" << symbol.name() << '\n';
 385             }
 386           },
 387           [&](const CommonBlockDetails &x) {
 388             decls_ << "common/" << symbol.name();
 389             char sep = '/';
 390             for (const auto &object : x.objects()) {
 391               decls_ << sep << object->name();
 392               sep = ',';
 393             }
 394             decls_ << '\n';
 395             if (symbol.attrs().test(Attr::BIND_C)) {
 396               PutAttrs(decls_, getSymbolAttrsToWrite(symbol), x.bindName(),
 397                   x.isExplicitBindName(), ""s);
 398               decls_ << "::/" << symbol.name() << "/\n";
 399             }
 400           },
 401           [](const HostAssocDetails &) {},
 402           [](const MiscDetails &) {},
 403           [&](const auto &) {
 404             PutEntity(decls_, symbol);
 405             PutDirective(decls_, symbol);
 406           },
 407       },
 408       symbol.details());
 409 }
 410
 411 void ModFileWriter::PutDerivedType(
 412     const Symbol &typeSymbol, const Scope *scope) {
 413   auto &details{typeSymbol.get<DerivedTypeDetails>()};
 414   if (details.isDECStructure()) {
 415     PutDECStructure(typeSymbol, scope);
 416     return;
 417   }
 418   PutAttrs(decls_ << "type", typeSymbol.attrs());
 419   if (const DerivedTypeSpec * extends{typeSymbol.GetParentTypeSpec()}) {
 420     decls_ << ",extends(" << extends->name() << ')';
 421   }
 422   decls_ << "::" << typeSymbol.name();
 423   if (!details.paramNames().empty()) {
 424     char sep{'('};
 425     for (const auto &name : details.paramNames()) {
 426       decls_ << sep << name;
 427       sep = ',';
 428     }
 429     decls_ << ')';
 430   }
 431   decls_ << '\n';
 432   if (details.sequence()) {
 433     decls_ << "sequence\n";
 434   }
 435   bool contains{PutComponents(typeSymbol)};
 436   if (!details.finals().empty()) {
 437     const char *sep{contains ? "final::" : "contains\nfinal::"};
 438     for (const auto &pair : details.finals()) {
 439       decls_ << sep << pair.second->name();
 440       sep = ",";
 441     }
 442     if (*sep == ',') {
 443       decls_ << '\n';
 444     }
 445   }
 446   decls_ << "end type\n";
 447 }
 448
 449 void ModFileWriter::PutDECStructure(
 450     const Symbol &typeSymbol, const Scope *scope) {
 451   if (emittedDECStructures_.find(typeSymbol) != emittedDECStructures_.end()) {
 452     return;
 453   }
 454   if (!scope && context_.IsTempName(typeSymbol.name().ToString())) {
 455     return; // defer until used
 456   }
 457   emittedDECStructures_.insert(typeSymbol);
 458   decls_ << "structure ";
 459   if (!context_.IsTempName(typeSymbol.name().ToString())) {
 460     decls_ << typeSymbol.name();
 461   }
 462   if (scope && scope->kind() == Scope::Kind::DerivedType) {
 463     // Nested STRUCTURE: emit entity declarations right now
 464     // on the STRUCTURE statement.
 465     bool any{false};
 466     for (const auto &ref : scope->GetSymbols()) {
 467       const auto *object{ref->detailsIf<ObjectEntityDetails>()};
 468       if (object && object->type() &&
 469           object->type()->category() == DeclTypeSpec::TypeDerived &&
 470           &object->type()->derivedTypeSpec().typeSymbol() == &typeSymbol) {
 471         if (any) {
 472           decls_ << ',';
 473         } else {
 474           any = true;
 475         }
 476         decls_ << ref->name();
 477         PutShape(decls_, object->shape(), '(', ')');
 478         PutInit(decls_, *ref, object->init(), nullptr, renamings_);
 479         emittedDECFields_.insert(*ref);
 480       } else if (any) {
 481         break; // any later use of this structure will use RECORD/str/
 482       }
 483     }
 484   }
 485   decls_ << '\n';
 486   PutComponents(typeSymbol);
 487   decls_ << "end structure\n";
 488 }
 489
 490 // Attributes that may be in a subprogram prefix
 491 static const Attrs subprogramPrefixAttrs{Attr::ELEMENTAL, Attr::IMPURE,
 492     Attr::MODULE, Attr::NON_RECURSIVE, Attr::PURE, Attr::RECURSIVE};
 493
 494 static void PutOpenACCRoutineInfo(
 495     llvm::raw_ostream &os, const SubprogramDetails &details) {
 496   for (auto info : details.openACCRoutineInfos()) {
 497     os << "!$acc routine";
 498     if (info.isSeq()) {
 499       os << " seq";
 500     }
 501     if (info.isGang()) {
 502       os << " gang";
 503       if (info.gangDim() > 0) {
 504         os << "(dim: " << info.gangDim() << ")";
 505       }
 506     }
 507     if (info.isVector()) {
 508       os << " vector";
 509     }
 510     if (info.isWorker()) {
 511       os << " worker";
 512     }
 513     if (info.isNohost()) {
 514       os << " nohost";
 515     }
 516     if (info.bindName()) {
 517       os << " bind(" << *info.bindName() << ")";
 518     }
 519     os << "\n";
 520   }
 521 }
 522
 523 void ModFileWriter::PutSubprogram(const Symbol &symbol) {
 524   auto &details{symbol.get<SubprogramDetails>()};
 525   if (const Symbol * interface{details.moduleInterface()}) {
 526     const Scope *module{FindModuleContaining(interface->owner())};
 527     if (module && module != &symbol.owner()) {
 528       // Interface is in ancestor module
 529     } else {
 530       PutSubprogram(*interface);
 531     }
 532   }
 533   auto attrs{symbol.attrs()};
 534   Attrs bindAttrs{};
 535   if (attrs.test(Attr::BIND_C)) {
 536     // bind(c) is a suffix, not prefix
 537     bindAttrs.set(Attr::BIND_C, true);
 538     attrs.set(Attr::BIND_C, false);
 539   }
 540   bool isAbstract{attrs.test(Attr::ABSTRACT)};
 541   if (isAbstract) {
 542     attrs.set(Attr::ABSTRACT, false);
 543   }
 544   Attrs prefixAttrs{subprogramPrefixAttrs & attrs};
 545   // emit any non-prefix attributes in an attribute statement
 546   attrs &= ~subprogramPrefixAttrs;
 547   std::string ssBuf;
 548   llvm::raw_string_ostream ss{ssBuf};
 549   PutAttrs(ss, attrs);
 550   if (!ss.str().empty()) {
 551     decls_ << ss.str().substr(1) << "::" << symbol.name() << '\n';
 552   }
 553   bool isInterface{details.isInterface()};
 554   llvm::raw_ostream &os{isInterface ? decls_ : contains_};
 555   if (isInterface) {
 556     os << (isAbstract ? "abstract " : "") << "interface\n";
 557   }
 558   PutAttrs(os, prefixAttrs, nullptr, false, ""s, " "s);
 559   if (auto attrs{details.cudaSubprogramAttrs()}) {
 560     if (*attrs == common::CUDASubprogramAttrs::HostDevice) {
 561       os << "attributes(host,device) ";
 562     } else {
 563       PutLower(os << "attributes(", common::EnumToString(*attrs)) << ") ";
 564     }
 565     if (!details.cudaLaunchBounds().empty()) {
 566       os << "launch_bounds";
 567       char sep{'('};
 568       for (auto x : details.cudaLaunchBounds()) {
 569         os << sep << x;
 570         sep = ',';
 571       }
 572       os << ") ";
 573     }
 574     if (!details.cudaClusterDims().empty()) {
 575       os << "cluster_dims";
 576       char sep{'('};
 577       for (auto x : details.cudaClusterDims()) {
 578         os << sep << x;
 579         sep = ',';
 580       }
 581       os << ") ";
 582     }
 583   }
 584   os << (details.isFunction() ? "function " : "subroutine ");
 585   os << symbol.name() << '(';
 586   int n = 0;
 587   for (const auto &dummy : details.dummyArgs()) {
 588     if (n++ > 0) {
 589       os << ',';
 590     }
 591     if (dummy) {
 592       os << dummy->name();
 593     } else {
 594       os << "*";
 595     }
 596   }
 597   os << ')';
 598   PutAttrs(os, bindAttrs, details.bindName(), details.isExplicitBindName(),
 599       " "s, ""s);
 600   if (details.isFunction()) {
 601     const Symbol &result{details.result()};
 602     if (result.name() != symbol.name()) {
 603       os << " result(" << result.name() << ')';
 604     }
 605   }
 606   os << '\n';
 607   // walk symbols, collect ones needed for interface
 608   const Scope &scope{
 609       details.entryScope() ? *details.entryScope() : DEREF(symbol.scope())};
 610   SubprogramSymbolCollector collector{symbol, scope};
 611   collector.Collect();
 612   std::string typeBindingsBuf;
 613   llvm::raw_string_ostream typeBindings{typeBindingsBuf};
 614   ModFileWriter writer{context_};
 615   for (const Symbol &need : collector.symbols()) {
 616     writer.PutSymbol(typeBindings, need);
 617   }
 618   CHECK(typeBindings.str().empty());
 619   os << writer.uses_.str();
 620   for (const SourceName &import : collector.imports()) {
 621     decls_ << "import::" << import << "\n";
 622   }
 623   os << writer.decls_.str();
 624   PutOpenACCRoutineInfo(os, details);
 625   os << "end\n";
 626   if (isInterface) {
 627     os << "end interface\n";
 628   }
 629 }
 630
 631 static bool IsIntrinsicOp(const Symbol &symbol) {
 632   if (const auto *details{symbol.GetUltimate().detailsIf<GenericDetails>()}) {
 633     return details->kind().IsIntrinsicOperator();
 634   } else {
 635     return false;
 636   }
 637 }
 638
 639 void ModFileWriter::PutGeneric(const Symbol &symbol) {
 640   const auto &genericOwner{symbol.owner()};
 641   auto &details{symbol.get<GenericDetails>()};
 642   PutGenericName(decls_ << "interface ", symbol) << '\n';
 643   for (const Symbol &specific : details.specificProcs()) {
 644     if (specific.owner() == genericOwner) {
 645       decls_ << "procedure::" << specific.name() << '\n';
 646     }
 647   }
 648   decls_ << "end interface\n";
 649   if (!isSubmodule_ && symbol.attrs().test(Attr::PRIVATE)) {
 650     PutGenericName(decls_ << "private::", symbol) << '\n';
 651   }
 652 }
 653
 654 void ModFileWriter::PutUse(const Symbol &symbol) {
 655   auto &details{symbol.get<UseDetails>()};
 656   auto &use{details.symbol()};
 657   const Symbol &module{GetUsedModule(details)};
 658   if (use.owner().parent().IsIntrinsicModules()) {
 659     uses_ << "use,intrinsic::";
 660   } else {
 661     uses_ << "use ";
 662   }
 663   uses_ << module.name() << ",only:";
 664   PutGenericName(uses_, symbol);
 665   // Can have intrinsic op with different local-name and use-name
 666   // (e.g. `operator(<)` and `operator(.lt.)`) but rename is not allowed
 667   if (!IsIntrinsicOp(symbol) && use.name() != symbol.name()) {
 668     PutGenericName(uses_ << "=>", use);
 669   }
 670   uses_ << '\n';
 671   PutUseExtraAttr(Attr::VOLATILE, symbol, use);
 672   PutUseExtraAttr(Attr::ASYNCHRONOUS, symbol, use);
 673   if (!isSubmodule_ && symbol.attrs().test(Attr::PRIVATE)) {
 674     PutGenericName(useExtraAttrs_ << "private::", symbol) << '\n';
 675   }
 676 }
 677
 678 // We have "USE local => use" in this module. If attr was added locally
 679 // (i.e. on local but not on use), also write it out in the mod file.
 680 void ModFileWriter::PutUseExtraAttr(
 681     Attr attr, const Symbol &local, const Symbol &use) {
 682   if (local.attrs().test(attr) && !use.attrs().test(attr)) {
 683     PutAttr(useExtraAttrs_, attr) << "::";
 684     useExtraAttrs_ << local.name() << '\n';
 685   }
 686 }
 687
 688 static inline SourceName NameInModuleFile(const Symbol &symbol) {
 689   if (const auto *use{symbol.detailsIf<UseDetails>()}) {
 690     if (use->symbol().attrs().test(Attr::PRIVATE)) {
 691       // Avoid the use in sorting of names created to access private
 692       // specific procedures as a result of generic resolution;
 693       // they're not in the cooked source.
 694       return use->symbol().name();
 695     }
 696   }
 697   return symbol.name();
 698 }
 699
 700 // Collect the symbols of this scope sorted by their original order, not name.
 701 // Generics and namelists are exceptions: they are sorted after other symbols.
 702 void CollectSymbols(const Scope &scope, SymbolVector &sorted,
 703     SymbolVector &uses, std::map<const Symbol *, SourceName> &renamings) {
 704   SymbolVector namelist, generics;
 705   auto symbols{scope.GetSymbols()};
 706   std::size_t commonSize{scope.commonBlocks().size()};
 707   sorted.reserve(symbols.size() + commonSize);
 708   for (SymbolRef symbol : symbols) {
 709     if (symbol->test(Symbol::Flag::ParentComp)) {
 710     } else if (symbol->has<NamelistDetails>()) {
 711       namelist.push_back(symbol);
 712     } else if (const auto *generic{symbol->detailsIf<GenericDetails>()}) {
 713       if (generic->specific() &&
 714           &generic->specific()->owner() == &symbol->owner()) {
 715         sorted.push_back(*generic->specific());
 716       } else if (generic->derivedType() &&
 717           &generic->derivedType()->owner() == &symbol->owner()) {
 718         sorted.push_back(*generic->derivedType());
 719       }
 720       generics.push_back(symbol);
 721     } else {
 722       sorted.push_back(symbol);
 723     }
 724     if (const auto *details{symbol->detailsIf<GenericDetails>()}) {
 725       uses.insert(uses.end(), details->uses().begin(), details->uses().end());
 726     }
 727   }
 728   // Sort most symbols by name: use of Symbol::ReplaceName ensures the source
 729   // location of a symbol's name is the first "real" use.
 730   auto sorter{[](SymbolRef x, SymbolRef y) {
 731     return NameInModuleFile(*x).begin() < NameInModuleFile(*y).begin();
 732   }};
 733   std::sort(sorted.begin(), sorted.end(), sorter);
 734   std::sort(generics.begin(), generics.end(), sorter);
 735   sorted.insert(sorted.end(), generics.begin(), generics.end());
 736   sorted.insert(sorted.end(), namelist.begin(), namelist.end());
 737   for (const auto &pair : scope.commonBlocks()) {
 738     sorted.push_back(*pair.second);
 739   }
 740   std::sort(
 741       sorted.end() - commonSize, sorted.end(), SymbolSourcePositionCompare{});
 742 }
 743
 744 void ModFileWriter::PutEntity(llvm::raw_ostream &os, const Symbol &symbol) {
 745   common::visit(
 746       common::visitors{
 747           [&](const ObjectEntityDetails &) { PutObjectEntity(os, symbol); },
 748           [&](const ProcEntityDetails &) { PutProcEntity(os, symbol); },
 749           [&](const TypeParamDetails &) { PutTypeParam(os, symbol); },
 750           [&](const auto &) {
 751             common::die("PutEntity: unexpected details: %s",
 752                 DetailsToString(symbol.details()).c_str());
 753           },
 754       },
 755       symbol.details());
 756 }
 757
 758 void PutShapeSpec(llvm::raw_ostream &os, const ShapeSpec &x) {
 759   if (x.lbound().isStar()) {
 760     CHECK(x.ubound().isStar());
 761     os << ".."; // assumed rank
 762   } else {
 763     if (!x.lbound().isColon()) {
 764       PutBound(os, x.lbound());
 765     }
 766     os << ':';
 767     if (!x.ubound().isColon()) {
 768       PutBound(os, x.ubound());
 769     }
 770   }
 771 }
 772 void PutShape(
 773     llvm::raw_ostream &os, const ArraySpec &shape, char open, char close) {
 774   if (!shape.empty()) {
 775     os << open;
 776     bool first{true};
 777     for (const auto &shapeSpec : shape) {
 778       if (first) {
 779         first = false;
 780       } else {
 781         os << ',';
 782       }
 783       PutShapeSpec(os, shapeSpec);
 784     }
 785     os << close;
 786   }
 787 }
 788
 789 void ModFileWriter::PutObjectEntity(
 790     llvm::raw_ostream &os, const Symbol &symbol) {
 791   auto &details{symbol.get<ObjectEntityDetails>()};
 792   if (details.type() &&
 793       details.type()->category() == DeclTypeSpec::TypeDerived) {
 794     const Symbol &typeSymbol{details.type()->derivedTypeSpec().typeSymbol()};
 795     if (typeSymbol.get<DerivedTypeDetails>().isDECStructure()) {
 796       PutDerivedType(typeSymbol, &symbol.owner());
 797       if (emittedDECFields_.find(symbol) != emittedDECFields_.end()) {
 798         return; // symbol was emitted on STRUCTURE statement
 799       }
 800     }
 801   }
 802   PutEntity(
 803       os, symbol, [&]() { PutType(os, DEREF(symbol.GetType())); },
 804       getSymbolAttrsToWrite(symbol));
 805   PutShape(os, details.shape(), '(', ')');
 806   PutShape(os, details.coshape(), '[', ']');
 807   PutInit(os, symbol, details.init(), details.unanalyzedPDTComponentInit(),
 808       renamings_);
 809   os << '\n';
 810   if (auto tkr{GetIgnoreTKR(symbol)}; !tkr.empty()) {
 811     os << "!dir$ ignore_tkr(";
 812     tkr.IterateOverMembers([&](common::IgnoreTKR tkr) {
 813       switch (tkr) {
 814         SWITCH_COVERS_ALL_CASES
 815       case common::IgnoreTKR::Type:
 816         os << 't';
 817         break;
 818       case common::IgnoreTKR::Kind:
 819         os << 'k';
 820         break;
 821       case common::IgnoreTKR::Rank:
 822         os << 'r';
 823         break;
 824       case common::IgnoreTKR::Device:
 825         os << 'd';
 826         break;
 827       case common::IgnoreTKR::Managed:
 828         os << 'm';
 829         break;
 830       case common::IgnoreTKR::Contiguous:
 831         os << 'c';
 832         break;
 833       }
 834     });
 835     os << ") " << symbol.name() << '\n';
 836   }
 837   if (auto attr{details.cudaDataAttr()}) {
 838     PutLower(os << "attributes(", common::EnumToString(*attr))
 839         << ") " << symbol.name() << '\n';
 840   }
 841   if (symbol.test(Fortran::semantics::Symbol::Flag::CrayPointer)) {
 842     if (!symbol.owner().crayPointers().empty()) {
 843       for (const auto &[pointee, pointer] : symbol.owner().crayPointers()) {
 844         if (pointer == symbol) {
 845           os << "pointer(" << symbol.name() << "," << pointee << ")\n";
 846         }
 847       }
 848     }
 849   }
 850 }
 851
 852 void ModFileWriter::PutProcEntity(llvm::raw_ostream &os, const Symbol &symbol) {
 853   if (symbol.attrs().test(Attr::INTRINSIC)) {
 854     os << "intrinsic::" << symbol.name() << '\n';
 855     if (!isSubmodule_ && symbol.attrs().test(Attr::PRIVATE)) {
 856       os << "private::" << symbol.name() << '\n';
 857     }
 858     return;
 859   }
 860   const auto &details{symbol.get<ProcEntityDetails>()};
 861   Attrs attrs{symbol.attrs()};
 862   if (details.passName()) {
 863     attrs.reset(Attr::PASS);
 864   }
 865   PutEntity(
 866       os, symbol,
 867       [&]() {
 868         os << "procedure(";
 869         if (details.procInterface()) {
 870           os << details.procInterface()->name();
 871         } else if (details.type()) {
 872           PutType(os, *details.type());
 873         }
 874         os << ')';
 875         PutPassName(os, details.passName());
 876       },
 877       attrs);
 878   os << '\n';
 879 }
 880
 881 void PutPassName(
 882     llvm::raw_ostream &os, const std::optional<SourceName> &passName) {
 883   if (passName) {
 884     os << ",pass(" << *passName << ')';
 885   }
 886 }
 887
 888 void ModFileWriter::PutTypeParam(llvm::raw_ostream &os, const Symbol &symbol) {
 889   auto &details{symbol.get<TypeParamDetails>()};
 890   PutEntity(
 891       os, symbol,
 892       [&]() {
 893         PutType(os, DEREF(symbol.GetType()));
 894         PutLower(os << ',', common::EnumToString(details.attr()));
 895       },
 896       symbol.attrs());
 897   PutInit(os, details.init());
 898   os << '\n';
 899 }
 900
 901 void PutInit(llvm::raw_ostream &os, const Symbol &symbol, const MaybeExpr &init,
 902     const parser::Expr *unanalyzed,
 903     const std::map<const Symbol *, SourceName> &renamings) {
 904   if (IsNamedConstant(symbol) || symbol.owner().IsDerivedType()) {
 905     const char *assign{symbol.attrs().test(Attr::POINTER) ? "=>" : "="};
 906     if (unanalyzed) {
 907       parser::Unparse(os << assign, *unanalyzed);
 908     } else if (init) {
 909       if (const auto *dtConst{
 910               evaluate::UnwrapExpr<evaluate::Constant<evaluate::SomeDerived>>(
 911                   *init)}) {
 912         const Symbol &dtSym{dtConst->result().derivedTypeSpec().typeSymbol()};
 913         if (auto iter{renamings.find(&dtSym)}; iter != renamings.end()) {
 914           // Initializer is a constant whose derived type's name has
 915           // been brought into scope from a module under a new name
 916           // to avoid a conflict.
 917           dtConst->AsFortran(os << assign, &iter->second);
 918           return;
 919         }
 920       }
 921       init->AsFortran(os << assign);
 922     }
 923   }
 924 }
 925
 926 void PutInit(llvm::raw_ostream &os, const MaybeIntExpr &init) {
 927   if (init) {
 928     init->AsFortran(os << '=');
 929   }
 930 }
 931
 932 void PutBound(llvm::raw_ostream &os, const Bound &x) {
 933   if (x.isStar()) {
 934     os << '*';
 935   } else if (x.isColon()) {
 936     os << ':';
 937   } else {
 938     x.GetExplicit()->AsFortran(os);
 939   }
 940 }
 941
 942 // Write an entity (object or procedure) declaration.
 943 // writeType is called to write out the type.
 944 void ModFileWriter::PutEntity(llvm::raw_ostream &os, const Symbol &symbol,
 945     std::function<void()> writeType, Attrs attrs) {
 946   writeType();
 947   PutAttrs(os, attrs, symbol.GetBindName(), symbol.GetIsExplicitBindName());
 948   if (symbol.owner().kind() == Scope::Kind::DerivedType &&
 949       context_.IsTempName(symbol.name().ToString())) {
 950     os << "::%FILL";
 951   } else {
 952     os << "::" << symbol.name();
 953   }
 954 }
 955
 956 // Put out each attribute to os, surrounded by `before` and `after` and
 957 // mapped to lower case.
 958 llvm::raw_ostream &ModFileWriter::PutAttrs(llvm::raw_ostream &os, Attrs attrs,
 959     const std::string *bindName, bool isExplicitBindName, std::string before,
 960     std::string after) const {
 961   attrs.set(Attr::PUBLIC, false); // no need to write PUBLIC
 962   attrs.set(Attr::EXTERNAL, false); // no need to write EXTERNAL
 963   if (isSubmodule_) {
 964     attrs.set(Attr::PRIVATE, false);
 965   }
 966   if (bindName || isExplicitBindName) {
 967     os << before << "bind(c";
 968     if (isExplicitBindName) {
 969       os << ",name=\"" << (bindName ? *bindName : ""s) << '"';
 970     }
 971     os << ')' << after;
 972     attrs.set(Attr::BIND_C, false);
 973   }
 974   for (std::size_t i{0}; i < Attr_enumSize; ++i) {
 975     Attr attr{static_cast<Attr>(i)};
 976     if (attrs.test(attr)) {
 977       PutAttr(os << before, attr) << after;
 978     }
 979   }
 980   return os;
 981 }
 982
 983 llvm::raw_ostream &PutAttr(llvm::raw_ostream &os, Attr attr) {
 984   return PutLower(os, AttrToString(attr));
 985 }
 986
 987 llvm::raw_ostream &PutType(llvm::raw_ostream &os, const DeclTypeSpec &type) {
 988   return PutLower(os, type.AsFortran());
 989 }
 990
 991 llvm::raw_ostream &PutLower(llvm::raw_ostream &os, std::string_view str) {
 992   for (char c : str) {
 993     os << parser::ToLowerCaseLetter(c);
 994   }
 995   return os;
 996 }
 997
 998 void PutOpenACCDirective(llvm::raw_ostream &os, const Symbol &symbol) {
 999   if (symbol.test(Symbol::Flag::AccDeclare)) {
1000     os << "!$acc declare ";
1001     if (symbol.test(Symbol::Flag::AccCopy)) {
1002       os << "copy";
1003     } else if (symbol.test(Symbol::Flag::AccCopyIn) ||
1004         symbol.test(Symbol::Flag::AccCopyInReadOnly)) {
1005       os << "copyin";
1006     } else if (symbol.test(Symbol::Flag::AccCopyOut)) {
1007       os << "copyout";
1008     } else if (symbol.test(Symbol::Flag::AccCreate)) {
1009       os << "create";
1010     } else if (symbol.test(Symbol::Flag::AccPresent)) {
1011       os << "present";
1012     } else if (symbol.test(Symbol::Flag::AccDevicePtr)) {
1013       os << "deviceptr";
1014     } else if (symbol.test(Symbol::Flag::AccDeviceResident)) {
1015       os << "device_resident";
1016     } else if (symbol.test(Symbol::Flag::AccLink)) {
1017       os << "link";
1018     }
1019     os << "(";
1020     if (symbol.test(Symbol::Flag::AccCopyInReadOnly)) {
1021       os << "readonly: ";
1022     }
1023     os << symbol.name() << ")\n";
1024   }
1025 }
1026
1027 void PutOpenMPDirective(llvm::raw_ostream &os, const Symbol &symbol) {
1028   if (symbol.test(Symbol::Flag::OmpThreadprivate)) {
1029     os << "!$omp threadprivate(" << symbol.name() << ")\n";
1030   }
1031 }
1032
1033 void ModFileWriter::PutDirective(llvm::raw_ostream &os, const Symbol &symbol) {
1034   PutOpenACCDirective(os, symbol);
1035   PutOpenMPDirective(os, symbol);
1036 }
1037
1038 struct Temp {
1039   Temp(int fd, std::string path) : fd{fd}, path{path} {}
1040   Temp(Temp &&t) : fd{std::exchange(t.fd, -1)}, path{std::move(t.path)} {}
1041   ~Temp() {
1042     if (fd >= 0) {
1043       llvm::sys::fs::file_t native{llvm::sys::fs::convertFDToNativeFile(fd)};
1044       llvm::sys::fs::closeFile(native);
1045       llvm::sys::fs::remove(path.c_str());
1046     }
1047   }
1048   int fd;
1049   std::string path;
1050 };
1051
1052 // Create a temp file in the same directory and with the same suffix as path.
1053 // Return an open file descriptor and its path.
1054 static llvm::ErrorOr<Temp> MkTemp(const std::string &path) {
1055   auto length{path.length()};
1056   auto dot{path.find_last_of("./")};
1057   std::string suffix{
1058       dot < length && path[dot] == '.' ? path.substr(dot + 1) : ""};
1059   CHECK(length > suffix.length() &&
1060       path.substr(length - suffix.length()) == suffix);
1061   auto prefix{path.substr(0, length - suffix.length())};
1062   int fd;
1063   llvm::SmallString<16> tempPath;
1064   if (std::error_code err{llvm::sys::fs::createUniqueFile(
1065           prefix + "%%%%%%" + suffix, fd, tempPath)}) {
1066     return err;
1067   }
1068   return Temp{fd, tempPath.c_str()};
1069 }
1070
1071 // Write the module file at path, prepending header. If an error occurs,
1072 // return errno, otherwise 0.
1073 static std::error_code WriteFile(
1074     const std::string &path, const std::string &contents, bool debug) {
1075   auto header{std::string{ModHeader::bom} + ModHeader::magic +
1076       CheckSum(contents) + ModHeader::terminator};
1077   if (debug) {
1078     llvm::dbgs() << "Processing module " << path << ": ";
1079   }
1080   if (FileContentsMatch(path, header, contents)) {
1081     if (debug) {
1082       llvm::dbgs() << "module unchanged, not writing\n";
1083     }
1084     return {};
1085   }
1086   llvm::ErrorOr<Temp> temp{MkTemp(path)};
1087   if (!temp) {
1088     return temp.getError();
1089   }
1090   llvm::raw_fd_ostream writer(temp->fd, /*shouldClose=*/false);
1091   writer << header;
1092   writer << contents;
1093   writer.flush();
1094   if (writer.has_error()) {
1095     return writer.error();
1096   }
1097   if (debug) {
1098     llvm::dbgs() << "module written\n";
1099   }
1100   return llvm::sys::fs::rename(temp->path, path);
1101 }
1102
1103 // Return true if the stream matches what we would write for the mod file.
1104 static bool FileContentsMatch(const std::string &path,
1105     const std::string &header, const std::string &contents) {
1106   std::size_t hsize{header.size()};
1107   std::size_t csize{contents.size()};
1108   auto buf_or{llvm::MemoryBuffer::getFile(path)};
1109   if (!buf_or) {
1110     return false;
1111   }
1112   auto buf = std::move(buf_or.get());
1113   if (buf->getBufferSize() != hsize + csize) {
1114     return false;
1115   }
1116   if (!std::equal(header.begin(), header.end(), buf->getBufferStart(),
1117           buf->getBufferStart() + hsize)) {
1118     return false;
1119   }
1120
1121   return std::equal(contents.begin(), contents.end(),
1122       buf->getBufferStart() + hsize, buf->getBufferEnd());
1123 }
1124
1125 // Compute a simple hash of the contents of a module file and
1126 // return it as a string of hex digits.
1127 // This uses the Fowler-Noll-Vo hash function.
1128 static std::string CheckSum(const std::string_view &contents) {
1129   std::uint64_t hash{0xcbf29ce484222325ull};
1130   for (char c : contents) {
1131     hash ^= c & 0xff;
1132     hash *= 0x100000001b3;
1133   }
1134   static const char *digits = "0123456789abcdef";
1135   std::string result(ModHeader::sumLen, '0');
1136   for (size_t i{ModHeader::sumLen}; hash != 0; hash >>= 4) {
1137     result[--i] = digits[hash & 0xf];
1138   }
1139   return result;
1140 }
1141
1142 static bool VerifyHeader(llvm::ArrayRef<char> content) {
1143   std::string_view sv{content.data(), content.size()};
1144   if (sv.substr(0, ModHeader::magicLen) != ModHeader::magic) {
1145     return false;
1146   }
1147   std::string_view expectSum{sv.substr(ModHeader::magicLen, ModHeader::sumLen)};
1148   std::string actualSum{CheckSum(sv.substr(ModHeader::len))};
1149   return expectSum == actualSum;
1150 }
1151
1152 Scope *ModFileReader::Read(const SourceName &name,
1153     std::optional<bool> isIntrinsic, Scope *ancestor, bool silent) {
1154   std::string ancestorName; // empty for module
1155   Symbol *notAModule{nullptr};
1156   bool fatalError{false};
1157   if (ancestor) {
1158     if (auto *scope{ancestor->FindSubmodule(name)}) {
1159       return scope;
1160     }
1161     ancestorName = ancestor->GetName().value().ToString();
1162   }
1163   if (!isIntrinsic.value_or(false) && !ancestor) {
1164     // Already present in the symbol table as a usable non-intrinsic module?
1165     auto it{context_.globalScope().find(name)};
1166     if (it != context_.globalScope().end()) {
1167       Scope *scope{it->second->scope()};
1168       if (scope->kind() == Scope::Kind::Module) {
1169         return scope;
1170       } else {
1171         notAModule = scope->symbol();
1172         // USE, NON_INTRINSIC global name isn't a module?
1173         fatalError = isIntrinsic.has_value();
1174       }
1175     }
1176   }
1177   auto path{ModFileName(name, ancestorName, context_.moduleFileSuffix())};
1178   parser::Parsing parsing{context_.allCookedSources()};
1179   parser::Options options;
1180   options.isModuleFile = true;
1181   options.features.Enable(common::LanguageFeature::BackslashEscapes);
1182   options.features.Enable(common::LanguageFeature::OpenMP);
1183   options.features.Enable(common::LanguageFeature::CUDA);
1184   if (!isIntrinsic.value_or(false) && !notAModule) {
1185     // The search for this module file will scan non-intrinsic module
1186     // directories.  If a directory is in both the intrinsic and non-intrinsic
1187     // directory lists, the intrinsic module directory takes precedence.
1188     options.searchDirectories = context_.searchDirectories();
1189     for (const auto &dir : context_.intrinsicModuleDirectories()) {
1190       options.searchDirectories.erase(
1191           std::remove(options.searchDirectories.begin(),
1192               options.searchDirectories.end(), dir),
1193           options.searchDirectories.end());
1194     }
1195     options.searchDirectories.insert(options.searchDirectories.begin(), "."s);
1196   }
1197   bool foundNonIntrinsicModuleFile{false};
1198   if (!isIntrinsic) {
1199     std::list<std::string> searchDirs;
1200     for (const auto &d : options.searchDirectories) {
1201       searchDirs.push_back(d);
1202     }
1203     foundNonIntrinsicModuleFile =
1204         parser::LocateSourceFile(path, searchDirs).has_value();
1205   }
1206   if (isIntrinsic.value_or(!foundNonIntrinsicModuleFile)) {
1207     // Explicitly intrinsic, or not specified and not found in the search
1208     // path; see whether it's already in the symbol table as an intrinsic
1209     // module.
1210     auto it{context_.intrinsicModulesScope().find(name)};
1211     if (it != context_.intrinsicModulesScope().end()) {
1212       return it->second->scope();
1213     }
1214   }
1215   // We don't have this module in the symbol table yet.
1216   // Find its module file and parse it.  Define or extend the search
1217   // path with intrinsic module directories, if appropriate.
1218   if (isIntrinsic.value_or(true)) {
1219     for (const auto &dir : context_.intrinsicModuleDirectories()) {
1220       options.searchDirectories.push_back(dir);
1221     }
1222   }
1223   const auto *sourceFile{fatalError ? nullptr : parsing.Prescan(path, options)};
1224   if (fatalError || parsing.messages().AnyFatalError()) {
1225     if (!silent) {
1226       if (notAModule) {
1227         // Module is not explicitly INTRINSIC, and there's already a global
1228         // symbol of the same name that is not a module.
1229         context_.SayWithDecl(
1230             *notAModule, name, "'%s' is not a module"_err_en_US, name);
1231       } else {
1232         for (auto &msg : parsing.messages().messages()) {
1233           std::string str{msg.ToString()};
1234           Say(name, ancestorName,
1235               parser::MessageFixedText{str.c_str(), str.size(), msg.severity()},
1236               path);
1237         }
1238       }
1239     }
1240     return nullptr;
1241   }
1242   CHECK(sourceFile);
1243   if (!VerifyHeader(sourceFile->content())) {
1244     Say(name, ancestorName, "File has invalid checksum: %s"_warn_en_US,
1245         sourceFile->path());
1246     return nullptr;
1247   }
1248   llvm::raw_null_ostream NullStream;
1249   parsing.Parse(NullStream);
1250   std::optional<parser::Program> &parsedProgram{parsing.parseTree()};
1251   if (!parsing.messages().empty() || !parsing.consumedWholeFile() ||
1252       !parsedProgram) {
1253     Say(name, ancestorName, "Module file is corrupt: %s"_err_en_US,
1254         sourceFile->path());
1255     return nullptr;
1256   }
1257   parser::Program &parseTree{context_.SaveParseTree(std::move(*parsedProgram))};
1258   Scope *parentScope; // the scope this module/submodule goes into
1259   if (!isIntrinsic.has_value()) {
1260     for (const auto &dir : context_.intrinsicModuleDirectories()) {
1261       if (sourceFile->path().size() > dir.size() &&
1262           sourceFile->path().find(dir) == 0) {
1263         isIntrinsic = true;
1264         break;
1265       }
1266     }
1267   }
1268   Scope &topScope{isIntrinsic.value_or(false) ? context_.intrinsicModulesScope()
1269                                               : context_.globalScope()};
1270   Symbol *moduleSymbol{nullptr};
1271   if (!ancestor) { // module, not submodule
1272     parentScope = &topScope;
1273     auto pair{parentScope->try_emplace(name, UnknownDetails{})};
1274     if (!pair.second) {
1275       return nullptr;
1276     }
1277     moduleSymbol = &*pair.first->second;
1278     moduleSymbol->set(Symbol::Flag::ModFile);
1279   } else if (std::optional<SourceName> parent{GetSubmoduleParent(parseTree)}) {
1280     // submodule with submodule parent
1281     parentScope = Read(*parent, false /*not intrinsic*/, ancestor, silent);
1282   } else {
1283     // submodule with module parent
1284     parentScope = ancestor;
1285   }
1286   // Process declarations from the module file
1287   bool wasInModuleFile{context_.foldingContext().inModuleFile()};
1288   context_.foldingContext().set_inModuleFile(true);
1289   ResolveNames(context_, parseTree, topScope);
1290   context_.foldingContext().set_inModuleFile(wasInModuleFile);
1291   if (!moduleSymbol) {
1292     // Submodule symbols' storage are owned by their parents' scopes,
1293     // but their names are not in their parents' dictionaries -- we
1294     // don't want to report bogus errors about clashes between submodule
1295     // names and other objects in the parent scopes.
1296     if (Scope * submoduleScope{ancestor->FindSubmodule(name)}) {
1297       moduleSymbol = submoduleScope->symbol();
1298       if (moduleSymbol) {
1299         moduleSymbol->set(Symbol::Flag::ModFile);
1300       }
1301     }
1302   }
1303   if (moduleSymbol) {
1304     CHECK(moduleSymbol->has<ModuleDetails>());
1305     CHECK(moduleSymbol->test(Symbol::Flag::ModFile));
1306     if (isIntrinsic.value_or(false)) {
1307       moduleSymbol->attrs().set(Attr::INTRINSIC);
1308     }
1309     return moduleSymbol->scope();
1310   } else {
1311     return nullptr;
1312   }
1313 }
1314
1315 parser::Message &ModFileReader::Say(const SourceName &name,
1316     const std::string &ancestor, parser::MessageFixedText &&msg,
1317     const std::string &arg) {
1318   return context_.Say(name, "Cannot read module file for %s: %s"_err_en_US,
1319       parser::MessageFormattedText{ancestor.empty()
1320               ? "module '%s'"_en_US
1321               : "submodule '%s' of module '%s'"_en_US,
1322           name, ancestor}
1323           .MoveString(),
1324       parser::MessageFormattedText{std::move(msg), arg}.MoveString());
1325 }
1326
1327 // program was read from a .mod file for a submodule; return the name of the
1328 // submodule's parent submodule, nullptr if none.
1329 static std::optional<SourceName> GetSubmoduleParent(
1330     const parser::Program &program) {
1331   CHECK(program.v.size() == 1);
1332   auto &unit{program.v.front()};
1333   auto &submod{std::get<common::Indirection<parser::Submodule>>(unit.u)};
1334   auto &stmt{
1335       std::get<parser::Statement<parser::SubmoduleStmt>>(submod.value().t)};
1336   auto &parentId{std::get<parser::ParentIdentifier>(stmt.statement.t)};
1337   if (auto &parent{std::get<std::optional<parser::Name>>(parentId.t)}) {
1338     return parent->source;
1339   } else {
1340     return std::nullopt;
1341   }
1342 }
1343
1344 void SubprogramSymbolCollector::Collect() {
1345   const auto &details{symbol_.get<SubprogramDetails>()};
1346   isInterface_ = details.isInterface();
1347   for (const Symbol *dummyArg : details.dummyArgs()) {
1348     if (dummyArg) {
1349       DoSymbol(*dummyArg);
1350     }
1351   }
1352   if (details.isFunction()) {
1353     DoSymbol(details.result());
1354   }
1355   for (const auto &pair : scope_) {
1356     const Symbol &symbol{*pair.second};
1357     if (const auto *useDetails{symbol.detailsIf<UseDetails>()}) {
1358       const Symbol &ultimate{useDetails->symbol().GetUltimate()};
1359       bool needed{useSet_.count(ultimate) > 0};
1360       if (const auto *generic{ultimate.detailsIf<GenericDetails>()}) {
1361         // The generic may not be needed itself, but the specific procedure
1362         // &/or derived type that it shadows may be needed.
1363         const Symbol *spec{generic->specific()};
1364         const Symbol *dt{generic->derivedType()};
1365         needed = needed || (spec && useSet_.count(*spec) > 0) ||
1366             (dt && useSet_.count(*dt) > 0);
1367       } else if (const auto *subp{ultimate.detailsIf<SubprogramDetails>()}) {
1368         const Symbol *interface { subp->moduleInterface() };
1369         needed = needed || (interface && useSet_.count(*interface) > 0);
1370       }
1371       if (needed) {
1372         need_.push_back(symbol);
1373       }
1374     } else if (symbol.has<SubprogramDetails>()) {
1375       // An internal subprogram is needed if it is used as interface
1376       // for a dummy or return value procedure.
1377       bool needed{false};
1378       const auto hasInterface{[&symbol](const Symbol *s) -> bool {
1379         // Is 's' a procedure with interface 'symbol'?
1380         if (s) {
1381           if (const auto *sDetails{s->detailsIf<ProcEntityDetails>()}) {
1382             if (sDetails->procInterface() == &symbol) {
1383               return true;
1384             }
1385           }
1386         }
1387         return false;
1388       }};
1389       for (const Symbol *dummyArg : details.dummyArgs()) {
1390         needed = needed || hasInterface(dummyArg);
1391       }
1392       needed =
1393           needed || (details.isFunction() && hasInterface(&details.result()));
1394       if (needed && needSet_.insert(symbol).second) {
1395         need_.push_back(symbol);
1396       }
1397     }
1398   }
1399 }
1400
1401 void SubprogramSymbolCollector::DoSymbol(const Symbol &symbol) {
1402   DoSymbol(symbol.name(), symbol);
1403 }
1404
1405 // Do symbols this one depends on; then add to need_
1406 void SubprogramSymbolCollector::DoSymbol(
1407     const SourceName &name, const Symbol &symbol) {
1408   const auto &scope{symbol.owner()};
1409   if (scope != scope_ && !scope.IsDerivedType()) {
1410     if (scope != scope_.parent()) {
1411       useSet_.insert(symbol);
1412     }
1413     if (NeedImport(name, symbol)) {
1414       imports_.insert(name);
1415     }
1416     return;
1417   }
1418   if (!needSet_.insert(symbol).second) {
1419     return; // already done
1420   }
1421   common::visit(common::visitors{
1422                     [this](const ObjectEntityDetails &details) {
1423                       for (const ShapeSpec &spec : details.shape()) {
1424                         DoBound(spec.lbound());
1425                         DoBound(spec.ubound());
1426                       }
1427                       for (const ShapeSpec &spec : details.coshape()) {
1428                         DoBound(spec.lbound());
1429                         DoBound(spec.ubound());
1430                       }
1431                       if (const Symbol * commonBlock{details.commonBlock()}) {
1432                         DoSymbol(*commonBlock);
1433                       }
1434                     },
1435                     [this](const CommonBlockDetails &details) {
1436                       for (const auto &object : details.objects()) {
1437                         DoSymbol(*object);
1438                       }
1439                     },
1440                     [this](const ProcEntityDetails &details) {
1441                       if (details.procInterface()) {
1442                         DoSymbol(*details.procInterface());
1443                       } else {
1444                         DoType(details.type());
1445                       }
1446                     },
1447                     [](const auto &) {},
1448                 },
1449       symbol.details());
1450   if (!symbol.has<UseDetails>()) {
1451     DoType(symbol.GetType());
1452   }
1453   if (!scope.IsDerivedType()) {
1454     need_.push_back(symbol);
1455   }
1456 }
1457
1458 void SubprogramSymbolCollector::DoType(const DeclTypeSpec *type) {
1459   if (!type) {
1460     return;
1461   }
1462   switch (type->category()) {
1463   case DeclTypeSpec::Numeric:
1464   case DeclTypeSpec::Logical:
1465     break; // nothing to do
1466   case DeclTypeSpec::Character:
1467     DoParamValue(type->characterTypeSpec().length());
1468     break;
1469   default:
1470     if (const DerivedTypeSpec * derived{type->AsDerived()}) {
1471       const auto &typeSymbol{derived->typeSymbol()};
1472       if (const DerivedTypeSpec * extends{typeSymbol.GetParentTypeSpec()}) {
1473         DoSymbol(extends->name(), extends->typeSymbol());
1474       }
1475       for (const auto &pair : derived->parameters()) {
1476         DoParamValue(pair.second);
1477       }
1478       for (const auto &pair : *typeSymbol.scope()) {
1479         const Symbol &comp{*pair.second};
1480         DoSymbol(comp);
1481       }
1482       DoSymbol(derived->name(), derived->typeSymbol());
1483     }
1484   }
1485 }
1486
1487 void SubprogramSymbolCollector::DoBound(const Bound &bound) {
1488   if (const MaybeSubscriptIntExpr & expr{bound.GetExplicit()}) {
1489     DoExpr(*expr);
1490   }
1491 }
1492 void SubprogramSymbolCollector::DoParamValue(const ParamValue &paramValue) {
1493   if (const auto &expr{paramValue.GetExplicit()}) {
1494     DoExpr(*expr);
1495   }
1496 }
1497
1498 // Do we need a IMPORT of this symbol into an interface block?
1499 bool SubprogramSymbolCollector::NeedImport(
1500     const SourceName &name, const Symbol &symbol) {
1501   if (!isInterface_) {
1502     return false;
1503   } else if (IsSeparateModuleProcedureInterface(&symbol_)) {
1504     return false; // IMPORT needed only for external and dummy procedure
1505                   // interfaces
1506   } else if (&symbol == scope_.symbol()) {
1507     return false;
1508   } else if (symbol.owner().Contains(scope_)) {
1509     return true;
1510   } else if (const Symbol *found{scope_.FindSymbol(name)}) {
1511     // detect import from ancestor of use-associated symbol
1512     return found->has<UseDetails>() && found->owner() != scope_;
1513   } else {
1514     // "found" can be null in the case of a use-associated derived type's parent
1515     // type
1516     CHECK(symbol.has<DerivedTypeDetails>());
1517     return false;
1518   }
1519 }
1520
1521 } // namespace Fortran::semantics