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/Semantics/scope.h"
16 #include "flang/Semantics/semantics.h"
17 #include "flang/Semantics/symbol.h"
18 #include "flang/Semantics/tools.h"
19 #include "llvm/Support/FileSystem.h"
20 #include "llvm/Support/MemoryBuffer.h"
21 #include "llvm/Support/raw_ostream.h"
22 #include <algorithm>
23 #include <fstream>
24 #include <set>
25 #include <string_view>
26 #include <vector>
27
28 namespace Fortran::semantics {
29
30 using namespace parser::literals;
31
32 // The first line of a file that identifies it as a .mod file.
33 // The first three bytes are a Unicode byte order mark that ensures
34 // that the module file is decoded as UTF-8 even if source files
35 // are using another encoding.
36 struct ModHeader {
37 static constexpr const char bom[3 + 1]{"\xef\xbb\xbf"};
38 static constexpr int magicLen{13};
39 static constexpr int sumLen{16};
40 static constexpr const char magic[magicLen + 1]{"!mod$ v1 sum:"};
41 static constexpr char terminator{'\n'};
42 static constexpr int len{magicLen + 1 + sumLen};
43 };
44
45 static std::optional<SourceName> GetSubmoduleParent(const parser::Program &);
46 static void CollectSymbols(const Scope &, SymbolVector &, SymbolVector &);
47 static void PutEntity(llvm::raw_ostream &, const Symbol &);
48 static void PutObjectEntity(llvm::raw_ostream &, const Symbol &);
49 static void PutProcEntity(llvm::raw_ostream &, const Symbol &);
50 static void PutPassName(llvm::raw_ostream &, const std::optional<SourceName> &);
51 static void PutTypeParam(llvm::raw_ostream &, const Symbol &);
52 static void PutEntity(
53 llvm::raw_ostream &, const Symbol &, std::function<void()>, Attrs);
54 static void PutInit(llvm::raw_ostream &, const Symbol &, const MaybeExpr &);
55 static void PutInit(llvm::raw_ostream &, const MaybeIntExpr &);
56 static void PutBound(llvm::raw_ostream &, const Bound &);
57 llvm::raw_ostream &PutAttrs(llvm::raw_ostream &, Attrs,
58 const std::string * = nullptr, std::string before = ","s,
59 std::string after = ""s);
60
61 static llvm::raw_ostream &PutAttr(llvm::raw_ostream &, Attr);
62 static llvm::raw_ostream &PutType(llvm::raw_ostream &, const DeclTypeSpec &);
63 static llvm::raw_ostream &PutLower(llvm::raw_ostream &, const std::string &);
64 static std::error_code WriteFile(
65 const std::string &, const std::string &, bool = true);
66 static bool FileContentsMatch(
67 const std::string &, const std::string &, const std::string &);
68 static std::string CheckSum(const std::string_view &);
69
70 // Collect symbols needed for a subprogram interface
71 class SubprogramSymbolCollector {
72 public:
SubprogramSymbolCollector(const Symbol & symbol,const Scope & scope)73 SubprogramSymbolCollector(const Symbol &symbol, const Scope &scope)
74 : symbol_{symbol}, scope_{scope} {}
symbols() const75 const SymbolVector &symbols() const { return need_; }
imports() const76 const std::set<SourceName> &imports() const { return imports_; }
77 void Collect();
78
79 private:
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
DoExpr(evaluate::Expr<T> expr)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
WriteAll()102 bool 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
WriteAll(const Scope & scope)110 void ModFileWriter::WriteAll(const Scope &scope) {
111 for (const auto &child : scope.children()) {
112 WriteOne(child);
113 }
114 }
115
WriteOne(const Scope & scope)116 void 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.
ModFileName(const SourceName & name,const std::string & ancestorName,const std::string & suffix)127 static 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.
Write(const Symbol & symbol)134 void ModFileWriter::Write(const Symbol &symbol) {
135 auto *ancestor{symbol.get<ModuleDetails>().ancestor()};
136 auto ancestorName{ancestor ? ancestor->GetName().value().ToString() : ""s};
137 auto path{context_.moduleDirectory() + '/' +
138 ModFileName(symbol.name(), ancestorName, context_.moduleFileSuffix())};
139 PutSymbols(DEREF(symbol.scope()));
140 if (std::error_code error{
141 WriteFile(path, GetAsString(symbol), context_.debugModuleWriter())}) {
142 context_.Say(
143 symbol.name(), "Error writing %s: %s"_err_en_US, path, error.message());
144 }
145 }
146
147 // Return the entire body of the module file
148 // and clear saved uses, decls, and contains.
GetAsString(const Symbol & symbol)149 std::string ModFileWriter::GetAsString(const Symbol &symbol) {
150 std::string buf;
151 llvm::raw_string_ostream all{buf};
152 auto &details{symbol.get<ModuleDetails>()};
153 if (!details.isSubmodule()) {
154 all << "module " << symbol.name();
155 } else {
156 auto *parent{details.parent()->symbol()};
157 auto *ancestor{details.ancestor()->symbol()};
158 all << "submodule(" << ancestor->name();
159 if (parent != ancestor) {
160 all << ':' << parent->name();
161 }
162 all << ") " << symbol.name();
163 }
164 all << '\n' << uses_.str();
165 uses_.str().clear();
166 all << useExtraAttrs_.str();
167 useExtraAttrs_.str().clear();
168 all << decls_.str();
169 decls_.str().clear();
170 auto str{contains_.str()};
171 contains_.str().clear();
172 if (!str.empty()) {
173 all << "contains\n" << str;
174 }
175 all << "end\n";
176 return all.str();
177 }
178
179 // Put out the visible symbols from scope.
PutSymbols(const Scope & scope)180 bool ModFileWriter::PutSymbols(const Scope &scope) {
181 SymbolVector sorted;
182 SymbolVector uses;
183 CollectSymbols(scope, sorted, uses);
184 std::string buf; // stuff after CONTAINS in derived type
185 llvm::raw_string_ostream typeBindings{buf};
186 for (const Symbol &symbol : sorted) {
187 if (!symbol.test(Symbol::Flag::CompilerCreated)) {
188 PutSymbol(typeBindings, symbol);
189 }
190 }
191 for (const Symbol &symbol : uses) {
192 PutUse(symbol);
193 }
194 for (const auto &set : scope.equivalenceSets()) {
195 if (!set.empty() &&
196 !set.front().symbol.test(Symbol::Flag::CompilerCreated)) {
197 char punctuation{'('};
198 decls_ << "equivalence";
199 for (const auto &object : set) {
200 decls_ << punctuation << object.AsFortran();
201 punctuation = ',';
202 }
203 decls_ << ")\n";
204 }
205 }
206 if (auto str{typeBindings.str()}; !str.empty()) {
207 CHECK(scope.IsDerivedType());
208 decls_ << "contains\n" << str;
209 return true;
210 } else {
211 return false;
212 }
213 }
214
PutGenericName(llvm::raw_ostream & os,const Symbol & symbol)215 static llvm::raw_ostream &PutGenericName(
216 llvm::raw_ostream &os, const Symbol &symbol) {
217 if (IsGenericDefinedOp(symbol)) {
218 return os << "operator(" << symbol.name() << ')';
219 } else {
220 return os << symbol.name();
221 }
222 }
223
224 // Emit a symbol to decls_, except for bindings in a derived type (type-bound
225 // procedures, type-bound generics, final procedures) which go to typeBindings.
PutSymbol(llvm::raw_ostream & typeBindings,const Symbol & symbol)226 void ModFileWriter::PutSymbol(
227 llvm::raw_ostream &typeBindings, const Symbol &symbol) {
228 std::visit(common::visitors{
229 [&](const ModuleDetails &) { /* should be current module */ },
230 [&](const DerivedTypeDetails &) { PutDerivedType(symbol); },
231 [&](const SubprogramDetails &) { PutSubprogram(symbol); },
232 [&](const GenericDetails &x) {
233 if (symbol.owner().IsDerivedType()) {
234 // generic binding
235 for (const Symbol &proc : x.specificProcs()) {
236 PutGenericName(typeBindings << "generic::", symbol)
237 << "=>" << proc.name() << '\n';
238 }
239 } else {
240 PutGeneric(symbol);
241 if (x.specific()) {
242 PutSymbol(typeBindings, *x.specific());
243 }
244 if (x.derivedType()) {
245 PutSymbol(typeBindings, *x.derivedType());
246 }
247 }
248 },
249 [&](const UseDetails &) { PutUse(symbol); },
250 [](const UseErrorDetails &) {},
251 [&](const ProcBindingDetails &x) {
252 bool deferred{symbol.attrs().test(Attr::DEFERRED)};
253 typeBindings << "procedure";
254 if (deferred) {
255 typeBindings << '(' << x.symbol().name() << ')';
256 }
257 PutPassName(typeBindings, x.passName());
258 auto attrs{symbol.attrs()};
259 if (x.passName()) {
260 attrs.reset(Attr::PASS);
261 }
262 PutAttrs(typeBindings, attrs);
263 typeBindings << "::" << symbol.name();
264 if (!deferred && x.symbol().name() != symbol.name()) {
265 typeBindings << "=>" << x.symbol().name();
266 }
267 typeBindings << '\n';
268 },
269 [&](const NamelistDetails &x) {
270 decls_ << "namelist/" << symbol.name();
271 char sep{'/'};
272 for (const Symbol &object : x.objects()) {
273 decls_ << sep << object.name();
274 sep = ',';
275 }
276 decls_ << '\n';
277 },
278 [&](const CommonBlockDetails &x) {
279 decls_ << "common/" << symbol.name();
280 char sep = '/';
281 for (const auto &object : x.objects()) {
282 decls_ << sep << object->name();
283 sep = ',';
284 }
285 decls_ << '\n';
286 if (symbol.attrs().test(Attr::BIND_C)) {
287 PutAttrs(decls_, symbol.attrs(), x.bindName(), ""s);
288 decls_ << "::/" << symbol.name() << "/\n";
289 }
290 },
291 [](const HostAssocDetails &) {},
292 [](const MiscDetails &) {},
293 [&](const auto &) { PutEntity(decls_, symbol); },
294 },
295 symbol.details());
296 }
297
PutDerivedType(const Symbol & typeSymbol)298 void ModFileWriter::PutDerivedType(const Symbol &typeSymbol) {
299 auto &details{typeSymbol.get<DerivedTypeDetails>()};
300 PutAttrs(decls_ << "type", typeSymbol.attrs());
301 if (const DerivedTypeSpec * extends{typeSymbol.GetParentTypeSpec()}) {
302 decls_ << ",extends(" << extends->name() << ')';
303 }
304 decls_ << "::" << typeSymbol.name();
305 auto &typeScope{*typeSymbol.scope()};
306 if (!details.paramNames().empty()) {
307 char sep{'('};
308 for (const auto &name : details.paramNames()) {
309 decls_ << sep << name;
310 sep = ',';
311 }
312 decls_ << ')';
313 }
314 decls_ << '\n';
315 if (details.sequence()) {
316 decls_ << "sequence\n";
317 }
318 bool contains{PutSymbols(typeScope)};
319 if (!details.finals().empty()) {
320 const char *sep{contains ? "final::" : "contains\nfinal::"};
321 for (const auto &pair : details.finals()) {
322 decls_ << sep << pair.second->name();
323 sep = ",";
324 }
325 if (*sep == ',') {
326 decls_ << '\n';
327 }
328 }
329 decls_ << "end type\n";
330 }
331
332 // Attributes that may be in a subprogram prefix
333 static const Attrs subprogramPrefixAttrs{Attr::ELEMENTAL, Attr::IMPURE,
334 Attr::MODULE, Attr::NON_RECURSIVE, Attr::PURE, Attr::RECURSIVE};
335
PutSubprogram(const Symbol & symbol)336 void ModFileWriter::PutSubprogram(const Symbol &symbol) {
337 auto attrs{symbol.attrs()};
338 auto &details{symbol.get<SubprogramDetails>()};
339 Attrs bindAttrs{};
340 if (attrs.test(Attr::BIND_C)) {
341 // bind(c) is a suffix, not prefix
342 bindAttrs.set(Attr::BIND_C, true);
343 attrs.set(Attr::BIND_C, false);
344 }
345 bool isAbstract{attrs.test(Attr::ABSTRACT)};
346 if (isAbstract) {
347 attrs.set(Attr::ABSTRACT, false);
348 }
349 Attrs prefixAttrs{subprogramPrefixAttrs & attrs};
350 // emit any non-prefix attributes in an attribute statement
351 attrs &= ~subprogramPrefixAttrs;
352 std::string ssBuf;
353 llvm::raw_string_ostream ss{ssBuf};
354 PutAttrs(ss, attrs);
355 if (!ss.str().empty()) {
356 decls_ << ss.str().substr(1) << "::" << symbol.name() << '\n';
357 }
358 bool isInterface{details.isInterface()};
359 llvm::raw_ostream &os{isInterface ? decls_ : contains_};
360 if (isInterface) {
361 os << (isAbstract ? "abstract " : "") << "interface\n";
362 }
363 PutAttrs(os, prefixAttrs, nullptr, ""s, " "s);
364 os << (details.isFunction() ? "function " : "subroutine ");
365 os << symbol.name() << '(';
366 int n = 0;
367 for (const auto &dummy : details.dummyArgs()) {
368 if (n++ > 0) {
369 os << ',';
370 }
371 if (dummy) {
372 os << dummy->name();
373 } else {
374 os << "*";
375 }
376 }
377 os << ')';
378 PutAttrs(os, bindAttrs, details.bindName(), " "s, ""s);
379 if (details.isFunction()) {
380 const Symbol &result{details.result()};
381 if (result.name() != symbol.name()) {
382 os << " result(" << result.name() << ')';
383 }
384 }
385 os << '\n';
386
387 // walk symbols, collect ones needed for interface
388 const Scope &scope{
389 details.entryScope() ? *details.entryScope() : DEREF(symbol.scope())};
390 SubprogramSymbolCollector collector{symbol, scope};
391 collector.Collect();
392 std::string typeBindingsBuf;
393 llvm::raw_string_ostream typeBindings{typeBindingsBuf};
394 ModFileWriter writer{context_};
395 for (const Symbol &need : collector.symbols()) {
396 writer.PutSymbol(typeBindings, need);
397 }
398 CHECK(typeBindings.str().empty());
399 os << writer.uses_.str();
400 for (const SourceName &import : collector.imports()) {
401 decls_ << "import::" << import << "\n";
402 }
403 os << writer.decls_.str();
404 os << "end\n";
405 if (isInterface) {
406 os << "end interface\n";
407 }
408 }
409
IsIntrinsicOp(const Symbol & symbol)410 static bool IsIntrinsicOp(const Symbol &symbol) {
411 if (const auto *details{symbol.GetUltimate().detailsIf<GenericDetails>()}) {
412 return details->kind().IsIntrinsicOperator();
413 } else {
414 return false;
415 }
416 }
417
PutGeneric(const Symbol & symbol)418 void ModFileWriter::PutGeneric(const Symbol &symbol) {
419 const auto &genericOwner{symbol.owner()};
420 auto &details{symbol.get<GenericDetails>()};
421 PutGenericName(decls_ << "interface ", symbol) << '\n';
422 for (const Symbol &specific : details.specificProcs()) {
423 if (specific.owner() == genericOwner) {
424 decls_ << "procedure::" << specific.name() << '\n';
425 }
426 }
427 decls_ << "end interface\n";
428 if (symbol.attrs().test(Attr::PRIVATE)) {
429 PutGenericName(decls_ << "private::", symbol) << '\n';
430 }
431 }
432
PutUse(const Symbol & symbol)433 void ModFileWriter::PutUse(const Symbol &symbol) {
434 auto &details{symbol.get<UseDetails>()};
435 auto &use{details.symbol()};
436 uses_ << "use " << GetUsedModule(details).name();
437 PutGenericName(uses_ << ",only:", symbol);
438 // Can have intrinsic op with different local-name and use-name
439 // (e.g. `operator(<)` and `operator(.lt.)`) but rename is not allowed
440 if (!IsIntrinsicOp(symbol) && use.name() != symbol.name()) {
441 PutGenericName(uses_ << "=>", use);
442 }
443 uses_ << '\n';
444 PutUseExtraAttr(Attr::VOLATILE, symbol, use);
445 PutUseExtraAttr(Attr::ASYNCHRONOUS, symbol, use);
446 if (symbol.attrs().test(Attr::PRIVATE)) {
447 PutGenericName(useExtraAttrs_ << "private::", symbol) << '\n';
448 }
449 }
450
451 // We have "USE local => use" in this module. If attr was added locally
452 // (i.e. on local but not on use), also write it out in the mod file.
PutUseExtraAttr(Attr attr,const Symbol & local,const Symbol & use)453 void ModFileWriter::PutUseExtraAttr(
454 Attr attr, const Symbol &local, const Symbol &use) {
455 if (local.attrs().test(attr) && !use.attrs().test(attr)) {
456 PutAttr(useExtraAttrs_, attr) << "::";
457 useExtraAttrs_ << local.name() << '\n';
458 }
459 }
460
461 // When a generic interface has the same name as a derived type
462 // in the same scope, the generic shadows the derived type.
463 // If the derived type were declared first, emit the generic
464 // interface at the position of derived type's declaration.
465 // (ReplaceName() is not used for this purpose because doing so
466 // would confusingly position error messages pertaining to the generic
467 // interface upon the derived type's declaration.)
NameInModuleFile(const Symbol & symbol)468 static inline SourceName NameInModuleFile(const Symbol &symbol) {
469 if (const auto *generic{symbol.detailsIf<GenericDetails>()}) {
470 if (const auto *derivedTypeOverload{generic->derivedType()}) {
471 if (derivedTypeOverload->name().begin() < symbol.name().begin()) {
472 return derivedTypeOverload->name();
473 }
474 }
475 } else if (const auto *use{symbol.detailsIf<UseDetails>()}) {
476 if (use->symbol().attrs().test(Attr::PRIVATE)) {
477 // Avoid the use in sorting of names created to access private
478 // specific procedures as a result of generic resolution;
479 // they're not in the cooked source.
480 return use->symbol().name();
481 }
482 }
483 return symbol.name();
484 }
485
486 // Collect the symbols of this scope sorted by their original order, not name.
487 // Namelists are an exception: they are sorted after other symbols.
CollectSymbols(const Scope & scope,SymbolVector & sorted,SymbolVector & uses)488 void CollectSymbols(
489 const Scope &scope, SymbolVector &sorted, SymbolVector &uses) {
490 SymbolVector namelist;
491 std::size_t commonSize{scope.commonBlocks().size()};
492 auto symbols{scope.GetSymbols()};
493 sorted.reserve(symbols.size() + commonSize);
494 for (SymbolRef symbol : symbols) {
495 if (!symbol->test(Symbol::Flag::ParentComp)) {
496 if (symbol->has<NamelistDetails>()) {
497 namelist.push_back(symbol);
498 } else {
499 sorted.push_back(symbol);
500 }
501 if (const auto *details{symbol->detailsIf<GenericDetails>()}) {
502 uses.insert(uses.end(), details->uses().begin(), details->uses().end());
503 }
504 }
505 }
506 // Sort most symbols by name: use of Symbol::ReplaceName ensures the source
507 // location of a symbol's name is the first "real" use.
508 std::sort(sorted.begin(), sorted.end(), [](SymbolRef x, SymbolRef y) {
509 return NameInModuleFile(x).begin() < NameInModuleFile(y).begin();
510 });
511 sorted.insert(sorted.end(), namelist.begin(), namelist.end());
512 for (const auto &pair : scope.commonBlocks()) {
513 sorted.push_back(*pair.second);
514 }
515 std::sort(
516 sorted.end() - commonSize, sorted.end(), SymbolSourcePositionCompare{});
517 }
518
PutEntity(llvm::raw_ostream & os,const Symbol & symbol)519 void PutEntity(llvm::raw_ostream &os, const Symbol &symbol) {
520 std::visit(
521 common::visitors{
522 [&](const ObjectEntityDetails &) { PutObjectEntity(os, symbol); },
523 [&](const ProcEntityDetails &) { PutProcEntity(os, symbol); },
524 [&](const TypeParamDetails &) { PutTypeParam(os, symbol); },
525 [&](const auto &) {
526 common::die("PutEntity: unexpected details: %s",
527 DetailsToString(symbol.details()).c_str());
528 },
529 },
530 symbol.details());
531 }
532
PutShapeSpec(llvm::raw_ostream & os,const ShapeSpec & x)533 void PutShapeSpec(llvm::raw_ostream &os, const ShapeSpec &x) {
534 if (x.lbound().isAssumed()) {
535 CHECK(x.ubound().isAssumed());
536 os << "..";
537 } else {
538 if (!x.lbound().isDeferred()) {
539 PutBound(os, x.lbound());
540 }
541 os << ':';
542 if (!x.ubound().isDeferred()) {
543 PutBound(os, x.ubound());
544 }
545 }
546 }
PutShape(llvm::raw_ostream & os,const ArraySpec & shape,char open,char close)547 void PutShape(
548 llvm::raw_ostream &os, const ArraySpec &shape, char open, char close) {
549 if (!shape.empty()) {
550 os << open;
551 bool first{true};
552 for (const auto &shapeSpec : shape) {
553 if (first) {
554 first = false;
555 } else {
556 os << ',';
557 }
558 PutShapeSpec(os, shapeSpec);
559 }
560 os << close;
561 }
562 }
563
PutObjectEntity(llvm::raw_ostream & os,const Symbol & symbol)564 void PutObjectEntity(llvm::raw_ostream &os, const Symbol &symbol) {
565 auto &details{symbol.get<ObjectEntityDetails>()};
566 PutEntity(
567 os, symbol, [&]() { PutType(os, DEREF(symbol.GetType())); },
568 symbol.attrs());
569 PutShape(os, details.shape(), '(', ')');
570 PutShape(os, details.coshape(), '[', ']');
571 PutInit(os, symbol, details.init());
572 os << '\n';
573 }
574
PutProcEntity(llvm::raw_ostream & os,const Symbol & symbol)575 void PutProcEntity(llvm::raw_ostream &os, const Symbol &symbol) {
576 if (symbol.attrs().test(Attr::INTRINSIC)) {
577 os << "intrinsic::" << symbol.name() << '\n';
578 if (symbol.attrs().test(Attr::PRIVATE)) {
579 os << "private::" << symbol.name() << '\n';
580 }
581 return;
582 }
583 const auto &details{symbol.get<ProcEntityDetails>()};
584 const ProcInterface &interface{details.interface()};
585 Attrs attrs{symbol.attrs()};
586 if (details.passName()) {
587 attrs.reset(Attr::PASS);
588 }
589 PutEntity(
590 os, symbol,
591 [&]() {
592 os << "procedure(";
593 if (interface.symbol()) {
594 os << interface.symbol()->name();
595 } else if (interface.type()) {
596 PutType(os, *interface.type());
597 }
598 os << ')';
599 PutPassName(os, details.passName());
600 },
601 attrs);
602 os << '\n';
603 }
604
PutPassName(llvm::raw_ostream & os,const std::optional<SourceName> & passName)605 void PutPassName(
606 llvm::raw_ostream &os, const std::optional<SourceName> &passName) {
607 if (passName) {
608 os << ",pass(" << *passName << ')';
609 }
610 }
PutTypeParam(llvm::raw_ostream & os,const Symbol & symbol)611 void PutTypeParam(llvm::raw_ostream &os, const Symbol &symbol) {
612 auto &details{symbol.get<TypeParamDetails>()};
613 PutEntity(
614 os, symbol,
615 [&]() {
616 PutType(os, DEREF(symbol.GetType()));
617 PutLower(os << ',', common::EnumToString(details.attr()));
618 },
619 symbol.attrs());
620 PutInit(os, details.init());
621 os << '\n';
622 }
623
PutInit(llvm::raw_ostream & os,const Symbol & symbol,const MaybeExpr & init)624 void PutInit(
625 llvm::raw_ostream &os, const Symbol &symbol, const MaybeExpr &init) {
626 if (init) {
627 if (symbol.attrs().test(Attr::PARAMETER) ||
628 symbol.owner().IsDerivedType()) {
629 os << (symbol.attrs().test(Attr::POINTER) ? "=>" : "=");
630 init->AsFortran(os);
631 }
632 }
633 }
634
PutInit(llvm::raw_ostream & os,const MaybeIntExpr & init)635 void PutInit(llvm::raw_ostream &os, const MaybeIntExpr &init) {
636 if (init) {
637 init->AsFortran(os << '=');
638 }
639 }
640
PutBound(llvm::raw_ostream & os,const Bound & x)641 void PutBound(llvm::raw_ostream &os, const Bound &x) {
642 if (x.isAssumed()) {
643 os << '*';
644 } else if (x.isDeferred()) {
645 os << ':';
646 } else {
647 x.GetExplicit()->AsFortran(os);
648 }
649 }
650
651 // Write an entity (object or procedure) declaration.
652 // writeType is called to write out the type.
PutEntity(llvm::raw_ostream & os,const Symbol & symbol,std::function<void ()> writeType,Attrs attrs)653 void PutEntity(llvm::raw_ostream &os, const Symbol &symbol,
654 std::function<void()> writeType, Attrs attrs) {
655 writeType();
656 PutAttrs(os, attrs, symbol.GetBindName());
657 os << "::" << symbol.name();
658 }
659
660 // Put out each attribute to os, surrounded by `before` and `after` and
661 // mapped to lower case.
PutAttrs(llvm::raw_ostream & os,Attrs attrs,const std::string * bindName,std::string before,std::string after)662 llvm::raw_ostream &PutAttrs(llvm::raw_ostream &os, Attrs attrs,
663 const std::string *bindName, std::string before, std::string after) {
664 attrs.set(Attr::PUBLIC, false); // no need to write PUBLIC
665 attrs.set(Attr::EXTERNAL, false); // no need to write EXTERNAL
666 if (bindName) {
667 os << before << "bind(c, name=\"" << *bindName << "\")" << after;
668 attrs.set(Attr::BIND_C, false);
669 }
670 for (std::size_t i{0}; i < Attr_enumSize; ++i) {
671 Attr attr{static_cast<Attr>(i)};
672 if (attrs.test(attr)) {
673 PutAttr(os << before, attr) << after;
674 }
675 }
676 return os;
677 }
678
PutAttr(llvm::raw_ostream & os,Attr attr)679 llvm::raw_ostream &PutAttr(llvm::raw_ostream &os, Attr attr) {
680 return PutLower(os, AttrToString(attr));
681 }
682
PutType(llvm::raw_ostream & os,const DeclTypeSpec & type)683 llvm::raw_ostream &PutType(llvm::raw_ostream &os, const DeclTypeSpec &type) {
684 return PutLower(os, type.AsFortran());
685 }
686
PutLower(llvm::raw_ostream & os,const std::string & str)687 llvm::raw_ostream &PutLower(llvm::raw_ostream &os, const std::string &str) {
688 for (char c : str) {
689 os << parser::ToLowerCaseLetter(c);
690 }
691 return os;
692 }
693
694 struct Temp {
TempFortran::semantics::Temp695 Temp(int fd, std::string path) : fd{fd}, path{path} {}
TempFortran::semantics::Temp696 Temp(Temp &&t) : fd{std::exchange(t.fd, -1)}, path{std::move(t.path)} {}
~TempFortran::semantics::Temp697 ~Temp() {
698 if (fd >= 0) {
699 llvm::sys::fs::file_t native{llvm::sys::fs::convertFDToNativeFile(fd)};
700 llvm::sys::fs::closeFile(native);
701 llvm::sys::fs::remove(path.c_str());
702 }
703 }
704 int fd;
705 std::string path;
706 };
707
708 // Create a temp file in the same directory and with the same suffix as path.
709 // Return an open file descriptor and its path.
MkTemp(const std::string & path)710 static llvm::ErrorOr<Temp> MkTemp(const std::string &path) {
711 auto length{path.length()};
712 auto dot{path.find_last_of("./")};
713 std::string suffix{
714 dot < length && path[dot] == '.' ? path.substr(dot + 1) : ""};
715 CHECK(length > suffix.length() &&
716 path.substr(length - suffix.length()) == suffix);
717 auto prefix{path.substr(0, length - suffix.length())};
718 int fd;
719 llvm::SmallString<16> tempPath;
720 if (std::error_code err{llvm::sys::fs::createUniqueFile(
721 prefix + "%%%%%%" + suffix, fd, tempPath)}) {
722 return err;
723 }
724 return Temp{fd, tempPath.c_str()};
725 }
726
727 // Write the module file at path, prepending header. If an error occurs,
728 // return errno, otherwise 0.
WriteFile(const std::string & path,const std::string & contents,bool debug)729 static std::error_code WriteFile(
730 const std::string &path, const std::string &contents, bool debug) {
731 auto header{std::string{ModHeader::bom} + ModHeader::magic +
732 CheckSum(contents) + ModHeader::terminator};
733 if (debug) {
734 llvm::dbgs() << "Processing module " << path << ": ";
735 }
736 if (FileContentsMatch(path, header, contents)) {
737 if (debug) {
738 llvm::dbgs() << "module unchanged, not writing\n";
739 }
740 return {};
741 }
742 llvm::ErrorOr<Temp> temp{MkTemp(path)};
743 if (!temp) {
744 return temp.getError();
745 }
746 llvm::raw_fd_ostream writer(temp->fd, /*shouldClose=*/false);
747 writer << header;
748 writer << contents;
749 writer.flush();
750 if (writer.has_error()) {
751 return writer.error();
752 }
753 if (debug) {
754 llvm::dbgs() << "module written\n";
755 }
756 return llvm::sys::fs::rename(temp->path, path);
757 }
758
759 // Return true if the stream matches what we would write for the mod file.
FileContentsMatch(const std::string & path,const std::string & header,const std::string & contents)760 static bool FileContentsMatch(const std::string &path,
761 const std::string &header, const std::string &contents) {
762 std::size_t hsize{header.size()};
763 std::size_t csize{contents.size()};
764 auto buf_or{llvm::MemoryBuffer::getFile(path)};
765 if (!buf_or) {
766 return false;
767 }
768 auto buf = std::move(buf_or.get());
769 if (buf->getBufferSize() != hsize + csize) {
770 return false;
771 }
772 if (!std::equal(header.begin(), header.end(), buf->getBufferStart(),
773 buf->getBufferStart() + hsize)) {
774 return false;
775 }
776
777 return std::equal(contents.begin(), contents.end(),
778 buf->getBufferStart() + hsize, buf->getBufferEnd());
779 }
780
781 // Compute a simple hash of the contents of a module file and
782 // return it as a string of hex digits.
783 // This uses the Fowler-Noll-Vo hash function.
CheckSum(const std::string_view & contents)784 static std::string CheckSum(const std::string_view &contents) {
785 std::uint64_t hash{0xcbf29ce484222325ull};
786 for (char c : contents) {
787 hash ^= c & 0xff;
788 hash *= 0x100000001b3;
789 }
790 static const char *digits = "0123456789abcdef";
791 std::string result(ModHeader::sumLen, '0');
792 for (size_t i{ModHeader::sumLen}; hash != 0; hash >>= 4) {
793 result[--i] = digits[hash & 0xf];
794 }
795 return result;
796 }
797
VerifyHeader(llvm::ArrayRef<char> content)798 static bool VerifyHeader(llvm::ArrayRef<char> content) {
799 std::string_view sv{content.data(), content.size()};
800 if (sv.substr(0, ModHeader::magicLen) != ModHeader::magic) {
801 return false;
802 }
803 std::string_view expectSum{sv.substr(ModHeader::magicLen, ModHeader::sumLen)};
804 std::string actualSum{CheckSum(sv.substr(ModHeader::len))};
805 return expectSum == actualSum;
806 }
807
Read(const SourceName & name,Scope * ancestor,bool silent)808 Scope *ModFileReader::Read(
809 const SourceName &name, Scope *ancestor, bool silent) {
810 std::string ancestorName; // empty for module
811 if (ancestor) {
812 if (auto *scope{ancestor->FindSubmodule(name)}) {
813 return scope;
814 }
815 ancestorName = ancestor->GetName().value().ToString();
816 } else {
817 auto it{context_.globalScope().find(name)};
818 if (it != context_.globalScope().end()) {
819 return it->second->scope();
820 }
821 }
822 parser::Parsing parsing{context_.allCookedSources()};
823 parser::Options options;
824 options.isModuleFile = true;
825 options.features.Enable(common::LanguageFeature::BackslashEscapes);
826 options.searchDirectories = context_.searchDirectories();
827 auto path{ModFileName(name, ancestorName, context_.moduleFileSuffix())};
828 const auto *sourceFile{parsing.Prescan(path, options)};
829 if (parsing.messages().AnyFatalError()) {
830 if (!silent) {
831 for (auto &msg : parsing.messages().messages()) {
832 std::string str{msg.ToString()};
833 Say(name, ancestorName,
834 parser::MessageFixedText{str.c_str(), str.size()}, path);
835 }
836 }
837 return nullptr;
838 }
839 CHECK(sourceFile);
840 if (!VerifyHeader(sourceFile->content())) {
841 Say(name, ancestorName, "File has invalid checksum: %s"_en_US,
842 sourceFile->path());
843 return nullptr;
844 }
845 llvm::raw_null_ostream NullStream;
846 parsing.Parse(NullStream);
847 auto &parseTree{parsing.parseTree()};
848 if (!parsing.messages().empty() || !parsing.consumedWholeFile() ||
849 !parseTree) {
850 Say(name, ancestorName, "Module file is corrupt: %s"_err_en_US,
851 sourceFile->path());
852 return nullptr;
853 }
854 Scope *parentScope; // the scope this module/submodule goes into
855 if (!ancestor) {
856 parentScope = &context_.globalScope();
857 } else if (std::optional<SourceName> parent{GetSubmoduleParent(*parseTree)}) {
858 parentScope = Read(*parent, ancestor);
859 } else {
860 parentScope = ancestor;
861 }
862 auto pair{parentScope->try_emplace(name, UnknownDetails{})};
863 if (!pair.second) {
864 return nullptr;
865 }
866 Symbol &modSymbol{*pair.first->second};
867 modSymbol.set(Symbol::Flag::ModFile);
868 ResolveNames(context_, *parseTree);
869 CHECK(modSymbol.has<ModuleDetails>());
870 CHECK(modSymbol.test(Symbol::Flag::ModFile));
871 return modSymbol.scope();
872 }
873
Say(const SourceName & name,const std::string & ancestor,parser::MessageFixedText && msg,const std::string & arg)874 parser::Message &ModFileReader::Say(const SourceName &name,
875 const std::string &ancestor, parser::MessageFixedText &&msg,
876 const std::string &arg) {
877 return context_.Say(name, "Cannot read module file for %s: %s"_err_en_US,
878 parser::MessageFormattedText{ancestor.empty()
879 ? "module '%s'"_en_US
880 : "submodule '%s' of module '%s'"_en_US,
881 name, ancestor}
882 .MoveString(),
883 parser::MessageFormattedText{std::move(msg), arg}.MoveString());
884 }
885
886 // program was read from a .mod file for a submodule; return the name of the
887 // submodule's parent submodule, nullptr if none.
GetSubmoduleParent(const parser::Program & program)888 static std::optional<SourceName> GetSubmoduleParent(
889 const parser::Program &program) {
890 CHECK(program.v.size() == 1);
891 auto &unit{program.v.front()};
892 auto &submod{std::get<common::Indirection<parser::Submodule>>(unit.u)};
893 auto &stmt{
894 std::get<parser::Statement<parser::SubmoduleStmt>>(submod.value().t)};
895 auto &parentId{std::get<parser::ParentIdentifier>(stmt.statement.t)};
896 if (auto &parent{std::get<std::optional<parser::Name>>(parentId.t)}) {
897 return parent->source;
898 } else {
899 return std::nullopt;
900 }
901 }
902
Collect()903 void SubprogramSymbolCollector::Collect() {
904 const auto &details{symbol_.get<SubprogramDetails>()};
905 isInterface_ = details.isInterface();
906 for (const Symbol *dummyArg : details.dummyArgs()) {
907 if (dummyArg) {
908 DoSymbol(*dummyArg);
909 }
910 }
911 if (details.isFunction()) {
912 DoSymbol(details.result());
913 }
914 for (const auto &pair : scope_) {
915 const Symbol &symbol{*pair.second};
916 if (const auto *useDetails{symbol.detailsIf<UseDetails>()}) {
917 if (useSet_.count(useDetails->symbol().GetUltimate()) > 0) {
918 need_.push_back(symbol);
919 }
920 }
921 }
922 }
923
DoSymbol(const Symbol & symbol)924 void SubprogramSymbolCollector::DoSymbol(const Symbol &symbol) {
925 DoSymbol(symbol.name(), symbol);
926 }
927
928 // Do symbols this one depends on; then add to need_
DoSymbol(const SourceName & name,const Symbol & symbol)929 void SubprogramSymbolCollector::DoSymbol(
930 const SourceName &name, const Symbol &symbol) {
931 const auto &scope{symbol.owner()};
932 if (scope != scope_ && !scope.IsDerivedType()) {
933 if (scope != scope_.parent()) {
934 useSet_.insert(symbol);
935 }
936 if (NeedImport(name, symbol)) {
937 imports_.insert(name);
938 }
939 return;
940 }
941 if (!needSet_.insert(symbol).second) {
942 return; // already done
943 }
944 std::visit(common::visitors{
945 [this](const ObjectEntityDetails &details) {
946 for (const ShapeSpec &spec : details.shape()) {
947 DoBound(spec.lbound());
948 DoBound(spec.ubound());
949 }
950 for (const ShapeSpec &spec : details.coshape()) {
951 DoBound(spec.lbound());
952 DoBound(spec.ubound());
953 }
954 if (const Symbol * commonBlock{details.commonBlock()}) {
955 DoSymbol(*commonBlock);
956 }
957 },
958 [this](const CommonBlockDetails &details) {
959 for (const auto &object : details.objects()) {
960 DoSymbol(*object);
961 }
962 },
963 [](const auto &) {},
964 },
965 symbol.details());
966 if (!symbol.has<UseDetails>()) {
967 DoType(symbol.GetType());
968 }
969 if (!scope.IsDerivedType()) {
970 need_.push_back(symbol);
971 }
972 }
973
DoType(const DeclTypeSpec * type)974 void SubprogramSymbolCollector::DoType(const DeclTypeSpec *type) {
975 if (!type) {
976 return;
977 }
978 switch (type->category()) {
979 case DeclTypeSpec::Numeric:
980 case DeclTypeSpec::Logical:
981 break; // nothing to do
982 case DeclTypeSpec::Character:
983 DoParamValue(type->characterTypeSpec().length());
984 break;
985 default:
986 if (const DerivedTypeSpec * derived{type->AsDerived()}) {
987 const auto &typeSymbol{derived->typeSymbol()};
988 if (const DerivedTypeSpec * extends{typeSymbol.GetParentTypeSpec()}) {
989 DoSymbol(extends->name(), extends->typeSymbol());
990 }
991 for (const auto &pair : derived->parameters()) {
992 DoParamValue(pair.second);
993 }
994 for (const auto &pair : *typeSymbol.scope()) {
995 const Symbol &comp{*pair.second};
996 DoSymbol(comp);
997 }
998 DoSymbol(derived->name(), derived->typeSymbol());
999 }
1000 }
1001 }
1002
DoBound(const Bound & bound)1003 void SubprogramSymbolCollector::DoBound(const Bound &bound) {
1004 if (const MaybeSubscriptIntExpr & expr{bound.GetExplicit()}) {
1005 DoExpr(*expr);
1006 }
1007 }
DoParamValue(const ParamValue & paramValue)1008 void SubprogramSymbolCollector::DoParamValue(const ParamValue ¶mValue) {
1009 if (const auto &expr{paramValue.GetExplicit()}) {
1010 DoExpr(*expr);
1011 }
1012 }
1013
1014 // Do we need a IMPORT of this symbol into an interface block?
NeedImport(const SourceName & name,const Symbol & symbol)1015 bool SubprogramSymbolCollector::NeedImport(
1016 const SourceName &name, const Symbol &symbol) {
1017 if (!isInterface_) {
1018 return false;
1019 } else if (symbol.owner().Contains(scope_)) {
1020 return true;
1021 } else if (const Symbol * found{scope_.FindSymbol(name)}) {
1022 // detect import from ancestor of use-associated symbol
1023 return found->has<UseDetails>() && found->owner() != scope_;
1024 } else {
1025 // "found" can be null in the case of a use-associated derived type's parent
1026 // type
1027 CHECK(symbol.has<DerivedTypeDetails>());
1028 return false;
1029 }
1030 }
1031
1032 } // namespace Fortran::semantics
1033