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

source code of flang/lib/Semantics/mod-file.cpp