flang/lib/Semantics/rewrite-parse-tree.cpp

   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       : 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
  70 private:
  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
  79 void 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
  86 static 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.
 102 void 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
 133 bool 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
 139 bool 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
 145 bool 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
 151 bool 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
 157 bool 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)
 164 bool 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=.
 190 template <typename READ_OR_WRITE>
 191 void 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.
 207 void 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
 225 void RewriteMutator::Post(parser::WriteStmt &x) {
 226   FixMisparsedUntaggedNamelistName(x);
 227 }
 228
 229 bool 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