flang/lib/Semantics/mod-file.cpp

//===-- lib/Semantics/mod-file.cpp ----------------------------------------===//
//
// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
// See https://llvm.org/LICENSE.txt for license information.
// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
//
//===----------------------------------------------------------------------===//

#include "mod-file.h"
#include "resolve-names.h"
#include "flang/Common/restorer.h"
#include "flang/Evaluate/tools.h"
#include "flang/Parser/message.h"
#include "flang/Parser/parsing.h"
#include "flang/Parser/unparse.h"
#include "flang/Semantics/scope.h"
#include "flang/Semantics/semantics.h"
#include "flang/Semantics/symbol.h"
#include "flang/Semantics/tools.h"
#include "llvm/Frontend/OpenMP/OMP.h"
#include "llvm/Support/FileSystem.h"
#include "llvm/Support/MemoryBuffer.h"
#include "llvm/Support/raw_ostream.h"
#include <algorithm>
#include <fstream>
#include <set>
#include <string_view>
#include <type_traits>
#include <variant>
#include <vector>

namespace Fortran::semantics {

using namespace parser::literals;

// The first line of a file that identifies it as a .mod file.
// The first three bytes are a Unicode byte order mark that ensures
// that the module file is decoded as UTF-8 even if source files
// are using another encoding.
struct ModHeader {
  static constexpr const char bom[3 + 1]{"\xef\xbb\xbf"};
  static constexpr int magicLen{13};
  static constexpr int sumLen{16};
  static constexpr const char magic[magicLen + 1]{"!mod$ v1 sum:"};
  static constexpr char terminator{'\n'};
  static constexpr int len{magicLen + 1 + sumLen};
  static constexpr int needLen{7};
  static constexpr const char need[needLen + 1]{"!need$ "};
};

static std::optional<SourceName> GetSubmoduleParent(const parser::Program &);
static void CollectSymbols(
    const Scope &, SymbolVector &, SymbolVector &, SourceOrderedSymbolSet &);
static void PutPassName(llvm::raw_ostream &, const std::optional<SourceName> &);
static void PutInit(llvm::raw_ostream &, const Symbol &, const MaybeExpr &,
    const parser::Expr *, SemanticsContext &);
static void PutInit(llvm::raw_ostream &, const MaybeIntExpr &);
static void PutBound(llvm::raw_ostream &, const Bound &);
static void PutShapeSpec(llvm::raw_ostream &, const ShapeSpec &);
static void PutShape(
    llvm::raw_ostream &, const ArraySpec &, char open, char close);
static void PutMapper(llvm::raw_ostream &, const Symbol &, SemanticsContext &);

static llvm::raw_ostream &PutAttr(llvm::raw_ostream &, Attr);
static llvm::raw_ostream &PutType(llvm::raw_ostream &, const DeclTypeSpec &);
static llvm::raw_ostream &PutLower(llvm::raw_ostream &, std::string_view);
static std::error_code WriteFile(const std::string &, const std::string &,
    ModuleCheckSumType &, bool debug = true);
static bool FileContentsMatch(
    const std::string &, const std::string &, const std::string &);
static ModuleCheckSumType ComputeCheckSum(const std::string_view &);
static std::string CheckSumString(ModuleCheckSumType);

// Collect symbols needed for a subprogram interface
class SubprogramSymbolCollector {
public:
  SubprogramSymbolCollector(const Symbol &symbol, const Scope &scope)
      : symbol_{symbol}, scope_{scope} {}
  const SymbolVector &symbols() const { return need_; }
  const std::set<SourceName> &imports() const { return imports_; }
  void Collect();

private:
  const Symbol &symbol_;
  const Scope &scope_;
  bool isInterface_{false};
  SymbolVector need_; // symbols that are needed
  UnorderedSymbolSet needSet_; // symbols already in need_
  UnorderedSymbolSet useSet_; // use-associations that might be needed
  std::set<SourceName> imports_; // imports from host that are needed

  void DoSymbol(const Symbol &);
  void DoSymbol(const SourceName &, const Symbol &);
  void DoType(const DeclTypeSpec *);
  void DoBound(const Bound &);
  void DoParamValue(const ParamValue &);
  bool NeedImport(const SourceName &, const Symbol &);

  template <typename T> void DoExpr(evaluate::Expr<T> expr) {
    for (const Symbol &symbol : evaluate::CollectSymbols(expr)) {
      DoSymbol(symbol);
    }
  }
};

bool ModFileWriter::WriteAll() {
  // this flag affects character literals: force it to be consistent
  auto restorer{
      common::ScopedSet(parser::useHexadecimalEscapeSequences, false)};
  WriteAll(context_.globalScope());
  return !context_.AnyFatalError();
}

void ModFileWriter::WriteAll(const Scope &scope) {
  for (const Scope &child : scope.children()) {
    WriteOne(child);
  }
}

void ModFileWriter::WriteOne(const Scope &scope) {
  if (scope.kind() == Scope::Kind::Module) {
    if (const auto *symbol{scope.symbol()}) {
      Write(*symbol);
    }
    WriteAll(scope); // write out submodules
  }
}

// Construct the name of a module file. Non-empty ancestorName means submodule.
static std::string ModFileName(const SourceName &name,
    const std::string &ancestorName, const std::string &suffix) {
  std::string result{name.ToString() + suffix};
  return ancestorName.empty() ? result : ancestorName + '-' + result;
}

// Write the module file for symbol, which must be a module or submodule.
void ModFileWriter::Write(const Symbol &symbol) {
  const auto &module{symbol.get<ModuleDetails>()};
  if (symbol.test(Symbol::Flag::ModFile) || module.moduleFileHash()) {
    return; // already written
  }
  const auto *ancestor{module.ancestor()};
  isSubmodule_ = ancestor != nullptr;
  auto ancestorName{ancestor ? ancestor->GetName().value().ToString() : ""s};
  std::string path{context_.moduleDirectory() + '/' +
      ModFileName(symbol.name(), ancestorName, context_.moduleFileSuffix())};

  std::set<std::string> hermeticModuleNames;
  hermeticModuleNames.insert(symbol.name().ToString());
  UnorderedSymbolSet additionalModules;
  PutSymbols(DEREF(symbol.scope()),
      hermeticModuleFileOutput_ ? &additionalModules : nullptr);
  auto asStr{GetAsString(symbol)};
  while (!additionalModules.empty()) {
    UnorderedSymbolSet nextPass{std::move(additionalModules)};
    additionalModules.clear();
    for (const Symbol &modSym : nextPass) {
      if (!modSym.owner().IsIntrinsicModules() &&
          hermeticModuleNames.find(modSym.name().ToString()) ==
              hermeticModuleNames.end()) {
        hermeticModuleNames.insert(modSym.name().ToString());
        PutSymbols(DEREF(modSym.scope()), &additionalModules);
        asStr += GetAsString(modSym);
      }
    }
  }

  ModuleCheckSumType checkSum;
  if (std::error_code error{
          WriteFile(path, asStr, checkSum, context_.debugModuleWriter())}) {
    context_.Say(
        symbol.name(), "Error writing %s: %s"_err_en_US, path, error.message());
  }
  const_cast<ModuleDetails &>(module).set_moduleFileHash(checkSum);
}

void ModFileWriter::WriteClosure(llvm::raw_ostream &out, const Symbol &symbol,
    UnorderedSymbolSet &nonIntrinsicModulesWritten) {
  if (!symbol.has<ModuleDetails>() || symbol.owner().IsIntrinsicModules() ||
      !nonIntrinsicModulesWritten.insert(symbol).second) {
    return;
  }
  PutSymbols(DEREF(symbol.scope()), /*hermeticModules=*/nullptr);
  needsBuf_.clear(); // omit module checksums
  auto str{GetAsString(symbol)};
  for (auto depRef : std::move(usedNonIntrinsicModules_)) {
    WriteClosure(out, *depRef, nonIntrinsicModulesWritten);
  }
  out << std::move(str);
}

// Return the entire body of the module file
// and clear saved uses, decls, and contains.
std::string ModFileWriter::GetAsString(const Symbol &symbol) {
  std::string buf;
  llvm::raw_string_ostream all{buf};
  all << needs_.str();
  needs_.str().clear();
  auto &details{symbol.get<ModuleDetails>()};
  if (!details.isSubmodule()) {
    all << "module " << symbol.name();
  } else {
    auto *parent{details.parent()->symbol()};
    auto *ancestor{details.ancestor()->symbol()};
    all << "submodule(" << ancestor->name();
    if (parent != ancestor) {
      all << ':' << parent->name();
    }
    all << ") " << symbol.name();
  }
  all << '\n' << uses_.str();
  uses_.str().clear();
  all << useExtraAttrs_.str();
  useExtraAttrs_.str().clear();
  all << decls_.str();
  decls_.str().clear();
  auto str{contains_.str()};
  contains_.str().clear();
  if (!str.empty()) {
    all << "contains\n" << str;
  }
  all << "end\n";
  return all.str();
}

// Collect symbols from constant and specification expressions that are being
// referenced directly from other modules; they may require new USE
// associations.
static void HarvestSymbolsNeededFromOtherModules(
    SourceOrderedSymbolSet &, const Scope &);
static void HarvestSymbolsNeededFromOtherModules(
    SourceOrderedSymbolSet &set, const Symbol &symbol, const Scope &scope) {
  auto HarvestBound{[&](const Bound &bound) {
    if (const auto &expr{bound.GetExplicit()}) {
      for (SymbolRef ref : evaluate::CollectSymbols(*expr)) {
        set.emplace(*ref);
      }
    }
  }};
  auto HarvestShapeSpec{[&](const ShapeSpec &shapeSpec) {
    HarvestBound(shapeSpec.lbound());
    HarvestBound(shapeSpec.ubound());
  }};
  auto HarvestArraySpec{[&](const ArraySpec &arraySpec) {
    for (const auto &shapeSpec : arraySpec) {
      HarvestShapeSpec(shapeSpec);
    }
  }};

  if (symbol.has<DerivedTypeDetails>()) {
    if (symbol.scope()) {
      HarvestSymbolsNeededFromOtherModules(set, *symbol.scope());
    }
  } else if (const auto &generic{symbol.detailsIf<GenericDetails>()};
             generic && generic->derivedType()) {
    const Symbol &dtSym{*generic->derivedType()};
    if (dtSym.has<DerivedTypeDetails>()) {
      if (dtSym.scope()) {
        HarvestSymbolsNeededFromOtherModules(set, *dtSym.scope());
      }
    } else {
      CHECK(dtSym.has<UseDetails>() || dtSym.has<UseErrorDetails>());
    }
  } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
    HarvestArraySpec(object->shape());
    HarvestArraySpec(object->coshape());
    if (IsNamedConstant(symbol) || scope.IsDerivedType()) {
      if (object->init()) {
        for (SymbolRef ref : evaluate::CollectSymbols(*object->init())) {
          set.emplace(*ref);
        }
      }
    }
  } else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
    if (proc->init() && *proc->init() && scope.IsDerivedType()) {
      set.emplace(**proc->init());
    }
  } else if (const auto *subp{symbol.detailsIf<SubprogramDetails>()}) {
    for (const Symbol *dummy : subp->dummyArgs()) {
      if (dummy) {
        HarvestSymbolsNeededFromOtherModules(set, *dummy, scope);
      }
    }
    if (subp->isFunction()) {
      HarvestSymbolsNeededFromOtherModules(set, subp->result(), scope);
    }
  }
}

