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:
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.
37   template <typename T> bool Pre(T &) { return true; }
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   void Post(parser::DataStmtConstant &);
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 
66 private:
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
75 void 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 
82 // Find mis-parsed statement functions and move to stmtFuncsToConvert_ list.
83 void RewriteMutator::Post(parser::SpecificationPart &x) {
84   auto &list{std::get<std::list<parser::DeclarationConstruct>>(x.t)};
85   for (auto it{list.begin()}; it != list.end();) {
86     if (auto stmt{std::get_if<stmtFuncType>(&it->u)}) {
87       Symbol *symbol{std::get<parser::Name>(stmt->statement.value().t).symbol};
88       if (symbol && symbol->has<ObjectEntityDetails>()) {
89         // not a stmt func: remove it here and add to ones to convert
90         stmtFuncsToConvert_.push_back(std::move(*stmt));
91         it = list.erase(it);
92         continue;
93       }
94     }
95     ++it;
96   }
97 }
98 
99 // Insert converted assignments at start of ExecutionPart.
100 bool RewriteMutator::Pre(parser::ExecutionPart &x) {
101   auto origFirst{x.v.begin()}; // insert each elem before origFirst
102   for (stmtFuncType &sf : stmtFuncsToConvert_) {
103     auto stmt{sf.statement.value().ConvertToAssignment()};
104     stmt.source = sf.source;
105     x.v.insert(origFirst,
106         parser::ExecutionPartConstruct{
107             parser::ExecutableConstruct{std::move(stmt)}});
108   }
109   stmtFuncsToConvert_.clear();
110   return true;
111 }
112 
113 void RewriteMutator::Post(parser::IoUnit &x) {
114   if (auto *var{std::get_if<parser::Variable>(&x.u)}) {
115     const parser::Name &last{parser::GetLastName(*var)};
116     DeclTypeSpec *type{last.symbol ? last.symbol->GetType() : nullptr};
117     if (!type || type->category() != DeclTypeSpec::Character) {
118       // If the Variable is not known to be character (any kind), transform
119       // the I/O unit in situ to a FileUnitNumber so that automatic expression
120       // constraint checking will be applied.
121       auto expr{std::visit(
122           [](auto &&indirection) {
123             return parser::Expr{std::move(indirection)};
124           },
125           std::move(var->u))};
126       x.u = parser::FileUnitNumber{
127           parser::ScalarIntExpr{parser::IntExpr{std::move(expr)}}};
128     }
129   }
130 }
131 
132 // When a namelist group name appears (without NML=) in a READ or WRITE
133 // statement in such a way that it can be misparsed as a format expression,
134 // rewrite the I/O statement's parse tree node as if the namelist group
135 // name had appeared with NML=.
136 template <typename READ_OR_WRITE>
137 void FixMisparsedUntaggedNamelistName(READ_OR_WRITE &x) {
138   if (x.iounit && x.format &&
139       std::holds_alternative<parser::Expr>(x.format->u)) {
140     if (const parser::Name * name{parser::Unwrap<parser::Name>(x.format)}) {
141       if (name->symbol && name->symbol->GetUltimate().has<NamelistDetails>()) {
142         x.controls.emplace_front(parser::IoControlSpec{std::move(*name)});
143         x.format.reset();
144       }
145     }
146   }
147 }
148 
149 void RewriteMutator::Post(parser::ReadStmt &x) {
150   FixMisparsedUntaggedNamelistName(x);
151 }
152 
153 void RewriteMutator::Post(parser::WriteStmt &x) {
154   FixMisparsedUntaggedNamelistName(x);
155 }
156 
157 void RewriteMutator::Post(parser::DataStmtConstant &x) {
158   if (auto *scalar{std::get_if<parser::Scalar<parser::ConstantValue>>(&x.u)}) {
159     if (auto *named{std::get_if<parser::NamedConstant>(&scalar->thing.u)}) {
160       if (const Symbol * symbol{named->v.symbol}) {
161         if (!IsNamedConstant(*symbol) && symbol->attrs().test(Attr::TARGET)) {
162           x.u = parser::InitialDataTarget{
163               parser::Designator{parser::DataRef{parser::Name{named->v}}}};
164         }
165       }
166     }
167   }
168 }
169 
170 bool RewriteParseTree(SemanticsContext &context, parser::Program &program) {
171   RewriteMutator mutator{context};
172   parser::Walk(program, mutator);
173   return !context.AnyFatalError();
174 }
175 
176 } // namespace Fortran::semantics
177