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