static void HarvestSymbolsNeededFromOtherModules(
    SourceOrderedSymbolSet &set, const Scope &scope) {
  for (const auto &[_, symbol] : scope) {
    HarvestSymbolsNeededFromOtherModules(set, *symbol, scope);
  }
}

void ModFileWriter::PrepareRenamings(const Scope &scope) {
  // Identify use-associated symbols already in scope under some name
  std::map<const Symbol *, const Symbol *> useMap;
  for (const auto &[name, symbolRef] : scope) {
    const Symbol *symbol{&*symbolRef};
    while (const auto *hostAssoc{symbol->detailsIf<HostAssocDetails>()}) {
      symbol = &hostAssoc->symbol();
    }
    if (const auto *use{symbol->detailsIf<UseDetails>()}) {
      useMap.emplace(&use->symbol(), symbol);
    }
  }
  // Collect symbols needed from other modules
  SourceOrderedSymbolSet symbolsNeeded;
  HarvestSymbolsNeededFromOtherModules(symbolsNeeded, scope);
  // Establish any necessary renamings of symbols in other modules
  // to their names in this scope, creating those new names when needed.
  auto &renamings{context_.moduleFileOutputRenamings()};
  for (SymbolRef s : symbolsNeeded) {
    if (s->owner().kind() != Scope::Kind::Module) {
      // Not a USE'able name from a module's top scope;
      // component, binding, dummy argument, &c.
      continue;
    }
    const Scope *sMod{FindModuleContaining(s->owner())};
    if (!sMod || sMod == &scope) {
      continue;
    }
    if (auto iter{useMap.find(&*s)}; iter != useMap.end()) {
      renamings.emplace(&*s, iter->second->name());
      continue;
    }
    SourceName rename{s->name()};
    if (const Symbol * found{scope.FindSymbol(s->name())}) {
      if (found == &*s) {
        continue; // available in scope
      }
      if (const auto *generic{found->detailsIf<GenericDetails>()}) {
        if (generic->derivedType() == &*s || generic->specific() == &*s) {
          continue;
        }
      } else if (found->has<UseDetails>()) {
        if (&found->GetUltimate() == &*s) {
          continue; // already use-associated with same name
        }
      }
      if (&s->owner() != &found->owner()) { // Symbol needs renaming
        rename = scope.context().SaveTempName(
            DEREF(sMod->symbol()).name().ToString() + "$" +
            s->name().ToString());
      }
    }
    // Symbol is used in this scope but not visible under its name
    if (sMod->parent().IsIntrinsicModules()) {
      uses_ << "use,intrinsic::";
    } else {
      uses_ << "use ";
    }
    uses_ << DEREF(sMod->symbol()).name() << ",only:";
    if (rename != s->name()) {
      uses_ << rename << "=>";
      renamings.emplace(&s->GetUltimate(), rename);
    }
    uses_ << s->name() << '\n';
    useExtraAttrs_ << "private::" << rename << '\n';
  }
}

static void PutOpenMPRequirements(llvm::raw_ostream &os, const Symbol &symbol) {
  using RequiresClauses = WithOmpDeclarative::RequiresClauses;
  using OmpMemoryOrderType = common::OmpMemoryOrderType;

  const auto [reqs, order]{common::visit(
      [&](auto &&details)
          -> std::pair<const RequiresClauses *, const OmpMemoryOrderType *> {
        if constexpr (std::is_convertible_v<decltype(details),
                          const WithOmpDeclarative &>) {
          return {details.ompRequires(), details.ompAtomicDefaultMemOrder()};
        } else {
          return {nullptr, nullptr};
        }
      },
      symbol.details())};

  if (order) {
    llvm::omp::Clause admo{llvm::omp::Clause::OMPC_atomic_default_mem_order};
    os << "!$omp requires "
       << parser::ToLowerCaseLetters(llvm::omp::getOpenMPClauseName(admo))
       << '(' << parser::ToLowerCaseLetters(EnumToString(*order)) << ")\n";
  }
  if (reqs) {
    os << "!$omp requires";
    reqs->IterateOverMembers([&](llvm::omp::Clause f) {
      if (f != llvm::omp::Clause::OMPC_atomic_default_mem_order) {
        os << ' '
           << parser::ToLowerCaseLetters(llvm::omp::getOpenMPClauseName(f));
      }
    });
    os << "\n";
  }
}

// Put out the visible symbols from scope.
void ModFileWriter::PutSymbols(
    const Scope &scope, UnorderedSymbolSet *hermeticModules) {
  SymbolVector sorted;
  SymbolVector uses;
  auto &renamings{context_.moduleFileOutputRenamings()};
  auto previousRenamings{std::move(renamings)};
  PrepareRenamings(scope);
  SourceOrderedSymbolSet modules;
  CollectSymbols(scope, sorted, uses, modules);
  // Write module files for dependencies first so that their
  // hashes are known.
  for (const Symbol &mod : modules) {
    if (hermeticModules) {
      hermeticModules->insert(mod);
    } else {
      Write(mod);
      // It's possible that the module's file already existed and
      // without its own hash due to being embedded in a hermetic
      // module file.
      if (auto hash{mod.get<ModuleDetails>().moduleFileHash()}) {
        needs_ << ModHeader::need << CheckSumString(*hash)
               << (mod.owner().IsIntrinsicModules() ? " i " : " n ")
               << mod.name().ToString() << '\n';
      }
    }
  }
  std::string buf; // stuff after CONTAINS in derived type
  llvm::raw_string_ostream typeBindings{buf};
  for (const Symbol &symbol : sorted) {
    if (!symbol.test(Symbol::Flag::CompilerCreated)) {
      PutSymbol(typeBindings, symbol);
    }
  }
  for (const Symbol &symbol : uses) {
    PutUse(symbol);
  }
  PutOpenMPRequirements(decls_, DEREF(scope.symbol()));
  for (const auto &set : scope.equivalenceSets()) {
    if (!set.empty() &&
        !set.front().symbol.test(Symbol::Flag::CompilerCreated)) {
      char punctuation{'('};
      decls_ << "equivalence";
      for (const auto &object : set) {
        decls_ << punctuation << object.AsFortran();
        punctuation = ',';
      }
      decls_ << ")\n";
    }
  }
  CHECK(typeBindings.str().empty());
  renamings = std::move(previousRenamings);
}

