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 : 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 void Post(parser::SpecificationPart &);
44 bool Pre(parser::ExecutionPart &);
45 void Post(parser::ReadStmt &);
46 void Post(parser::WriteStmt &);
47
48 // Name resolution yet implemented:
49 // TODO: Can some/all of these now be enabled?
50 bool Pre(parser::EquivalenceStmt &) { return false; }
51 bool Pre(parser::Keyword &) { return false; }
52 bool Pre(parser::EntryStmt &) { return false; }
53 bool Pre(parser::CompilerDirective &) { return false; }
54
55 // Don't bother resolving names in end statements.
56 bool Pre(parser::EndBlockDataStmt &) { return false; }
57 bool Pre(parser::EndFunctionStmt &) { return false; }
58 bool Pre(parser::EndInterfaceStmt &) { return false; }
59 bool Pre(parser::EndModuleStmt &) { return false; }
60 bool Pre(parser::EndMpSubprogramStmt &) { return false; }
61 bool Pre(parser::EndProgramStmt &) { return false; }
62 bool Pre(parser::EndSubmoduleStmt &) { return false; }
63 bool Pre(parser::EndSubroutineStmt &) { return false; }
64 bool Pre(parser::EndTypeStmt &) { return false; }
65
66private:
67 using stmtFuncType =
68 parser::Statement<common::Indirection<parser::StmtFunctionStmt>>;
69 bool errorOnUnresolvedName_{true};
70 parser::Messages &messages_;
71 std::list<stmtFuncType> stmtFuncsToConvert_;
72};
73
74// Check that name has been resolved to a symbol
75void RewriteMutator::Post(parser::Name &name) {
76 if (!name.symbol && errorOnUnresolvedName_) {
77 messages_.Say(name.source, "Internal: no symbol found for '%s'"_err_en_US,
78 name.source);
79 }
80}
81
82static bool ReturnsDataPointer(const Symbol &symbol) {
83 if (const Symbol * funcRes{FindFunctionResult(symbol)}) {
84 return IsPointer(*funcRes) && !IsProcedure(*funcRes);
85 } else if (const auto *generic{symbol.detailsIf<GenericDetails>()}) {
86 for (auto ref : generic->specificProcs()) {
87 if (ReturnsDataPointer(*ref)) {
88 return true;
89 }
90 }
91 }
92 return false;
93}
94
95// Find mis-parsed statement functions and move to stmtFuncsToConvert_ list.
96void RewriteMutator::Post(parser::SpecificationPart &x) {
97 auto &list{std::get<std::list<parser::DeclarationConstruct>>(x.t)};
98 for (auto it{list.begin()}; it != list.end();) {
99 bool isAssignment{false};
100 if (auto *stmt{std::get_if<stmtFuncType>(&it->u)}) {
101 if (const Symbol *
102 symbol{std::get<parser::Name>(stmt->statement.value().t).symbol}) {
103 const Symbol &ultimate{symbol->GetUltimate()};
104 isAssignment =
105 ultimate.has<ObjectEntityDetails>() || ReturnsDataPointer(ultimate);
106 if (isAssignment) {
107 stmtFuncsToConvert_.emplace_back(std::move(*stmt));
108 }
109 }
110 }
111 if (isAssignment) {
112 it = list.erase(it);
113 } else {
114 ++it;
115 }
116 }
117}
118
119// Insert converted assignments at start of ExecutionPart.
120bool RewriteMutator::Pre(parser::ExecutionPart &x) {
121 auto origFirst{x.v.begin()}; // insert each elem before origFirst
122 for (stmtFuncType &sf : stmtFuncsToConvert_) {
123 auto stmt{sf.statement.value().ConvertToAssignment()};
124 stmt.source = sf.source;
125 x.v.insert(origFirst,
126 parser::ExecutionPartConstruct{
127 parser::ExecutableConstruct{std::move(stmt)}});
128 }
129 stmtFuncsToConvert_.clear();
130 return true;
131}
132
133// When a namelist group name appears (without NML=) in a READ or WRITE
134// statement in such a way that it can be misparsed as a format expression,
135// rewrite the I/O statement's parse tree node as if the namelist group
136// name had appeared with NML=.
137template <typename READ_OR_WRITE>
138void FixMisparsedUntaggedNamelistName(READ_OR_WRITE &x) {
139 if (x.iounit && x.format &&
140 std::holds_alternative<parser::Expr>(x.format->u)) {
141 if (const parser::Name * name{parser::Unwrap<parser::Name>(x.format)}) {
142 if (name->symbol && name->symbol->GetUltimate().has<NamelistDetails>()) {
143 x.controls.emplace_front(parser::IoControlSpec{std::move(*name)});
144 x.format.reset();
145 }
146 }
147 }
148}
149
150// READ(CVAR) [, ...] will be misparsed as UNIT=CVAR; correct
151// it to READ CVAR [,...] with CVAR as a format rather than as
152// an internal I/O unit for unformatted I/O, which Fortran does
153// not support.
154void RewriteMutator::Post(parser::ReadStmt &x) {
155 if (x.iounit && !x.format && x.controls.empty()) {
156 if (auto *var{std::get_if<parser::Variable>(&x.iounit->u)}) {
157 const parser::Name &last{parser::GetLastName(*var)};
158 DeclTypeSpec *type{last.symbol ? last.symbol->GetType() : nullptr};
159 if (type && type->category() == DeclTypeSpec::Character) {
160 x.format = common::visit(
161 [](auto &&indirection) {
162 return parser::Expr{std::move(indirection)};
163 },
164 std::move(var->u));
165 x.iounit.reset();
166 }
167 }
168 }
169 FixMisparsedUntaggedNamelistName(x);
170}
171
172void RewriteMutator::Post(parser::WriteStmt &x) {
173 FixMisparsedUntaggedNamelistName(x);
174}
175
176bool RewriteParseTree(SemanticsContext &context, parser::Program &program) {
177 RewriteMutator mutator{context};
178 parser::Walk(program, mutator);
179 return !context.AnyFatalError() && RewriteOmpParts(context, program);
180}
181
182} // namespace Fortran::semantics
183

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