1 //===-- lib/Semantics/rewrite-parse-tree.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 "rewrite-parse-tree.h"
10 #include "flang/Common/indirection.h"
11 #include "flang/Parser/parse-tree-visitor.h"
12 #include "flang/Parser/parse-tree.h"
13 #include "flang/Parser/tools.h"
14 #include "flang/Semantics/scope.h"
15 #include "flang/Semantics/semantics.h"
16 #include "flang/Semantics/symbol.h"
17 #include "flang/Semantics/tools.h"
18 #include <list>
19
20 namespace Fortran::semantics {
21
22 using namespace parser::literals;
23
24 /// Convert misidentified statement functions to array element assignments.
25 /// Convert misidentified format expressions to namelist group names.
26 /// Convert misidentified character variables in I/O units to integer
27 /// unit number expressions.
28 /// Convert misidentified named constants in data statement values to
29 /// initial data targets
30 class RewriteMutator {
31 public:
RewriteMutator(SemanticsContext & context)32 RewriteMutator(SemanticsContext &context)
33 : errorOnUnresolvedName_{!context.AnyFatalError()},
34 messages_{context.messages()} {}
35
36 // Default action for a parse tree node is to visit children.
Pre(T &)37 template <typename T> bool Pre(T &) { return true; }
Post(T &)38 template <typename T> void Post(T &) {}
39
40 void Post(parser::Name &);
41 void Post(parser::SpecificationPart &);
42 bool Pre(parser::ExecutionPart &);
43 void Post(parser::IoUnit &);
44 void Post(parser::ReadStmt &);
45 void Post(parser::WriteStmt &);
46
47 // Name resolution yet implemented:
48 // TODO: Can some/all of these now be enabled?
Pre(parser::EquivalenceStmt &)49 bool Pre(parser::EquivalenceStmt &) { return false; }
Pre(parser::Keyword &)50 bool Pre(parser::Keyword &) { return false; }
Pre(parser::EntryStmt &)51 bool Pre(parser::EntryStmt &) { return false; }
Pre(parser::CompilerDirective &)52 bool Pre(parser::CompilerDirective &) { return false; }
53
54 // Don't bother resolving names in end statements.
Pre(parser::EndBlockDataStmt &)55 bool Pre(parser::EndBlockDataStmt &) { return false; }
Pre(parser::EndFunctionStmt &)56 bool Pre(parser::EndFunctionStmt &) { return false; }
Pre(parser::EndInterfaceStmt &)57 bool Pre(parser::EndInterfaceStmt &) { return false; }
Pre(parser::EndModuleStmt &)58 bool Pre(parser::EndModuleStmt &) { return false; }
Pre(parser::EndMpSubprogramStmt &)59 bool Pre(parser::EndMpSubprogramStmt &) { return false; }
Pre(parser::EndProgramStmt &)60 bool Pre(parser::EndProgramStmt &) { return false; }
Pre(parser::EndSubmoduleStmt &)61 bool Pre(parser::EndSubmoduleStmt &) { return false; }
Pre(parser::EndSubroutineStmt &)62 bool Pre(parser::EndSubroutineStmt &) { return false; }
Pre(parser::EndTypeStmt &)63 bool Pre(parser::EndTypeStmt &) { return false; }
64
65 private:
66 using stmtFuncType =
67 parser::Statement<common::Indirection<parser::StmtFunctionStmt>>;
68 bool errorOnUnresolvedName_{true};
69 parser::Messages &messages_;
70 std::list<stmtFuncType> stmtFuncsToConvert_;
71 };
72
73 // Check that name has been resolved to a symbol
Post(parser::Name & name)74 void RewriteMutator::Post(parser::Name &name) {
75 if (!name.symbol && errorOnUnresolvedName_) {
76 messages_.Say(name.source, "Internal: no symbol found for '%s'"_err_en_US,
77 name.source);
78 }
79 }
80
81 // Find mis-parsed statement functions and move to stmtFuncsToConvert_ list.
Post(parser::SpecificationPart & x)82 void RewriteMutator::Post(parser::SpecificationPart &x) {
83 auto &list{std::get<std::list<parser::DeclarationConstruct>>(x.t)};
84 for (auto it{list.begin()}; it != list.end();) {
85 if (auto stmt{std::get_if<stmtFuncType>(&it->u)}) {
86 Symbol *symbol{std::get<parser::Name>(stmt->statement.value().t).symbol};
87 if (symbol && symbol->has<ObjectEntityDetails>()) {
88 // not a stmt func: remove it here and add to ones to convert
89 stmtFuncsToConvert_.push_back(std::move(*stmt));
90 it = list.erase(it);
91 continue;
92 }
93 }
94 ++it;
95 }
96 }
97
98 // Insert converted assignments at start of ExecutionPart.
Pre(parser::ExecutionPart & x)99 bool RewriteMutator::Pre(parser::ExecutionPart &x) {
100 auto origFirst{x.v.begin()}; // insert each elem before origFirst
101 for (stmtFuncType &sf : stmtFuncsToConvert_) {
102 auto stmt{sf.statement.value().ConvertToAssignment()};
103 stmt.source = sf.source;
104 x.v.insert(origFirst,
105 parser::ExecutionPartConstruct{
106 parser::ExecutableConstruct{std::move(stmt)}});
107 }
108 stmtFuncsToConvert_.clear();
109 return true;
110 }
111
112 // Convert a syntactically ambiguous io-unit internal-file-variable to a
113 // file-unit-number.
Post(parser::IoUnit & x)114 void RewriteMutator::Post(parser::IoUnit &x) {
115 if (auto *var{std::get_if<parser::Variable>(&x.u)}) {
116 const parser::Name &last{parser::GetLastName(*var)};
117 DeclTypeSpec *type{last.symbol ? last.symbol->GetType() : nullptr};
118 if (!type || type->category() != DeclTypeSpec::Character) {
119 // If the Variable is not known to be character (any kind), transform
120 // the I/O unit in situ to a FileUnitNumber so that automatic expression
121 // constraint checking will be applied.
122 auto source{var->GetSource()};
123 auto expr{std::visit(
124 [](auto &&indirection) {
125 return parser::Expr{std::move(indirection)};
126 },
127 std::move(var->u))};
128 expr.source = source;
129 x.u = parser::FileUnitNumber{
130 parser::ScalarIntExpr{parser::IntExpr{std::move(expr)}}};
131 }
132 }
133 }
134
135 // When a namelist group name appears (without NML=) in a READ or WRITE
136 // statement in such a way that it can be misparsed as a format expression,
137 // rewrite the I/O statement's parse tree node as if the namelist group
138 // name had appeared with NML=.
139 template <typename READ_OR_WRITE>
FixMisparsedUntaggedNamelistName(READ_OR_WRITE & x)140 void FixMisparsedUntaggedNamelistName(READ_OR_WRITE &x) {
141 if (x.iounit && x.format &&
142 std::holds_alternative<parser::Expr>(x.format->u)) {
143 if (const parser::Name * name{parser::Unwrap<parser::Name>(x.format)}) {
144 if (name->symbol && name->symbol->GetUltimate().has<NamelistDetails>()) {
145 x.controls.emplace_front(parser::IoControlSpec{std::move(*name)});
146 x.format.reset();
147 }
148 }
149 }
150 }
151
152 // READ(CVAR) [, ...] will be misparsed as UNIT=CVAR; correct
153 // it to READ CVAR [,...] with CVAR as a format rather than as
154 // an internal I/O unit for unformatted I/O, which Fortran does
155 // not support.
Post(parser::ReadStmt & x)156 void RewriteMutator::Post(parser::ReadStmt &x) {
157 if (x.iounit && !x.format && x.controls.empty()) {
158 if (auto *var{std::get_if<parser::Variable>(&x.iounit->u)}) {
159 const parser::Name &last{parser::GetLastName(*var)};
160 DeclTypeSpec *type{last.symbol ? last.symbol->GetType() : nullptr};
161 if (type && type->category() == DeclTypeSpec::Character) {
162 x.format = std::visit(
163 [](auto &&indirection) {
164 return parser::Expr{std::move(indirection)};
165 },
166 std::move(var->u));
167 x.iounit.reset();
168 }
169 }
170 }
171 FixMisparsedUntaggedNamelistName(x);
172 }
173
Post(parser::WriteStmt & x)174 void RewriteMutator::Post(parser::WriteStmt &x) {
175 FixMisparsedUntaggedNamelistName(x);
176 }
177
RewriteParseTree(SemanticsContext & context,parser::Program & program)178 bool RewriteParseTree(SemanticsContext &context, parser::Program &program) {
179 RewriteMutator mutator{context};
180 parser::Walk(program, mutator);
181 return !context.AnyFatalError();
182 }
183
184 } // namespace Fortran::semantics
185