// Emit components in order
bool ModFileWriter::PutComponents(const Symbol &typeSymbol) {
  const auto &scope{DEREF(typeSymbol.scope())};
  std::string buf; // stuff after CONTAINS in derived type
  llvm::raw_string_ostream typeBindings{buf};
  UnorderedSymbolSet emitted;
  SymbolVector symbols{scope.GetSymbols()};
  // Emit type parameter declarations first, in order
  const auto &details{typeSymbol.get<DerivedTypeDetails>()};
  for (const Symbol &symbol : details.paramDeclOrder()) {
    CHECK(symbol.has<TypeParamDetails>());
    PutSymbol(typeBindings, symbol);
    emitted.emplace(symbol);
  }
  // Emit actual components in component order.
  for (SourceName name : details.componentNames()) {
    auto iter{scope.find(name)};
    if (iter != scope.end()) {
      const Symbol &component{*iter->second};
      if (!component.test(Symbol::Flag::ParentComp)) {
        PutSymbol(typeBindings, component);
      }
      emitted.emplace(component);
    }
  }
  // Emit remaining symbols from the type's scope
  for (const Symbol &symbol : symbols) {
    if (emitted.find(symbol) == emitted.end()) {
      PutSymbol(typeBindings, symbol);
    }
  }
  if (auto str{typeBindings.str()}; !str.empty()) {
    CHECK(scope.IsDerivedType());
    decls_ << "contains\n" << str;
    return true;
  } else {
    return false;
  }
}

// Return the symbol's attributes that should be written
// into the mod file.
static Attrs getSymbolAttrsToWrite(const Symbol &symbol) {
  // Is SAVE attribute is implicit, it should be omitted
  // to not violate F202x C862 for a common block member.
  return symbol.attrs() & ~(symbol.implicitAttrs() & Attrs{Attr::SAVE});
}

static llvm::raw_ostream &PutGenericName(
    llvm::raw_ostream &os, const Symbol &symbol) {
  if (IsGenericDefinedOp(symbol)) {
    return os << "operator(" << symbol.name() << ')';
  } else {
    return os << symbol.name();
  }
}

// Emit a symbol to decls_, except for bindings in a derived type (type-bound
// procedures, type-bound generics, final procedures) which go to typeBindings.
void ModFileWriter::PutSymbol(
    llvm::raw_ostream &typeBindings, const Symbol &symbol) {
  common::visit(
      common::visitors{
          [&](const ModuleDetails &) { /* should be current module */ },
          [&](const DerivedTypeDetails &) { PutDerivedType(symbol); },
          [&](const SubprogramDetails &) { PutSubprogram(symbol); },
          [&](const GenericDetails &x) {
            if (symbol.owner().IsDerivedType()) {
              // generic binding
              for (const Symbol &proc : x.specificProcs()) {
                PutGenericName(typeBindings << "generic::", symbol)
                    << "=>" << proc.name() << '\n';
              }
            } else {
              PutGeneric(symbol);
            }
          },
          [&](const UseDetails &) { PutUse(symbol); },
          [](const UseErrorDetails &) {},
          [&](const ProcBindingDetails &x) {
            bool deferred{symbol.attrs().test(Attr::DEFERRED)};
            typeBindings << "procedure";
            if (deferred) {
              typeBindings << '(' << x.symbol().name() << ')';
            }
            PutPassName(typeBindings, x.passName());
            auto attrs{symbol.attrs()};
            if (x.passName()) {
              attrs.reset(Attr::PASS);
            }
            PutAttrs(typeBindings, attrs);
            typeBindings << "::" << symbol.name();
            if (!deferred && x.symbol().name() != symbol.name()) {
              typeBindings << "=>" << x.symbol().name();
            }
            typeBindings << '\n';
          },
          [&](const NamelistDetails &x) {
            decls_ << "namelist/" << symbol.name();
            char sep{'/'};
            for (const Symbol &object : x.objects()) {
              decls_ << sep << object.name();
              sep = ',';
            }
            decls_ << '\n';
            if (!isSubmodule_ && symbol.attrs().test(Attr::PRIVATE)) {
              decls_ << "private::" << symbol.name() << '\n';
            }
          },
          [&](const CommonBlockDetails &x) {
            decls_ << "common/" << symbol.name();
            char sep = '/';
            for (const auto &object : x.objects()) {
              decls_ << sep << object->name();
              sep = ',';
            }
            decls_ << '\n';
            if (symbol.attrs().test(Attr::BIND_C)) {
              PutAttrs(decls_, getSymbolAttrsToWrite(symbol), x.bindName(),
                  x.isExplicitBindName(), ""s);
              decls_ << "::/" << symbol.name() << "/\n";
            }
          },
          [](const HostAssocDetails &) {},
          [](const MiscDetails &) {},
          [&](const auto &) {
            PutEntity(decls_, symbol);
            PutDirective(decls_, symbol);
          },
      },
      symbol.details());
}

void ModFileWriter::PutDerivedType(
    const Symbol &typeSymbol, const Scope *scope) {
  auto &details{typeSymbol.get<DerivedTypeDetails>()};
  if (details.isDECStructure()) {
    PutDECStructure(typeSymbol, scope);
    return;
  }
  PutAttrs(decls_ << "type", typeSymbol.attrs());
  if (const DerivedTypeSpec * extends{typeSymbol.GetParentTypeSpec()}) {
    decls_ << ",extends(" << extends->name() << ')';
  }
  decls_ << "::" << typeSymbol.name();
  if (!details.paramNameOrder().empty()) {
    char sep{'('};
    for (const SymbolRef &ref : details.paramNameOrder()) {
      decls_ << sep << ref->name();
      sep = ',';
    }
    decls_ << ')';
  }
  decls_ << '\n';
  if (details.sequence()) {
    decls_ << "sequence\n";
  }
  bool contains{PutComponents(typeSymbol)};
  if (!details.finals().empty()) {
    const char *sep{contains ? "final::" : "contains\nfinal::"};
    for (const auto &pair : details.finals()) {
      decls_ << sep << pair.second->name();
      sep = ",";
    }
    if (*sep == ',') {
      decls_ << '\n';
    }
  }
  decls_ << "end type\n";
}

void ModFileWriter::PutDECStructure(
    const Symbol &typeSymbol, const Scope *scope) {
  if (emittedDECStructures_.find(typeSymbol) != emittedDECStructures_.end()) {
    return;
  }
  if (!scope && context_.IsTempName(typeSymbol.name().ToString())) {
    return; // defer until used
  }
  emittedDECStructures_.insert(typeSymbol);
  decls_ << "structure ";
  if (!context_.IsTempName(typeSymbol.name().ToString())) {
    decls_ << typeSymbol.name();
  }
  if (scope && scope->kind() == Scope::Kind::DerivedType) {
    // Nested STRUCTURE: emit entity declarations right now
    // on the STRUCTURE statement.
    bool any{false};
    for (const auto &ref : scope->GetSymbols()) {
      const auto *object{ref->detailsIf<ObjectEntityDetails>()};
      if (object && object->type() &&
          object->type()->category() == DeclTypeSpec::TypeDerived &&
          &object->type()->derivedTypeSpec().typeSymbol() == &typeSymbol) {
        if (any) {
          decls_ << ',';
        } else {
          any = true;
        }
        decls_ << ref->name();
        PutShape(decls_, object->shape(), '(', ')');
        PutInit(decls_, *ref, object->init(), nullptr, context_);
        emittedDECFields_.insert(*ref);
      } else if (any) {
        break; // any later use of this structure will use RECORD/str/
      }
    }
  }
  decls_ << '\n';
  PutComponents(typeSymbol);
  decls_ << "end structure\n";
}

// Attributes that may be in a subprogram prefix
static const Attrs subprogramPrefixAttrs{Attr::ELEMENTAL, Attr::IMPURE,
    Attr::MODULE, Attr::NON_RECURSIVE, Attr::PURE, Attr::RECURSIVE};

static void PutOpenACCDeviceTypeRoutineInfo(
    llvm::raw_ostream &os, const OpenACCRoutineDeviceTypeInfo &info) {
  if (info.isSeq()) {
    os << " seq";
  }
  if (info.isGang()) {
    os << " gang";
    if (info.gangDim() > 0) {
      os << "(dim: " << info.gangDim() << ")";
    }
  }
  if (info.isVector()) {
    os << " vector";
  }
  if (info.isWorker()) {
    os << " worker";
  }
  if (const std::variant<std::string, SymbolRef> *bindName{info.bindName()}) {
    os << " bind(";
    if (std::holds_alternative<std::string>(*bindName)) {
      os << "\"" << std::get<std::string>(*bindName) << "\"";
    } else {
      os << std::get<SymbolRef>(*bindName)->name();
    }
    os << ")";
  }
}

static void PutOpenACCRoutineInfo(
    llvm::raw_ostream &os, const SubprogramDetails &details) {
  for (auto info : details.openACCRoutineInfos()) {
    os << "!$acc routine";

    PutOpenACCDeviceTypeRoutineInfo(os, info);

    if (info.isNohost()) {
      os << " nohost";
    }

    for (auto dtype : info.deviceTypeInfos()) {
      os << " device_type(";
      if (dtype.dType() == common::OpenACCDeviceType::Star) {
        os << "*";
      } else {
        os << parser::ToLowerCaseLetters(common::EnumToString(dtype.dType()));
      }
      os << ")";

      PutOpenACCDeviceTypeRoutineInfo(os, dtype);
    }

    os << "\n";
  }
}

