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