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 21 namespace Fortran::semantics { 22 23 using 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 32 class RewriteMutator { 33 public: 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 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 static 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. 96 void 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. 120 bool 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=. 137 template <typename READ_OR_WRITE> 138 void 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. 154 void 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 172 void RewriteMutator::Post(parser::WriteStmt &x) { 173 FixMisparsedUntaggedNamelistName(x); 174 } 175 176 bool 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