void ModFileWriter::PutSubprogram(const Symbol &symbol) {
  auto &details{symbol.get<SubprogramDetails>()};
  if (const Symbol * interface{details.moduleInterface()}) {
    const Scope *module{FindModuleContaining(interface->owner())};
    if (module && module != &symbol.owner()) {
      // Interface is in ancestor module
    } else {
      PutSubprogram(*interface);
    }
  }
  auto attrs{symbol.attrs()};
  Attrs bindAttrs{};
  if (attrs.test(Attr::BIND_C)) {
    // bind(c) is a suffix, not prefix
    bindAttrs.set(Attr::BIND_C, true);
    attrs.set(Attr::BIND_C, false);
  }
  bool isAbstract{attrs.test(Attr::ABSTRACT)};
  if (isAbstract) {
    attrs.set(Attr::ABSTRACT, false);
  }
  Attrs prefixAttrs{subprogramPrefixAttrs & attrs};
  // emit any non-prefix attributes in an attribute statement
  attrs &= ~subprogramPrefixAttrs;
  std::string ssBuf;
  llvm::raw_string_ostream ss{ssBuf};
  PutAttrs(ss, attrs);
  if (!ss.str().empty()) {
    decls_ << ss.str().substr(1) << "::" << symbol.name() << '\n';
  }
  bool isInterface{details.isInterface()};
  llvm::raw_ostream &os{isInterface ? decls_ : contains_};
  if (isInterface) {
    os << (isAbstract ? "abstract " : "") << "interface\n";
  }
  PutAttrs(os, prefixAttrs, nullptr, false, ""s, " "s);
  if (auto attrs{details.cudaSubprogramAttrs()}) {
    if (*attrs == common::CUDASubprogramAttrs::HostDevice) {
      os << "attributes(host,device) ";
    } else {
      PutLower(os << "attributes(", common::EnumToString(*attrs)) << ") ";
    }
    if (!details.cudaLaunchBounds().empty()) {
      os << "launch_bounds";
      char sep{'('};
      for (auto x : details.cudaLaunchBounds()) {
        os << sep << x;
        sep = ',';
      }
      os << ") ";
    }
    if (!details.cudaClusterDims().empty()) {
      os << "cluster_dims";
      char sep{'('};
      for (auto x : details.cudaClusterDims()) {
        os << sep << x;
        sep = ',';
      }
      os << ") ";
    }
  }
  os << (details.isFunction() ? "function " : "subroutine ");
  os << symbol.name() << '(';
  int n = 0;
  for (const auto &dummy : details.dummyArgs()) {
    if (n++ > 0) {
      os << ',';
    }
    if (dummy) {
      os << dummy->name();
    } else {
      os << "*";
    }
  }
  os << ')';
  PutAttrs(os, bindAttrs, details.bindName(), details.isExplicitBindName(),
      " "s, ""s);
  if (details.isFunction()) {
    const Symbol &result{details.result()};
    if (result.name() != symbol.name()) {
      os << " result(" << result.name() << ')';
    }
  }
  os << '\n';
  // walk symbols, collect ones needed for interface
  const Scope &scope{
      details.entryScope() ? *details.entryScope() : DEREF(symbol.scope())};
  SubprogramSymbolCollector collector{symbol, scope};
  collector.Collect();
  std::string typeBindingsBuf;
  llvm::raw_string_ostream typeBindings{typeBindingsBuf};
  ModFileWriter writer{context_};
  for (const Symbol &need : collector.symbols()) {
    writer.PutSymbol(typeBindings, need);
  }
  CHECK(typeBindings.str().empty());
  os << writer.uses_.str();
  for (const SourceName &import : collector.imports()) {
    decls_ << "import::" << import << "\n";
  }
  os << writer.decls_.str();
  PutOpenACCRoutineInfo(os, details);
  os << "end\n";
  if (isInterface) {
    os << "end interface\n";
  }
}

static bool IsIntrinsicOp(const Symbol &symbol) {
  if (const auto *details{symbol.GetUltimate().detailsIf<GenericDetails>()}) {
    return details->kind().IsIntrinsicOperator();
  } else {
    return false;
  }
}

void ModFileWriter::PutGeneric(const Symbol &symbol) {
  const auto &genericOwner{symbol.owner()};
  auto &details{symbol.get<GenericDetails>()};
  PutGenericName(decls_ << "interface ", symbol) << '\n';
  for (const Symbol &specific : details.specificProcs()) {
    if (specific.owner() == genericOwner) {
      decls_ << "procedure::" << specific.name() << '\n';
    }
  }
  decls_ << "end interface\n";
  if (!isSubmodule_ && symbol.attrs().test(Attr::PRIVATE)) {
    PutGenericName(decls_ << "private::", symbol) << '\n';
  }
}

void ModFileWriter::PutUse(const Symbol &symbol) {
  auto &details{symbol.get<UseDetails>()};
  auto &use{details.symbol()};
  const Symbol &module{GetUsedModule(details)};
  if (use.owner().parent().IsIntrinsicModules()) {
    uses_ << "use,intrinsic::";
  } else {
    uses_ << "use ";
    usedNonIntrinsicModules_.insert(module);
  }
  uses_ << module.name() << ",only:";
  PutGenericName(uses_, symbol);
  // Can have intrinsic op with different local-name and use-name
  // (e.g. `operator(<)` and `operator(.lt.)`) but rename is not allowed
  if (!IsIntrinsicOp(symbol) && use.name() != symbol.name()) {
    PutGenericName(uses_ << "=>", use);
  }
  uses_ << '\n';
  PutUseExtraAttr(Attr::VOLATILE, symbol, use);
  PutUseExtraAttr(Attr::ASYNCHRONOUS, symbol, use);
  if (!isSubmodule_ && symbol.attrs().test(Attr::PRIVATE)) {
    PutGenericName(useExtraAttrs_ << "private::", symbol) << '\n';
  }
}

// We have "USE local => use" in this module. If attr was added locally
// (i.e. on local but not on use), also write it out in the mod file.
void ModFileWriter::PutUseExtraAttr(
    Attr attr, const Symbol &local, const Symbol &use) {
  if (local.attrs().test(attr) && !use.attrs().test(attr)) {
    PutAttr(useExtraAttrs_, attr) << "::";
    useExtraAttrs_ << local.name() << '\n';
  }
}

static void CollectModules(const Scope &scope, const SymbolVector &symbols,
    SourceOrderedSymbolSet &modules) {
  for (const Symbol &symbol : symbols) {
    const auto *generic{symbol.detailsIf<GenericDetails>()};
    if (generic) {
      for (const Symbol &used : generic->uses()) {
        modules.insert(GetUsedModule(used.get<UseDetails>()));
      }
    } else if (const auto *use{symbol.detailsIf<UseDetails>()}) {
      modules.insert(GetUsedModule(*use));
    }
  }
  for (const Scope &child : scope.children()) {
    if (!child.IsSubmodule()) {
      CollectModules(child, child.GetSymbols(), modules);
    }
  }
}

// Collect the symbols of this scope sorted by their original order, not name.
// Generics and namelists are exceptions: they are sorted after other symbols.
void CollectSymbols(const Scope &scope, SymbolVector &sorted,
    SymbolVector &uses, SourceOrderedSymbolSet &modules) {
  SymbolVector namelist, generics;
  auto symbols{scope.GetSymbols()};
  std::size_t commonSize{scope.commonBlocks().size()};
  sorted.reserve(symbols.size() + commonSize);
  CollectModules(scope, symbols, modules);
  for (const Symbol &symbol : symbols) {
    if (symbol.test(Symbol::Flag::ParentComp)) {
    } else if (symbol.has<NamelistDetails>()) {
      namelist.push_back(symbol);
    } else if (const auto *generic{symbol.detailsIf<GenericDetails>()}) {
      uses.insert(uses.end(), generic->uses().begin(), generic->uses().end());
      if (generic->specific() &&
          &generic->specific()->owner() == &symbol.owner()) {
        sorted.push_back(*generic->specific());
      } else if (generic->derivedType() &&
          &generic->derivedType()->owner() == &symbol.owner()) {
        sorted.push_back(*generic->derivedType());
      }
      generics.push_back(symbol);
    } else {
      sorted.push_back(symbol);
    }
  }
  std::sort(sorted.begin(), sorted.end(), SymbolSourcePositionCompare{});
  std::sort(generics.begin(), generics.end(), SymbolSourcePositionCompare{});
  sorted.insert(sorted.end(), generics.begin(), generics.end());
  sorted.insert(sorted.end(), namelist.begin(), namelist.end());
  for (const auto &pair : scope.commonBlocks()) {
    sorted.push_back(*pair.second);
  }
  std::sort(
      sorted.end() - commonSize, sorted.end(), SymbolSourcePositionCompare{});
}

