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 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, nullptr, ""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(
502 sorted.end() - commonSize, sorted.end(), SymbolSourcePositionCompare{});
503 }
504
PutEntity(llvm::raw_ostream & os,const Symbol & symbol)505 void PutEntity(llvm::raw_ostream &os, const Symbol &symbol) {
506 std::visit(
507 common::visitors{
508 [&](const ObjectEntityDetails &) { PutObjectEntity(os, symbol); },
509 [&](const ProcEntityDetails &) { PutProcEntity(os, symbol); },
510 [&](const TypeParamDetails &) { PutTypeParam(os, symbol); },
511 [&](const auto &) {
512 common::die("PutEntity: unexpected details: %s",
513 DetailsToString(symbol.details()).c_str());
514 },
515 },
516 symbol.details());
517 }
518
PutShapeSpec(llvm::raw_ostream & os,const ShapeSpec & x)519 void PutShapeSpec(llvm::raw_ostream &os, const ShapeSpec &x) {
520 if (x.lbound().isAssumed()) {
521 CHECK(x.ubound().isAssumed());
522 os << "..";
523 } else {
524 if (!x.lbound().isDeferred()) {
525 PutBound(os, x.lbound());
526 }
527 os << ':';
528 if (!x.ubound().isDeferred()) {
529 PutBound(os, x.ubound());
530 }
531 }
532 }
PutShape(llvm::raw_ostream & os,const ArraySpec & shape,char open,char close)533 void PutShape(
534 llvm::raw_ostream &os, const ArraySpec &shape, char open, char close) {
535 if (!shape.empty()) {
536 os << open;
537 bool first{true};
538 for (const auto &shapeSpec : shape) {
539 if (first) {
540 first = false;
541 } else {
542 os << ',';
543 }
544 PutShapeSpec(os, shapeSpec);
545 }
546 os << close;
547 }
548 }
549
PutObjectEntity(llvm::raw_ostream & os,const Symbol & symbol)550 void PutObjectEntity(llvm::raw_ostream &os, const Symbol &symbol) {
551 auto &details{symbol.get<ObjectEntityDetails>()};
552 PutEntity(
553 os, symbol, [&]() { PutType(os, DEREF(symbol.GetType())); },
554 symbol.attrs());
555 PutShape(os, details.shape(), '(', ')');
556 PutShape(os, details.coshape(), '[', ']');
557 PutInit(os, symbol, details.init());
558 os << '\n';
559 }
560
PutProcEntity(llvm::raw_ostream & os,const Symbol & symbol)561 void PutProcEntity(llvm::raw_ostream &os, const Symbol &symbol) {
562 if (symbol.attrs().test(Attr::INTRINSIC)) {
563 os << "intrinsic::" << symbol.name() << '\n';
564 if (symbol.attrs().test(Attr::PRIVATE)) {
565 os << "private::" << symbol.name() << '\n';
566 }
567 return;
568 }
569 const auto &details{symbol.get<ProcEntityDetails>()};
570 const ProcInterface &interface{details.interface()};
571 Attrs attrs{symbol.attrs()};
572 if (details.passName()) {
573 attrs.reset(Attr::PASS);
574 }
575 PutEntity(
576 os, symbol,
577 [&]() {
578 os << "procedure(";
579 if (interface.symbol()) {
580 os << interface.symbol()->name();
581 } else if (interface.type()) {
582 PutType(os, *interface.type());
583 }
584 os << ')';
585 PutPassName(os, details.passName());
586 },
587 attrs);
588 os << '\n';
589 }
590
PutPassName(llvm::raw_ostream & os,const std::optional<SourceName> & passName)591 void PutPassName(
592 llvm::raw_ostream &os, const std::optional<SourceName> &passName) {
593 if (passName) {
594 os << ",pass(" << *passName << ')';
595 }
596 }
PutTypeParam(llvm::raw_ostream & os,const Symbol & symbol)597 void PutTypeParam(llvm::raw_ostream &os, const Symbol &symbol) {
598 auto &details{symbol.get<TypeParamDetails>()};
599 PutEntity(
600 os, symbol,
601 [&]() {
602 PutType(os, DEREF(symbol.GetType()));
603 PutLower(os << ',', common::EnumToString(details.attr()));
604 },
605 symbol.attrs());
606 PutInit(os, details.init());
607 os << '\n';
608 }
609
PutInit(llvm::raw_ostream & os,const Symbol & symbol,const MaybeExpr & init)610 void PutInit(
611 llvm::raw_ostream &os, const Symbol &symbol, const MaybeExpr &init) {
612 if (init) {
613 if (symbol.attrs().test(Attr::PARAMETER) ||
614 symbol.owner().IsDerivedType()) {
615 os << (symbol.attrs().test(Attr::POINTER) ? "=>" : "=");
616 init->AsFortran(os);
617 }
618 }
619 }
620
PutInit(llvm::raw_ostream & os,const MaybeIntExpr & init)621 void PutInit(llvm::raw_ostream &os, const MaybeIntExpr &init) {
622 if (init) {
623 init->AsFortran(os << '=');
624 }
625 }
626
PutBound(llvm::raw_ostream & os,const Bound & x)627 void PutBound(llvm::raw_ostream &os, const Bound &x) {
628 if (x.isAssumed()) {
629 os << '*';
630 } else if (x.isDeferred()) {
631 os << ':';
632 } else {
633 x.GetExplicit()->AsFortran(os);
634 }
635 }
636
637 // Write an entity (object or procedure) declaration.
638 // writeType is called to write out the type.
PutEntity(llvm::raw_ostream & os,const Symbol & symbol,std::function<void ()> writeType,Attrs attrs)639 void PutEntity(llvm::raw_ostream &os, const Symbol &symbol,
640 std::function<void()> writeType, Attrs attrs) {
641 writeType();
642 PutAttrs(os, attrs, symbol.GetBindName());
643 os << "::" << symbol.name();
644 }
645
646 // Put out each attribute to os, surrounded by `before` and `after` and
647 // mapped to lower case.
PutAttrs(llvm::raw_ostream & os,Attrs attrs,const std::string * bindName,std::string before,std::string after)648 llvm::raw_ostream &PutAttrs(llvm::raw_ostream &os, Attrs attrs,
649 const std::string *bindName, std::string before, std::string after) {
650 attrs.set(Attr::PUBLIC, false); // no need to write PUBLIC
651 attrs.set(Attr::EXTERNAL, false); // no need to write EXTERNAL
652 if (bindName) {
653 os << before << "bind(c, name=\"" << *bindName << "\")" << after;
654 attrs.set(Attr::BIND_C, false);
655 }
656 for (std::size_t i{0}; i < Attr_enumSize; ++i) {
657 Attr attr{static_cast<Attr>(i)};
658 if (attrs.test(attr)) {
659 PutAttr(os << before, attr) << after;
660 }
661 }
662 return os;
663 }
664
PutAttr(llvm::raw_ostream & os,Attr attr)665 llvm::raw_ostream &PutAttr(llvm::raw_ostream &os, Attr attr) {
666 return PutLower(os, AttrToString(attr));
667 }
668
PutType(llvm::raw_ostream & os,const DeclTypeSpec & type)669 llvm::raw_ostream &PutType(llvm::raw_ostream &os, const DeclTypeSpec &type) {
670 return PutLower(os, type.AsFortran());
671 }
672
PutLower(llvm::raw_ostream & os,const std::string & str)673 llvm::raw_ostream &PutLower(llvm::raw_ostream &os, const std::string &str) {
674 for (char c : str) {
675 os << parser::ToLowerCaseLetter(c);
676 }
677 return os;
678 }
679
680 struct Temp {
TempFortran::semantics::Temp681 Temp(int fd, std::string path) : fd{fd}, path{path} {}
TempFortran::semantics::Temp682 Temp(Temp &&t) : fd{std::exchange(t.fd, -1)}, path{std::move(t.path)} {}
~TempFortran::semantics::Temp683 ~Temp() {
684 if (fd >= 0) {
685 llvm::sys::fs::file_t native{llvm::sys::fs::convertFDToNativeFile(fd)};
686 llvm::sys::fs::closeFile(native);
687 llvm::sys::fs::remove(path.c_str());
688 }
689 }
690 int fd;
691 std::string path;
692 };
693
694 // Create a temp file in the same directory and with the same suffix as path.
695 // Return an open file descriptor and its path.
MkTemp(const std::string & path)696 static llvm::ErrorOr<Temp> MkTemp(const std::string &path) {
697 auto length{path.length()};
698 auto dot{path.find_last_of("./")};
699 std::string suffix{
700 dot < length && path[dot] == '.' ? path.substr(dot + 1) : ""};
701 CHECK(length > suffix.length() &&
702 path.substr(length - suffix.length()) == suffix);
703 auto prefix{path.substr(0, length - suffix.length())};
704 int fd;
705 llvm::SmallString<16> tempPath;
706 if (std::error_code err{llvm::sys::fs::createUniqueFile(
707 prefix + "%%%%%%" + suffix, fd, tempPath)}) {
708 return err;
709 }
710 return Temp{fd, tempPath.c_str()};
711 }
712
713 // Write the module file at path, prepending header. If an error occurs,
714 // return errno, otherwise 0.
WriteFile(const std::string & path,const std::string & contents,bool debug)715 static std::error_code WriteFile(
716 const std::string &path, const std::string &contents, bool debug) {
717 auto header{std::string{ModHeader::bom} + ModHeader::magic +
718 CheckSum(contents) + ModHeader::terminator};
719 if (debug) {
720 llvm::dbgs() << "Processing module " << path << ": ";
721 }
722 if (FileContentsMatch(path, header, contents)) {
723 if (debug) {
724 llvm::dbgs() << "module unchanged, not writing\n";
725 }
726 return {};
727 }
728 llvm::ErrorOr<Temp> temp{MkTemp(path)};
729 if (!temp) {
730 return temp.getError();
731 }
732 llvm::raw_fd_ostream writer(temp->fd, /*shouldClose=*/false);
733 writer << header;
734 writer << contents;
735 writer.flush();
736 if (writer.has_error()) {
737 return writer.error();
738 }
739 if (debug) {
740 llvm::dbgs() << "module written\n";
741 }
742 return llvm::sys::fs::rename(temp->path, path);
743 }
744
745 // 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)746 static bool FileContentsMatch(const std::string &path,
747 const std::string &header, const std::string &contents) {
748 std::size_t hsize{header.size()};
749 std::size_t csize{contents.size()};
750 auto buf_or{llvm::MemoryBuffer::getFile(path)};
751 if (!buf_or) {
752 return false;
753 }
754 auto buf = std::move(buf_or.get());
755 if (buf->getBufferSize() != hsize + csize) {
756 return false;
757 }
758 if (!std::equal(header.begin(), header.end(), buf->getBufferStart(),
759 buf->getBufferStart() + hsize)) {
760 return false;
761 }
762
763 return std::equal(contents.begin(), contents.end(),
764 buf->getBufferStart() + hsize, buf->getBufferEnd());
765 }
766
767 // Compute a simple hash of the contents of a module file and
768 // return it as a string of hex digits.
769 // This uses the Fowler-Noll-Vo hash function.
CheckSum(const std::string_view & contents)770 static std::string CheckSum(const std::string_view &contents) {
771 std::uint64_t hash{0xcbf29ce484222325ull};
772 for (char c : contents) {
773 hash ^= c & 0xff;
774 hash *= 0x100000001b3;
775 }
776 static const char *digits = "0123456789abcdef";
777 std::string result(ModHeader::sumLen, '0');
778 for (size_t i{ModHeader::sumLen}; hash != 0; hash >>= 4) {
779 result[--i] = digits[hash & 0xf];
780 }
781 return result;
782 }
783
VerifyHeader(llvm::ArrayRef<char> content)784 static bool VerifyHeader(llvm::ArrayRef<char> content) {
785 std::string_view sv{content.data(), content.size()};
786 if (sv.substr(0, ModHeader::magicLen) != ModHeader::magic) {
787 return false;
788 }
789 std::string_view expectSum{sv.substr(ModHeader::magicLen, ModHeader::sumLen)};
790 std::string actualSum{CheckSum(sv.substr(ModHeader::len))};
791 return expectSum == actualSum;
792 }
793
Read(const SourceName & name,Scope * ancestor)794 Scope *ModFileReader::Read(const SourceName &name, Scope *ancestor) {
795 std::string ancestorName; // empty for module
796 if (ancestor) {
797 if (auto *scope{ancestor->FindSubmodule(name)}) {
798 return scope;
799 }
800 ancestorName = ancestor->GetName().value().ToString();
801 } else {
802 auto it{context_.globalScope().find(name)};
803 if (it != context_.globalScope().end()) {
804 return it->second->scope();
805 }
806 }
807 parser::Parsing parsing{context_.allCookedSources()};
808 parser::Options options;
809 options.isModuleFile = true;
810 options.features.Enable(common::LanguageFeature::BackslashEscapes);
811 options.searchDirectories = context_.searchDirectories();
812 auto path{ModFileName(name, ancestorName, context_.moduleFileSuffix())};
813 const auto *sourceFile{parsing.Prescan(path, options)};
814 if (parsing.messages().AnyFatalError()) {
815 for (auto &msg : parsing.messages().messages()) {
816 std::string str{msg.ToString()};
817 Say(name, ancestorName, parser::MessageFixedText{str.c_str(), str.size()},
818 path);
819 }
820 return nullptr;
821 }
822 CHECK(sourceFile);
823 if (!VerifyHeader(sourceFile->content())) {
824 Say(name, ancestorName, "File has invalid checksum: %s"_en_US,
825 sourceFile->path());
826 return nullptr;
827 }
828 llvm::raw_null_ostream NullStream;
829 parsing.Parse(NullStream);
830 auto &parseTree{parsing.parseTree()};
831 if (!parsing.messages().empty() || !parsing.consumedWholeFile() ||
832 !parseTree) {
833 Say(name, ancestorName, "Module file is corrupt: %s"_err_en_US,
834 sourceFile->path());
835 return nullptr;
836 }
837 Scope *parentScope; // the scope this module/submodule goes into
838 if (!ancestor) {
839 parentScope = &context_.globalScope();
840 } else if (std::optional<SourceName> parent{GetSubmoduleParent(*parseTree)}) {
841 parentScope = Read(*parent, ancestor);
842 } else {
843 parentScope = ancestor;
844 }
845 auto pair{parentScope->try_emplace(name, UnknownDetails{})};
846 if (!pair.second) {
847 return nullptr;
848 }
849 Symbol &modSymbol{*pair.first->second};
850 modSymbol.set(Symbol::Flag::ModFile);
851 ResolveNames(context_, *parseTree);
852 CHECK(modSymbol.has<ModuleDetails>());
853 CHECK(modSymbol.test(Symbol::Flag::ModFile));
854 return modSymbol.scope();
855 }
856
Say(const SourceName & name,const std::string & ancestor,parser::MessageFixedText && msg,const std::string & arg)857 parser::Message &ModFileReader::Say(const SourceName &name,
858 const std::string &ancestor, parser::MessageFixedText &&msg,
859 const std::string &arg) {
860 return context_.Say(name, "Cannot read module file for %s: %s"_err_en_US,
861 parser::MessageFormattedText{ancestor.empty()
862 ? "module '%s'"_en_US
863 : "submodule '%s' of module '%s'"_en_US,
864 name, ancestor}
865 .MoveString(),
866 parser::MessageFormattedText{std::move(msg), arg}.MoveString());
867 }
868
869 // program was read from a .mod file for a submodule; return the name of the
870 // submodule's parent submodule, nullptr if none.
GetSubmoduleParent(const parser::Program & program)871 static std::optional<SourceName> GetSubmoduleParent(
872 const parser::Program &program) {
873 CHECK(program.v.size() == 1);
874 auto &unit{program.v.front()};
875 auto &submod{std::get<common::Indirection<parser::Submodule>>(unit.u)};
876 auto &stmt{
877 std::get<parser::Statement<parser::SubmoduleStmt>>(submod.value().t)};
878 auto &parentId{std::get<parser::ParentIdentifier>(stmt.statement.t)};
879 if (auto &parent{std::get<std::optional<parser::Name>>(parentId.t)}) {
880 return parent->source;
881 } else {
882 return std::nullopt;
883 }
884 }
885
Collect()886 void SubprogramSymbolCollector::Collect() {
887 const auto &details{symbol_.get<SubprogramDetails>()};
888 isInterface_ = details.isInterface();
889 for (const Symbol *dummyArg : details.dummyArgs()) {
890 if (dummyArg) {
891 DoSymbol(*dummyArg);
892 }
893 }
894 if (details.isFunction()) {
895 DoSymbol(details.result());
896 }
897 for (const auto &pair : scope_) {
898 const Symbol &symbol{*pair.second};
899 if (const auto *useDetails{symbol.detailsIf<UseDetails>()}) {
900 if (useSet_.count(useDetails->symbol().GetUltimate()) > 0) {
901 need_.push_back(symbol);
902 }
903 }
904 }
905 }
906
DoSymbol(const Symbol & symbol)907 void SubprogramSymbolCollector::DoSymbol(const Symbol &symbol) {
908 DoSymbol(symbol.name(), symbol);
909 }
910
911 // Do symbols this one depends on; then add to need_
DoSymbol(const SourceName & name,const Symbol & symbol)912 void SubprogramSymbolCollector::DoSymbol(
913 const SourceName &name, const Symbol &symbol) {
914 const auto &scope{symbol.owner()};
915 if (scope != scope_ && !scope.IsDerivedType()) {
916 if (scope != scope_.parent()) {
917 useSet_.insert(symbol);
918 }
919 if (NeedImport(name, symbol)) {
920 imports_.insert(name);
921 }
922 return;
923 }
924 if (!needSet_.insert(symbol).second) {
925 return; // already done
926 }
927 std::visit(common::visitors{
928 [this](const ObjectEntityDetails &details) {
929 for (const ShapeSpec &spec : details.shape()) {
930 DoBound(spec.lbound());
931 DoBound(spec.ubound());
932 }
933 for (const ShapeSpec &spec : details.coshape()) {
934 DoBound(spec.lbound());
935 DoBound(spec.ubound());
936 }
937 if (const Symbol * commonBlock{details.commonBlock()}) {
938 DoSymbol(*commonBlock);
939 }
940 },
941 [this](const CommonBlockDetails &details) {
942 for (const auto &object : details.objects()) {
943 DoSymbol(*object);
944 }
945 },
946 [](const auto &) {},
947 },
948 symbol.details());
949 if (!symbol.has<UseDetails>()) {
950 DoType(symbol.GetType());
951 }
952 if (!scope.IsDerivedType()) {
953 need_.push_back(symbol);
954 }
955 }
956
DoType(const DeclTypeSpec * type)957 void SubprogramSymbolCollector::DoType(const DeclTypeSpec *type) {
958 if (!type) {
959 return;
960 }
961 switch (type->category()) {
962 case DeclTypeSpec::Numeric:
963 case DeclTypeSpec::Logical:
964 break; // nothing to do
965 case DeclTypeSpec::Character:
966 DoParamValue(type->characterTypeSpec().length());
967 break;
968 default:
969 if (const DerivedTypeSpec * derived{type->AsDerived()}) {
970 const auto &typeSymbol{derived->typeSymbol()};
971 if (const DerivedTypeSpec * extends{typeSymbol.GetParentTypeSpec()}) {
972 DoSymbol(extends->name(), extends->typeSymbol());
973 }
974 for (const auto &pair : derived->parameters()) {
975 DoParamValue(pair.second);
976 }
977 for (const auto &pair : *typeSymbol.scope()) {
978 const Symbol &comp{*pair.second};
979 DoSymbol(comp);
980 }
981 DoSymbol(derived->name(), derived->typeSymbol());
982 }
983 }
984 }
985
DoBound(const Bound & bound)986 void SubprogramSymbolCollector::DoBound(const Bound &bound) {
987 if (const MaybeSubscriptIntExpr & expr{bound.GetExplicit()}) {
988 DoExpr(*expr);
989 }
990 }
DoParamValue(const ParamValue & paramValue)991 void SubprogramSymbolCollector::DoParamValue(const ParamValue ¶mValue) {
992 if (const auto &expr{paramValue.GetExplicit()}) {
993 DoExpr(*expr);
994 }
995 }
996
997 // Do we need a IMPORT of this symbol into an interface block?
NeedImport(const SourceName & name,const Symbol & symbol)998 bool SubprogramSymbolCollector::NeedImport(
999 const SourceName &name, const Symbol &symbol) {
1000 if (!isInterface_) {
1001 return false;
1002 } else if (symbol.owner().Contains(scope_)) {
1003 return true;
1004 } else if (const Symbol * found{scope_.FindSymbol(name)}) {
1005 // detect import from ancestor of use-associated symbol
1006 return found->has<UseDetails>() && found->owner() != scope_;
1007 } else {
1008 // "found" can be null in the case of a use-associated derived type's parent
1009 // type
1010 CHECK(symbol.has<DerivedTypeDetails>());
1011 return false;
1012 }
1013 }
1014
1015 } // namespace Fortran::semantics
1016