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 "rewrite-directives.h"
11#include "flang/Common/indirection.h"
12#include "flang/Parser/parse-tree-visitor.h"
13#include "flang/Parser/parse-tree.h"
14#include "flang/Parser/tools.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 <list>
20
21namespace Fortran::semantics {
22
23using namespace parser::literals;
24
25/// Convert misidentified statement functions to array element assignments
26/// or pointer-valued function result assignments.
27/// Convert misidentified format expressions to namelist group names.
28/// Convert misidentified character variables in I/O units to integer
29/// unit number expressions.
30/// Convert misidentified named constants in data statement values to
31/// initial data targets
32class RewriteMutator {
33public:
34 RewriteMutator(SemanticsContext &context)
35 : context_{context}, errorOnUnresolvedName_{!context.AnyFatalError()},
36 messages_{context.messages()} {}
37
38 // Default action for a parse tree node is to visit children.
39 template <typename T> bool Pre(T &) { return true; }
40 template <typename T> void Post(T &) {}
41
42 void Post(parser::Name &);
43 bool Pre(parser::MainProgram &);
44 bool Pre(parser::FunctionSubprogram &);
45 bool Pre(parser::SubroutineSubprogram &);
46 bool Pre(parser::SeparateModuleSubprogram &);
47 bool Pre(parser::BlockConstruct &);
48 bool Pre(parser::ActionStmt &);
49 void Post(parser::ReadStmt &);
50 void Post(parser::WriteStmt &);
51
52 // Name resolution yet implemented:
53 // TODO: Can some/all of these now be enabled?
54 bool Pre(parser::EquivalenceStmt &) { return false; }
55 bool Pre(parser::Keyword &) { return false; }
56 bool Pre(parser::EntryStmt &) { return false; }
57 bool Pre(parser::CompilerDirective &) { return false; }
58
59 // Don't bother resolving names in end statements.
60 bool Pre(parser::EndBlockDataStmt &) { return false; }
61 bool Pre(parser::EndFunctionStmt &) { return false; }
62 bool Pre(parser::EndInterfaceStmt &) { return false; }
63 bool Pre(parser::EndModuleStmt &) { return false; }
64 bool Pre(parser::EndMpSubprogramStmt &) { return false; }
65 bool Pre(parser::EndProgramStmt &) { return false; }
66 bool Pre(parser::EndSubmoduleStmt &) { return false; }
67 bool Pre(parser::EndSubroutineStmt &) { return false; }
68 bool Pre(parser::EndTypeStmt &) { return false; }
69
70private:
71 void FixMisparsedStmtFuncs(parser::SpecificationPart &, parser::Block &);
72
73 SemanticsContext &context_;
74 bool errorOnUnresolvedName_{true};
75 parser::Messages &messages_;
76};
77
78// Check that name has been resolved to a symbol
79void RewriteMutator::Post(parser::Name &name) {
80 if (!name.symbol && errorOnUnresolvedName_) {
81 messages_.Say(name.source, "Internal: no symbol found for '%s'"_err_en_US,
82 name.source);
83 }
84}
85
86static bool ReturnsDataPointer(const Symbol &symbol) {
87 if (const Symbol * funcRes{FindFunctionResult(symbol)}) {
88 return IsPointer(*funcRes) && !IsProcedure(*funcRes);
89 } else if (const auto *generic{symbol.detailsIf<GenericDetails>()}) {
90 for (auto ref : generic->specificProcs()) {
91 if (ReturnsDataPointer(*ref)) {
92 return true;
93 }
94 }
95 }
96 return false;
97}
98
99// Finds misparsed statement functions in a specification part, rewrites
100// them into array element assignment statements, and moves them into the
101// beginning of the corresponding (execution part's) block.
102void RewriteMutator::FixMisparsedStmtFuncs(
103 parser::SpecificationPart &specPart, parser::Block &block) {
104 auto &list{std::get<std::list<parser::DeclarationConstruct>>(specPart.t)};
105 auto origFirst{block.begin()}; // insert each elem before origFirst
106 for (auto it{list.begin()}; it != list.end();) {
107 bool convert{false};
108 if (auto *stmt{std::get_if<
109 parser::Statement<common::Indirection<parser::StmtFunctionStmt>>>(
110 &it->u)}) {
111 if (const Symbol *
112 symbol{std::get<parser::Name>(stmt->statement.value().t).symbol}) {
113 const Symbol &ultimate{symbol->GetUltimate()};
114 convert =
115 ultimate.has<ObjectEntityDetails>() || ReturnsDataPointer(ultimate);
116 if (convert) {
117 auto newStmt{stmt->statement.value().ConvertToAssignment()};
118 newStmt.source = stmt->source;
119 block.insert(origFirst,
120 parser::ExecutionPartConstruct{
121 parser::ExecutableConstruct{std::move(newStmt)}});
122 }
123 }
124 }
125 if (convert) {
126 it = list.erase(it);
127 } else {
128 ++it;
129 }
130 }
131}
132
133bool RewriteMutator::Pre(parser::MainProgram &program) {
134 FixMisparsedStmtFuncs(std::get<parser::SpecificationPart>(program.t),
135 std::get<parser::ExecutionPart>(program.t).v);
136 return true;
137}
138
139bool RewriteMutator::Pre(parser::FunctionSubprogram &func) {
140 FixMisparsedStmtFuncs(std::get<parser::SpecificationPart>(func.t),
141 std::get<parser::ExecutionPart>(func.t).v);
142 return true;
143}
144
145bool RewriteMutator::Pre(parser::SubroutineSubprogram &subr) {
146 FixMisparsedStmtFuncs(std::get<parser::SpecificationPart>(subr.t),
147 std::get<parser::ExecutionPart>(subr.t).v);
148 return true;
149}
150
151bool RewriteMutator::Pre(parser::SeparateModuleSubprogram &subp) {
152 FixMisparsedStmtFuncs(std::get<parser::SpecificationPart>(subp.t),
153 std::get<parser::ExecutionPart>(subp.t).v);
154 return true;
155}
156
157bool RewriteMutator::Pre(parser::BlockConstruct &block) {
158 FixMisparsedStmtFuncs(std::get<parser::BlockSpecificationPart>(block.t).v,
159 std::get<parser::Block>(block.t));
160 return true;
161}
162
163// Rewrite PRINT NML -> WRITE(*,NML=NML)
164bool RewriteMutator::Pre(parser::ActionStmt &x) {
165 if (auto *print{std::get_if<common::Indirection<parser::PrintStmt>>(&x.u)};
166 print &&
167 std::get<std::list<parser::OutputItem>>(print->value().t).empty()) {
168 auto &format{std::get<parser::Format>(print->value().t)};
169 if (std::holds_alternative<parser::Expr>(format.u)) {
170 if (auto *name{parser::Unwrap<parser::Name>(format)}; name &&
171 name->symbol && name->symbol->GetUltimate().has<NamelistDetails>() &&
172 context_.IsEnabled(common::LanguageFeature::PrintNamelist)) {
173 context_.Warn(common::LanguageFeature::PrintNamelist, name->source,
174 "nonstandard: namelist in PRINT statement"_port_en_US);
175 std::list<parser::IoControlSpec> controls;
176 controls.emplace_back(std::move(*name));
177 x.u = common::Indirection<parser::WriteStmt>::Make(
178 parser::IoUnit{parser::Star{}}, std::optional<parser::Format>{},
179 std::move(controls), std::list<parser::OutputItem>{});
180 }
181 }
182 }
183 return true;
184}
185
186// When a namelist group name appears (without NML=) in a READ or WRITE
187// statement in such a way that it can be misparsed as a format expression,
188// rewrite the I/O statement's parse tree node as if the namelist group
189// name had appeared with NML=.
190template <typename READ_OR_WRITE>
191void FixMisparsedUntaggedNamelistName(READ_OR_WRITE &x) {
192 if (x.iounit && x.format &&
193 std::holds_alternative<parser::Expr>(x.format->u)) {
194 if (const parser::Name * name{parser::Unwrap<parser::Name>(x.format)}) {
195 if (name->symbol && name->symbol->GetUltimate().has<NamelistDetails>()) {
196 x.controls.emplace_front(parser::IoControlSpec{std::move(*name)});
197 x.format.reset();
198 }
199 }
200 }
201}
202
203// READ(CVAR) [, ...] will be misparsed as UNIT=CVAR; correct
204// it to READ CVAR [,...] with CVAR as a format rather than as
205// an internal I/O unit for unformatted I/O, which Fortran does
206// not support.
207void RewriteMutator::Post(parser::ReadStmt &x) {
208 if (x.iounit && !x.format && x.controls.empty()) {
209 if (auto *var{std::get_if<parser::Variable>(&x.iounit->u)}) {
210 const parser::Name &last{parser::GetLastName(*var)};
211 DeclTypeSpec *type{last.symbol ? last.symbol->GetType() : nullptr};
212 if (type && type->category() == DeclTypeSpec::Character) {
213 x.format = common::visit(
214 [](auto &&indirection) {
215 return parser::Expr{std::move(indirection)};
216 },
217 std::move(var->u));
218 x.iounit.reset();
219 }
220 }
221 }
222 FixMisparsedUntaggedNamelistName(x);
223}
224
225void RewriteMutator::Post(parser::WriteStmt &x) {
226 FixMisparsedUntaggedNamelistName(x);
227}
228
229bool RewriteParseTree(SemanticsContext &context, parser::Program &program) {
230 RewriteMutator mutator{context};
231 parser::Walk(program, mutator);
232 return !context.AnyFatalError() && RewriteOmpParts(context, program);
233}
234
235} // namespace Fortran::semantics
236

source code of flang/lib/Semantics/rewrite-parse-tree.cpp