void ModFileWriter::PutEntity(llvm::raw_ostream &os, const Symbol &symbol) {
  common::visit(
      common::visitors{
          [&](const ObjectEntityDetails &) { PutObjectEntity(os, symbol); },
          [&](const ProcEntityDetails &) { PutProcEntity(os, symbol); },
          [&](const TypeParamDetails &) { PutTypeParam(os, symbol); },
          [&](const UserReductionDetails &) { PutUserReduction(os, symbol); },
          [&](const MapperDetails &) { PutMapper(decls_, symbol, context_); },
          [&](const auto &) {
            common::die("PutEntity: unexpected details: %s",
                DetailsToString(symbol.details()).c_str());
          },
      },
      symbol.details());
}

void PutShapeSpec(llvm::raw_ostream &os, const ShapeSpec &x) {
  if (x.lbound().isStar()) {
    CHECK(x.ubound().isStar());
    os << ".."; // assumed rank
  } else {
    if (!x.lbound().isColon()) {
      PutBound(os, x.lbound());
    }
    os << ':';
    if (!x.ubound().isColon()) {
      PutBound(os, x.ubound());
    }
  }
}
void PutShape(
    llvm::raw_ostream &os, const ArraySpec &shape, char open, char close) {
  if (!shape.empty()) {
    os << open;
    bool first{true};
    for (const auto &shapeSpec : shape) {
      if (first) {
        first = false;
      } else {
        os << ',';
      }
      PutShapeSpec(os, shapeSpec);
    }
    os << close;
  }
}

void ModFileWriter::PutObjectEntity(
    llvm::raw_ostream &os, const Symbol &symbol) {
  auto &details{symbol.get<ObjectEntityDetails>()};
  if (details.type() &&
      details.type()->category() == DeclTypeSpec::TypeDerived) {
    const Symbol &typeSymbol{details.type()->derivedTypeSpec().typeSymbol()};
    if (typeSymbol.get<DerivedTypeDetails>().isDECStructure()) {
      PutDerivedType(typeSymbol, &symbol.owner());
      if (emittedDECFields_.find(symbol) != emittedDECFields_.end()) {
        return; // symbol was emitted on STRUCTURE statement
      }
    }
  }
  PutEntity(
      os, symbol, [&]() { PutType(os, DEREF(symbol.GetType())); },
      getSymbolAttrsToWrite(symbol));
  PutShape(os, details.shape(), '(', ')');
  PutShape(os, details.coshape(), '[', ']');
  PutInit(os, symbol, details.init(), details.unanalyzedPDTComponentInit(),
      context_);
  os << '\n';
  if (auto tkr{GetIgnoreTKR(symbol)}; !tkr.empty()) {
    os << "!dir$ ignore_tkr(";
    tkr.IterateOverMembers([&](common::IgnoreTKR tkr) {
      switch (tkr) {
        SWITCH_COVERS_ALL_CASES
      case common::IgnoreTKR::Type:
        os << 't';
        break;
      case common::IgnoreTKR::Kind:
        os << 'k';
        break;
      case common::IgnoreTKR::Rank:
        os << 'r';
        break;
      case common::IgnoreTKR::Device:
        os << 'd';
        break;
      case common::IgnoreTKR::Managed:
        os << 'm';
        break;
      case common::IgnoreTKR::Contiguous:
        os << 'c';
        break;
      case common::IgnoreTKR::Pointer:
        os << 'p';
        break;
      }
    });
    os << ") " << symbol.name() << '\n';
  }
  if (symbol.test(Fortran::semantics::Symbol::Flag::CrayPointer)) {
    for (const auto &[pointee, pointer] : symbol.owner().crayPointers()) {
      if (pointer == symbol) {
        os << "pointer(" << symbol.name() << "," << pointee << ")\n";
      }
    }
  }
}

void ModFileWriter::PutProcEntity(llvm::raw_ostream &os, const Symbol &symbol) {
  if (symbol.attrs().test(Attr::INTRINSIC)) {
    os << "intrinsic::" << symbol.name() << '\n';
    if (!isSubmodule_ && symbol.attrs().test(Attr::PRIVATE)) {
      os << "private::" << symbol.name() << '\n';
    }
    return;
  }
  const auto &details{symbol.get<ProcEntityDetails>()};
  Attrs attrs{symbol.attrs()};
  if (details.passName()) {
    attrs.reset(Attr::PASS);
  }
  PutEntity(
      os, symbol,
      [&]() {
        os << "procedure(";
        if (details.rawProcInterface()) {
          os << details.rawProcInterface()->name();
        } else if (details.type()) {
          PutType(os, *details.type());
        }
        os << ')';
        PutPassName(os, details.passName());
      },
      attrs);
  if (symbol.owner().IsDerivedType()) {
    if (const auto &init{details.init()}) {
      if (const Symbol *symbol{*init}) {
        os << "=>" << symbol->name();
      } else {
        os << "=>NULL()";
      }
    }
  }
  os << '\n';
}

void PutPassName(
    llvm::raw_ostream &os, const std::optional<SourceName> &passName) {
  if (passName) {
    os << ",pass(" << *passName << ')';
  }
}

void ModFileWriter::PutTypeParam(llvm::raw_ostream &os, const Symbol &symbol) {
  auto &details{symbol.get<TypeParamDetails>()};
  PutEntity(
      os, symbol,
      [&]() {
        PutType(os, DEREF(symbol.GetType()));
        PutLower(os << ',', common::EnumToString(details.attr().value()));
      },
      symbol.attrs());
  PutInit(os, details.init());
  os << '\n';
}

void ModFileWriter::PutUserReduction(
    llvm::raw_ostream &os, const Symbol &symbol) {
  const auto &details{symbol.get<UserReductionDetails>()};
  // The module content for a OpenMP Declare Reduction is the OpenMP
  // declaration. There may be multiple declarations.
  // Decls are pointers, so do not use a reference.
  for (const auto *decl : details.GetDeclList()) {
    Unparse(os, *decl, context_.langOptions());
  }
}

static void PutMapper(
    llvm::raw_ostream &os, const Symbol &symbol, SemanticsContext &context) {
  const auto &details{symbol.get<MapperDetails>()};
  // Emit each saved DECLARE MAPPER construct as-is, so that consumers of the
  // module can reparse it and recreate the mapper symbol and semantics state.
  for (const auto *decl : details.GetDeclList()) {
    Unparse(os, *decl, context.langOptions());
  }
}

void PutInit(llvm::raw_ostream &os, const Symbol &symbol, const MaybeExpr &init,
    const parser::Expr *unanalyzed, SemanticsContext &context) {
  if (IsNamedConstant(symbol) || symbol.owner().IsDerivedType()) {
    const char *assign{symbol.attrs().test(Attr::POINTER) ? "=>" : "="};
    if (unanalyzed) {
      parser::Unparse(os << assign, *unanalyzed, context.langOptions());
    } else if (init) {
      init->AsFortran(os << assign);
    }
  }
}

void PutInit(llvm::raw_ostream &os, const MaybeIntExpr &init) {
  if (init) {
    init->AsFortran(os << '=');
  }
}

void PutBound(llvm::raw_ostream &os, const Bound &x) {
  if (x.isStar()) {
    os << '*';
  } else if (x.isColon()) {
    os << ':';
  } else {
    x.GetExplicit()->AsFortran(os);
  }
}

// Write an entity (object or procedure) declaration.
// writeType is called to write out the type.
void ModFileWriter::PutEntity(llvm::raw_ostream &os, const Symbol &symbol,
    std::function<void()> writeType, Attrs attrs) {
  writeType();
  PutAttrs(os, attrs, symbol.GetBindName(), symbol.GetIsExplicitBindName());
  if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
    if (auto attr{details->cudaDataAttr()}) {
      PutLower(os << ',', common::EnumToString(*attr));
    }
  }
  if (symbol.owner().kind() == Scope::Kind::DerivedType &&
      context_.IsTempName(symbol.name().ToString())) {
    os << "::%FILL";
  } else {
    os << "::" << symbol.name();
  }
}

// Put out each attribute to os, surrounded by `before` and `after` and
// mapped to lower case.
llvm::raw_ostream &ModFileWriter::PutAttrs(llvm::raw_ostream &os, Attrs attrs,
    const std::string *bindName, bool isExplicitBindName, std::string before,
    std::string after) const {
  attrs.set(Attr::PUBLIC, false); // no need to write PUBLIC
  attrs.set(Attr::EXTERNAL, false); // no need to write EXTERNAL
  if (isSubmodule_) {
    attrs.set(Attr::PRIVATE, false);
  }
  if (bindName || isExplicitBindName) {
    os << before << "bind(c";
    if (isExplicitBindName) {
      os << ",name=\"" << (bindName ? *bindName : ""s) << '"';
    }
    os << ')' << after;
    attrs.set(Attr::BIND_C, false);
  }
  for (std::size_t i{0}; i < Attr_enumSize; ++i) {
    Attr attr{static_cast<Attr>(i)};
    if (attrs.test(attr)) {
      PutAttr(os << before, attr) << after;
    }
  }
  return os;
}

llvm::raw_ostream &PutAttr(llvm::raw_ostream &os, Attr attr) {
  return PutLower(os, AttrToString(attr));
}

llvm::raw_ostream &PutType(llvm::raw_ostream &os, const DeclTypeSpec &type) {
  return PutLower(os, type.AsFortran());
}

llvm::raw_ostream &PutLower(llvm::raw_ostream &os, std::string_view str) {
  for (char c : str) {
    os << parser::ToLowerCaseLetter(c);
  }
  return os;
}

void PutOpenACCDirective(llvm::raw_ostream &os, const Symbol &symbol) {
  if (symbol.test(Symbol::Flag::AccDeclare)) {
    os << "!$acc declare ";
    if (symbol.test(Symbol::Flag::AccCopy)) {
      os << "copy";
    } else if (symbol.test(Symbol::Flag::AccCopyIn) ||
        symbol.test(Symbol::Flag::AccCopyInReadOnly)) {
      os << "copyin";
    } else if (symbol.test(Symbol::Flag::AccCopyOut)) {
      os << "copyout";
    } else if (symbol.test(Symbol::Flag::AccCreate)) {
      os << "create";
    } else if (symbol.test(Symbol::Flag::AccPresent)) {
      os << "present";
    } else if (symbol.test(Symbol::Flag::AccDevicePtr)) {
      os << "deviceptr";
    } else if (symbol.test(Symbol::Flag::AccDeviceResident)) {
      os << "device_resident";
    } else if (symbol.test(Symbol::Flag::AccLink)) {
      os << "link";
    }
    os << "(";
    if (symbol.test(Symbol::Flag::AccCopyInReadOnly)) {
      os << "readonly: ";
    }
    os << symbol.name() << ")\n";
  }
}

void PutOpenMPDirective(llvm::raw_ostream &os, const Symbol &symbol) {
  if (symbol.test(Symbol::Flag::OmpThreadprivate)) {
    os << "!$omp threadprivate(" << symbol.name() << ")\n";
  }
}

void ModFileWriter::PutDirective(llvm::raw_ostream &os, const Symbol &symbol) {
  PutOpenACCDirective(os, symbol);
  PutOpenMPDirective(os, symbol);
}

struct Temp {
  Temp(int fd, std::string path) : fd{fd}, path{path} {}
  Temp(Temp &&t) : fd{std::exchange(t.fd, -1)}, path{std::move(t.path)} {}
  ~Temp() {
    if (fd >= 0) {
      llvm::sys::fs::file_t native{llvm::sys::fs::convertFDToNativeFile(fd)};
      llvm::sys::fs::closeFile(native);
      llvm::sys::fs::remove(path.c_str());
    }
  }
  int fd;
  std::string path;
};

// Create a temp file in the same directory and with the same suffix as path.
// Return an open file descriptor and its path.
static llvm::ErrorOr<Temp> MkTemp(const std::string &path) {
  auto length{path.length()};
  auto dot{path.find_last_of("./")};
  std::string suffix{
      dot < length && path[dot] == '.' ? path.substr(dot + 1) : ""};
  CHECK(length > suffix.length() &&
      path.substr(length - suffix.length()) == suffix);
  auto prefix{path.substr(0, length - suffix.length())};
  int fd;
  llvm::SmallString<16> tempPath;
  if (std::error_code err{llvm::sys::fs::createUniqueFile(
          prefix + "%%%%%%" + suffix, fd, tempPath)}) {
    return err;
  }
  return Temp{fd, tempPath.c_str()};
}

// Write the module file at path, prepending header. If an error occurs,
// return errno, otherwise 0.
static std::error_code WriteFile(const std::string &path,
    const std::string &contents, ModuleCheckSumType &checkSum, bool debug) {
  checkSum = ComputeCheckSum(contents);
  auto header{std::string{ModHeader::bom} + ModHeader::magic +
      CheckSumString(checkSum) + ModHeader::terminator};
  if (debug) {
    llvm::dbgs() << "Processing module " << path << ": ";
  }
  if (FileContentsMatch(path, header, contents)) {
    if (debug) {
      llvm::dbgs() << "module unchanged, not writing\n";
    }
    return {};
  }
  llvm::ErrorOr<Temp> temp{MkTemp(path)};
  if (!temp) {
    return temp.getError();
  }
  llvm::raw_fd_ostream writer(temp->fd, /*shouldClose=*/false);
  writer << header;
  writer << contents;
  writer.flush();
  if (writer.has_error()) {
    return writer.error();
  }
  if (debug) {
    llvm::dbgs() << "module written\n";
  }
  return llvm::sys::fs::rename(temp->path, path);
}

// Return true if the stream matches what we would write for the mod file.
static bool FileContentsMatch(const std::string &path,
    const std::string &header, const std::string &contents) {
  std::size_t hsize{header.size()};
  std::size_t csize{contents.size()};
  auto buf_or{llvm::MemoryBuffer::getFile(path)};
  if (!buf_or) {
    return false;
  }
  auto buf = std::move(buf_or.get());
  if (buf->getBufferSize() != hsize + csize) {
    return false;
  }
  if (!std::equal(header.begin(), header.end(), buf->getBufferStart(),
          buf->getBufferStart() + hsize)) {
    return false;
  }

  return std::equal(contents.begin(), contents.end(),
      buf->getBufferStart() + hsize, buf->getBufferEnd());
}

// Compute a simple hash of the contents of a module file and
// return it as a string of hex digits.
// This uses the Fowler-Noll-Vo hash function.
static ModuleCheckSumType ComputeCheckSum(const std::string_view &contents) {
  ModuleCheckSumType hash{0xcbf29ce484222325ull};
  for (char c : contents) {
    hash ^= c & 0xff;
    hash *= 0x100000001b3;
  }
  return hash;
}

static std::string CheckSumString(ModuleCheckSumType hash) {
  static const char *digits = "0123456789abcdef";
  std::string result(ModHeader::sumLen, '0');
  for (size_t i{ModHeader::sumLen}; hash != 0; hash >>= 4) {
    result[--i] = digits[hash & 0xf];
  }
  return result;
}

std::optional<ModuleCheckSumType> ExtractCheckSum(const std::string_view &str) {
  if (str.size() == ModHeader::sumLen) {
    ModuleCheckSumType hash{0};
    for (size_t j{0}; j < ModHeader::sumLen; ++j) {
      hash <<= 4;
      char ch{str.at(j)};
      if (ch >= '0' && ch <= '9') {
        hash += ch - '0';
      } else if (ch >= 'a' && ch <= 'f') {
        hash += ch - 'a' + 10;
      } else {
        return std::nullopt;
      }
    }
    return hash;
  }
  return std::nullopt;
}

static bool VerifyMagic(llvm::ArrayRef<char> content) {
  std::string_view sv{content.data(), content.size()};
  return sv.substr(0, ModHeader::magicLen) == ModHeader::magic;
}

static std::optional<ModuleCheckSumType> VerifyHeader(
    llvm::ArrayRef<char> content) {
  if (!VerifyMagic(content)) {
    return std::nullopt;
  }
  std::string_view sv{content.data(), content.size()};
  ModuleCheckSumType checkSum{ComputeCheckSum(sv.substr(ModHeader::len))};
  std::string_view expectSum{sv.substr(ModHeader::magicLen, ModHeader::sumLen)};
  if (auto extracted{ExtractCheckSum(expectSum)};
      extracted && *extracted == checkSum) {
    return checkSum;
  } else {
    return std::nullopt;
  }
}

static void GetModuleDependences(
    ModuleDependences &dependences, llvm::ArrayRef<char> content) {
  std::size_t limit{content.size()};
  std::string_view str{content.data(), limit};
  for (std::size_t j{ModHeader::len};
       str.substr(j, ModHeader::needLen) == ModHeader::need; ++j) {
    j += 7;
    auto checkSum{ExtractCheckSum(str.substr(j, ModHeader::sumLen))};
    if (!checkSum) {
      break;
    }
    j += ModHeader::sumLen;
    bool intrinsic{false};
    if (str.substr(j, 3) == " i ") {
      intrinsic = true;
    } else if (str.substr(j, 3) != " n ") {
      break;
    }
    j += 3;
    std::size_t start{j};
    for (; j < limit && str.at(j) != '\n'; ++j) {
    }
    if (j > start && j < limit && str.at(j) == '\n') {
      std::string depModName{str.substr(start, j - start)};
      dependences.AddDependence(std::move(depModName), intrinsic, *checkSum);
    } else {
      break;
    }
  }
}

Scope *ModFileReader::Read(SourceName name, std::optional<bool> isIntrinsic,
    Scope *ancestor, bool silent) {
  std::string ancestorName; // empty for module
  const Symbol *notAModule{nullptr};
  bool fatalError{false};
  if (ancestor) {
    if (auto *scope{ancestor->FindSubmodule(name)}) {
      return scope;
    }
    ancestorName = ancestor->GetName().value().ToString();
  }
  auto requiredHash{context_.moduleDependences().GetRequiredHash(
      name.ToString(), isIntrinsic.value_or(false))};
  if (!isIntrinsic.value_or(false) && !ancestor) {
    // Already present in the symbol table as a usable non-intrinsic module?
    if (Scope * hermeticScope{context_.currentHermeticModuleFileScope()}) {
      auto it{hermeticScope->find(name)};
      if (it != hermeticScope->end()) {
        return it->second->scope();
      }
    }
    auto it{context_.globalScope().find(name)};
    if (it != context_.globalScope().end()) {
      Scope *scope{it->second->scope()};
      if (scope->kind() == Scope::Kind::Module) {
        for (const Symbol *found{scope->symbol()}; found;) {
          if (const auto *module{found->detailsIf<ModuleDetails>()}) {
            if (!requiredHash ||
                *requiredHash ==
                    module->moduleFileHash().value_or(*requiredHash)) {
              return const_cast<Scope *>(found->scope());
            }
            found = module->previous(); // same name, distinct hash
          } else {
            notAModule = found;
            break;
          }
        }
      } else {
        notAModule = scope->symbol();
      }
    }
  }
  if (notAModule) {
    // USE, NON_INTRINSIC global name isn't a module?
    fatalError = isIntrinsic.has_value();
  }
  std::string path{
      ModFileName(name, ancestorName, context_.moduleFileSuffix())};
  parser::Parsing parsing{context_.allCookedSources()};
  parser::Options options;
  options.isModuleFile = true;
  options.features.Enable(common::LanguageFeature::BackslashEscapes);
  if (context_.languageFeatures().IsEnabled(common::LanguageFeature::OpenACC)) {
    options.features.Enable(common::LanguageFeature::OpenACC);
  }
  options.features.Enable(common::LanguageFeature::OpenMP);
  options.features.Enable(common::LanguageFeature::CUDA);
  if (!isIntrinsic.value_or(false) && !notAModule) {
    // The search for this module file will scan non-intrinsic module
    // directories.  If a directory is in both the intrinsic and non-intrinsic
    // directory lists, the intrinsic module directory takes precedence.
    options.searchDirectories = context_.searchDirectories();
    for (const auto &dir : context_.intrinsicModuleDirectories()) {
      options.searchDirectories.erase(
          std::remove(options.searchDirectories.begin(),
              options.searchDirectories.end(), dir),
          options.searchDirectories.end());
    }
    options.searchDirectories.insert(options.searchDirectories.begin(), "."s);
  }
  bool foundNonIntrinsicModuleFile{false};
  if (!isIntrinsic) {
    std::list<std::string> searchDirs;
    for (const auto &d : options.searchDirectories) {
      searchDirs.push_back(d);
    }
    foundNonIntrinsicModuleFile =
        parser::LocateSourceFile(path, searchDirs).has_value();
  }
  if (isIntrinsic.value_or(!foundNonIntrinsicModuleFile)) {
    // Explicitly intrinsic, or not specified and not found in the search
    // path; see whether it's already in the symbol table as an intrinsic
    // module.
    auto it{context_.intrinsicModulesScope().find(name)};
    if (it != context_.intrinsicModulesScope().end()) {
      return it->second->scope();
    }
  }
  // We don't have this module in the symbol table yet.
  // Find its module file and parse it.  Define or extend the search
  // path with intrinsic module directories, if appropriate.
  if (isIntrinsic.value_or(true)) {
    for (const auto &dir : context_.intrinsicModuleDirectories()) {
      options.searchDirectories.push_back(dir);
    }
    if (!requiredHash) {
      requiredHash =
          context_.moduleDependences().GetRequiredHash(name.ToString(), true);
    }
  }
  // Look for the right module file if its hash is known
  if (requiredHash && !fatalError) {
    for (const std::string &maybe :
        parser::LocateSourceFileAll(path, options.searchDirectories)) {
      if (const auto *srcFile{context_.allCookedSources().allSources().OpenPath(
              maybe, llvm::errs())}) {
        if (auto checkSum{VerifyHeader(srcFile->content())};
            checkSum && *checkSum == *requiredHash) {
          path = maybe;
          break;
        }
      }
    }
  }
  const auto *sourceFile{fatalError ? nullptr : parsing.Prescan(path, options)};
  if (fatalError || parsing.messages().AnyFatalError()) {
    if (!silent) {
      if (notAModule) {
        // Module is not explicitly INTRINSIC, and there's already a global
        // symbol of the same name that is not a module.
        context_.SayWithDecl(
            *notAModule, name, "'%s' is not a module"_err_en_US, name);
      } else if (sourceFile && !VerifyMagic(sourceFile->content())) {
        Say("read", name, ancestorName,
            "'%s' is not a module file for this compiler"_err_en_US, path);
      } else {
        for (auto &msg : parsing.messages().messages()) {
          std::string str{msg.ToString()};
          Say("parse", name, ancestorName,
              parser::MessageFixedText{str.c_str(), str.size(), msg.severity()},
              path);
        }
      }
    }
    return nullptr;
  }
  CHECK(sourceFile);
  std::optional<ModuleCheckSumType> checkSum{
      VerifyHeader(sourceFile->content())};
  if (!checkSum) {
    if (!silent) {
      if (!VerifyMagic(sourceFile->content())) {
        Say("read", name, ancestorName,
            "'%s' is not a module file for this compiler"_err_en_US, path);
      } else {
        Say("use", name, ancestorName,
            "File has invalid checksum: %s"_err_en_US, sourceFile->path());
      }
    }
    return nullptr;
  } else if (requiredHash && *requiredHash != *checkSum) {
    if (!silent) {
      Say("use", name, ancestorName,
          "File is not the right module file for %s"_err_en_US,
          "'"s + name.ToString() + "': "s + sourceFile->path());
    }
    return nullptr;
  }
  llvm::raw_null_ostream NullStream;
  parsing.Parse(NullStream);
  std::optional<parser::Program> &parsedProgram{parsing.parseTree()};
  if (!parsing.messages().empty() || !parsing.consumedWholeFile() ||
      !parsedProgram) {
    if (!silent) {
      Say("parse", name, ancestorName, "Module file is corrupt: %s"_err_en_US,
          sourceFile->path());
    }
    return nullptr;
  }
  parser::Program &parseTree{context_.SaveParseTree(std::move(*parsedProgram))};
  Scope *parentScope; // the scope this module/submodule goes into
  if (!isIntrinsic.has_value()) {
    for (const auto &dir : context_.intrinsicModuleDirectories()) {
      if (sourceFile->path().size() > dir.size() &&
          sourceFile->path().find(dir) == 0) {
        isIntrinsic = true;
        break;
      }
    }
  }
  Scope &topScope{isIntrinsic.value_or(false) ? context_.intrinsicModulesScope()
                                              : context_.globalScope()};
  Symbol *moduleSymbol{nullptr};
  const Symbol *previousModuleSymbol{nullptr};
  if (!ancestor) { // module, not submodule
    parentScope = &topScope;
    auto pair{parentScope->try_emplace(name, UnknownDetails{})};
    if (!pair.second) {
      // There is already a global symbol or intrinsic module of the same name.
      previousModuleSymbol = &*pair.first->second;
      if (const auto *details{
              previousModuleSymbol->detailsIf<ModuleDetails>()}) {
        if (!details->moduleFileHash().has_value()) {
          return nullptr;
        }
      } else {
        return nullptr;
      }
      CHECK(parentScope->erase(name) != 0);
      pair = parentScope->try_emplace(name, UnknownDetails{});
      CHECK(pair.second);
    }
    moduleSymbol = &*pair.first->second;
    moduleSymbol->set(Symbol::Flag::ModFile);
  } else if (std::optional<SourceName> parent{GetSubmoduleParent(parseTree)}) {
    // submodule with submodule parent
    parentScope = Read(*parent, false /*not intrinsic*/, ancestor, silent);
  } else {
    // submodule with module parent
    parentScope = ancestor;
  }
  // Process declarations from the module file
  auto wasModuleFileName{context_.foldingContext().moduleFileName()};
  context_.foldingContext().set_moduleFileName(name);
  // Are there multiple modules in the module file due to it having been
  // created under -fhermetic-module-files?  If so, process them first in
  // their own nested scope that will be visible only to USE statements
  // within the module file.
  Scope *previousHermetic{context_.currentHermeticModuleFileScope()};
  if (parseTree.v.size() > 1) {
    parser::Program hermeticModules{std::move(parseTree.v)};
    parseTree.v.emplace_back(std::move(hermeticModules.v.front()));
    hermeticModules.v.pop_front();
    Scope &hermeticScope{topScope.MakeScope(Scope::Kind::Global)};
    context_.set_currentHermeticModuleFileScope(&hermeticScope);
    ResolveNames(context_, hermeticModules, hermeticScope);
    for (auto &[_, ref] : hermeticScope) {
      CHECK(ref->has<ModuleDetails>());
      ref->set(Symbol::Flag::ModFile);
    }
  }
  GetModuleDependences(context_.moduleDependences(), sourceFile->content());
  ResolveNames(context_, parseTree, topScope);
  context_.foldingContext().set_moduleFileName(wasModuleFileName);
  context_.set_currentHermeticModuleFileScope(previousHermetic);
  if (!moduleSymbol) {
    // Submodule symbols' storage are owned by their parents' scopes,
    // but their names are not in their parents' dictionaries -- we
    // don't want to report bogus errors about clashes between submodule
    // names and other objects in the parent scopes.
    if (Scope * submoduleScope{ancestor->FindSubmodule(name)}) {
      moduleSymbol = submoduleScope->symbol();
      if (moduleSymbol) {
        moduleSymbol->set(Symbol::Flag::ModFile);
      }
    }
  }
  if (moduleSymbol) {
    CHECK(moduleSymbol->test(Symbol::Flag::ModFile));
    auto &details{moduleSymbol->get<ModuleDetails>()};
    details.set_moduleFileHash(checkSum.value());
    details.set_previous(previousModuleSymbol);
    if (isIntrinsic.value_or(false)) {
      moduleSymbol->attrs().set(Attr::INTRINSIC);
    }
    return moduleSymbol->scope();
  } else {
    return nullptr;
  }
}

parser::Message &ModFileReader::Say(const char *verb, SourceName name,
    const std::string &ancestor, parser::MessageFixedText &&msg,
    const std::string &arg) {
  return context_.Say(name, "Cannot %s module file for %s: %s"_err_en_US, verb,
      parser::MessageFormattedText{ancestor.empty()
              ? "module '%s'"_en_US
              : "submodule '%s' of module '%s'"_en_US,
          name, ancestor}
          .MoveString(),
      parser::MessageFormattedText{std::move(msg), arg}.MoveString());
}

// program was read from a .mod file for a submodule; return the name of the
// submodule's parent submodule, nullptr if none.
static std::optional<SourceName> GetSubmoduleParent(
    const parser::Program &program) {
  CHECK(program.v.size() == 1);
  auto &unit{program.v.front()};
  auto &submod{std::get<common::Indirection<parser::Submodule>>(unit.u)};
  auto &stmt{
      std::get<parser::Statement<parser::SubmoduleStmt>>(submod.value().t)};
  auto &parentId{std::get<parser::ParentIdentifier>(stmt.statement.t)};
  if (auto &parent{std::get<std::optional<parser::Name>>(parentId.t)}) {
    return parent->source;
  } else {
    return std::nullopt;
  }
}

void SubprogramSymbolCollector::Collect() {
  const auto &details{symbol_.get<SubprogramDetails>()};
  isInterface_ = details.isInterface();
  for (const Symbol *dummyArg : details.dummyArgs()) {
    if (dummyArg) {
      DoSymbol(*dummyArg);
    }
  }
  if (details.isFunction()) {
    DoSymbol(details.result());
  }
  for (const auto &pair : scope_) {
    const Symbol &symbol{*pair.second};
    if (const auto *useDetails{symbol.detailsIf<UseDetails>()}) {
      const Symbol &ultimate{useDetails->symbol().GetUltimate()};
      bool needed{useSet_.count(ultimate) > 0};
      if (const auto *generic{ultimate.detailsIf<GenericDetails>()}) {
        // The generic may not be needed itself, but the specific procedure
        // &/or derived type that it shadows may be needed.
        const Symbol *spec{generic->specific()};
        const Symbol *dt{generic->derivedType()};
        needed = needed || (spec && useSet_.count(spec->GetUltimate()) > 0) ||
            (dt && useSet_.count(dt->GetUltimate()) > 0);
      } else if (const auto *subp{ultimate.detailsIf<SubprogramDetails>()}) {
        const Symbol *interface { subp->moduleInterface() };
        needed = needed || (interface && useSet_.count(*interface) > 0);
      }
      if (needed) {
        need_.push_back(symbol);
      }
    } else if (symbol.has<SubprogramDetails>()) {
      // An internal subprogram is needed if it is used as interface
      // for a dummy or return value procedure.
      bool needed{false};
      const auto hasInterface{[&symbol](const Symbol *s) -> bool {
        // Is 's' a procedure with interface 'symbol'?
        if (s) {
          if (const auto *sDetails{s->detailsIf<ProcEntityDetails>()}) {
            if (sDetails->procInterface() == &symbol) {
              return true;
            }
          }
        }
        return false;
      }};
      for (const Symbol *dummyArg : details.dummyArgs()) {
        needed = needed || hasInterface(dummyArg);
      }
      needed =
          needed || (details.isFunction() && hasInterface(&details.result()));
      if (needed && needSet_.insert(symbol).second) {
        need_.push_back(symbol);
      }
    }
  }
}

void SubprogramSymbolCollector::DoSymbol(const Symbol &symbol) {
  DoSymbol(symbol.name(), symbol);
}

// Do symbols this one depends on; then add to need_
void SubprogramSymbolCollector::DoSymbol(
    const SourceName &name, const Symbol &symbol) {
  const auto &scope{symbol.owner()};
  if (scope != scope_ && !scope.IsDerivedType()) {
    if (scope != scope_.parent()) {
      useSet_.insert(symbol);
    }
    if (NeedImport(name, symbol)) {
      imports_.insert(name);
    }
    return;
  }
  if (!needSet_.insert(symbol).second) {
    return; // already done
  }
  common::visit(common::visitors{
                    [this](const ObjectEntityDetails &details) {
                      for (const ShapeSpec &spec : details.shape()) {
                        DoBound(spec.lbound());
                        DoBound(spec.ubound());
                      }
                      for (const ShapeSpec &spec : details.coshape()) {
                        DoBound(spec.lbound());
                        DoBound(spec.ubound());
                      }
                      if (const Symbol * commonBlock{details.commonBlock()}) {
                        DoSymbol(*commonBlock);
                      }
                    },
                    [this](const CommonBlockDetails &details) {
                      for (const auto &object : details.objects()) {
                        DoSymbol(*object);
                      }
                    },
                    [this](const ProcEntityDetails &details) {
                      if (details.rawProcInterface()) {
                        DoSymbol(*details.rawProcInterface());
                      } else {
                        DoType(details.type());
                      }
                    },
                    [this](const ProcBindingDetails &details) {
                      DoSymbol(details.symbol());
                    },
                    [](const auto &) {},
                },
      symbol.details());
  if (!symbol.has<UseDetails>()) {
    DoType(symbol.GetType());
  }
  if (!scope.IsDerivedType()) {
    need_.push_back(symbol);
  }
  if (symbol.test(Fortran::semantics::Symbol::Flag::CrayPointer)) {
    for (const auto &[pointee, pointer] : symbol.owner().crayPointers()) {
      if (&*pointer == &symbol) {
        auto iter{symbol.owner().find(pointee)};
        CHECK(iter != symbol.owner().end());
        DoSymbol(*iter->second);
      }
    }
  } else if (symbol.test(Fortran::semantics::Symbol::Flag::CrayPointee)) {
    DoSymbol(GetCrayPointer(symbol));
  }
}

void SubprogramSymbolCollector::DoType(const DeclTypeSpec *type) {
  if (!type) {
    return;
  }
  switch (type->category()) {
  case DeclTypeSpec::Numeric:
  case DeclTypeSpec::Logical:
    break; // nothing to do
  case DeclTypeSpec::Character:
    DoParamValue(type->characterTypeSpec().length());
    break;
  default:
    if (const DerivedTypeSpec * derived{type->AsDerived()}) {
      const auto &typeSymbol{derived->typeSymbol()};
      for (const auto &pair : derived->parameters()) {
        DoParamValue(pair.second);
      }
      // The components of the type (including its parent component, if
      // any) matter to IMPORT symbol collection only for derived types
      // defined in the subprogram.
      if (typeSymbol.owner() == scope_) {
        if (const DerivedTypeSpec * extends{typeSymbol.GetParentTypeSpec()}) {
          DoSymbol(extends->name(), extends->typeSymbol());
        }
        for (const auto &pair : *typeSymbol.scope()) {
          DoSymbol(*pair.second);
        }
      }
      DoSymbol(derived->name(), typeSymbol);
    }
  }
}

void SubprogramSymbolCollector::DoBound(const Bound &bound) {
  if (const MaybeSubscriptIntExpr & expr{bound.GetExplicit()}) {
    DoExpr(*expr);
  }
}
void SubprogramSymbolCollector::DoParamValue(const ParamValue &paramValue) {
  if (const auto &expr{paramValue.GetExplicit()}) {
    DoExpr(*expr);
  }
}

// Do we need a IMPORT of this symbol into an interface block?
bool SubprogramSymbolCollector::NeedImport(
    const SourceName &name, const Symbol &symbol) {
  if (!isInterface_) {
    return false;
  } else if (IsSeparateModuleProcedureInterface(&symbol_)) {
    return false; // IMPORT needed only for external and dummy procedure
                  // interfaces
  } else if (&symbol == scope_.symbol()) {
    return false;
  } else if (symbol.owner().Contains(scope_)) {
    return true;
  } else if (const Symbol *found{scope_.FindSymbol(name)}) {
    // detect import from ancestor of use-associated symbol
    return found->has<UseDetails>() && found->owner() != scope_;
  } else {
    // "found" can be null in the case of a use-associated derived type's
    // parent type, and also in the case of an object (like a dummy argument)
    // used to define a length or bound of a nested interface.
    return false;
  }
}

} // namespace Fortran::semantics