From 0ff94b9d0be3b9c53ba7375db69a44db313eed09 Mon Sep 17 00:00:00 2001
From: peter klausler <pklausler@nvidia.com>
Date: Mon, 1 Apr 2019 15:52:49 -0700
Subject: [PATCH] [flang] Define and use UnlabeledStatement<> for if & forall

Original-commit: flang-compiler/f18@028e6aba6cd0ca40533401fcd4bab38e94f1f43a
Reviewed-on: https://github.com/flang-compiler/f18/pull/373
Tree-same-pre-rewrite: false
---
 flang/lib/parser/dump-parse-tree.h    |   6 +-
 flang/lib/parser/grammar.h            |   7 +-
 flang/lib/parser/parse-tree-visitor.h |   8 +-
 flang/lib/parser/parse-tree.h         |  17 +-
 flang/lib/parser/stmt-parser.h        |   9 ++
 flang/lib/semantics/assignment.cc     | 297 +++++++++++++++++-----------------
 flang/lib/semantics/check-if-stmt.cc  |   6 +-
 7 files changed, 187 insertions(+), 163 deletions(-)

diff --git a/flang/lib/parser/dump-parse-tree.h b/flang/lib/parser/dump-parse-tree.h
index f427b1a..818e03e 100644
--- a/flang/lib/parser/dump-parse-tree.h
+++ b/flang/lib/parser/dump-parse-tree.h
@@ -790,8 +790,10 @@ public:
   bool Pre(const parser::CharBlock &) { return true; }
   void Post(const parser::CharBlock &) {}
 
-  template<typename T> bool Pre(const parser::Statement<T> &) { return true; }
-  template<typename T> void Post(const parser::Statement<T> &) {}
+  template<typename T> bool Pre(const parser::UnlabeledStatement<T> &) {
+    return true;
+  }
+  template<typename T> void Post(const parser::UnlabeledStatement<T> &) {}
 
   template<typename T> bool Pre(const common::Indirection<T> &) { return true; }
   template<typename T> void Post(const common::Indirection<T> &) {}
diff --git a/flang/lib/parser/grammar.h b/flang/lib/parser/grammar.h
index 66ce639b..10963ea 100644
--- a/flang/lib/parser/grammar.h
+++ b/flang/lib/parser/grammar.h
@@ -2015,8 +2015,8 @@ TYPE_CONTEXT_PARSER("END FORALL statement"_en_US,
 
 // R1055 forall-stmt -> FORALL concurrent-header forall-assignment-stmt
 TYPE_CONTEXT_PARSER("FORALL statement"_en_US,
-    construct<ForallStmt>(
-        "FORALL" >> indirect(concurrentHeader), forallAssignmentStmt))
+    construct<ForallStmt>("FORALL" >> indirect(concurrentHeader),
+        unlabeledStatement(forallAssignmentStmt)))
 
 // R1101 block -> [execution-part-construct]...
 constexpr auto block{many(executionPartConstruct)};
@@ -2201,7 +2201,8 @@ TYPE_CONTEXT_PARSER("IF construct"_en_US,
 
 // R1139 if-stmt -> IF ( scalar-logical-expr ) action-stmt
 TYPE_CONTEXT_PARSER("IF statement"_en_US,
-    construct<IfStmt>("IF" >> parenthesized(scalarLogicalExpr), actionStmt))
+    construct<IfStmt>("IF" >> parenthesized(scalarLogicalExpr),
+        unlabeledStatement(actionStmt)))
 
 // R1140 case-construct ->
 //         select-case-stmt [case-stmt block]... end-select-stmt
diff --git a/flang/lib/parser/parse-tree-visitor.h b/flang/lib/parser/parse-tree-visitor.h
index 7c9e2ae..4434106 100644
--- a/flang/lib/parser/parse-tree-visitor.h
+++ b/flang/lib/parser/parse-tree-visitor.h
@@ -291,17 +291,17 @@ template<typename T, typename M> void Walk(DefaultChar<T> &x, M &mutator) {
   }
 }
 
-template<typename T, typename V> void Walk(const Statement<T> &x, V &visitor) {
+template<typename T, typename V>
+void Walk(const UnlabeledStatement<T> &x, V &visitor) {
   if (visitor.Pre(x)) {
-    // N.B. the label is not traversed
     Walk(x.source, visitor);
     Walk(x.statement, visitor);
     visitor.Post(x);
   }
 }
-template<typename T, typename M> void Walk(Statement<T> &x, M &mutator) {
+template<typename T, typename M>
+void Walk(UnlabeledStatement<T> &x, M &mutator) {
   if (mutator.Pre(x)) {
-    // N.B. the label is not traversed
     Walk(x.source, mutator);
     Walk(x.statement, mutator);
     mutator.Post(x);
diff --git a/flang/lib/parser/parse-tree.h b/flang/lib/parser/parse-tree.h
index 5e5925a..c1dcdff 100644
--- a/flang/lib/parser/parse-tree.h
+++ b/flang/lib/parser/parse-tree.h
@@ -323,13 +323,16 @@ using Label = std::uint64_t;  // validated later, must be in [1..99999]
 
 // A wrapper for xzy-stmt productions that are statements, so that
 // source provenances and labels have a uniform representation.
-template<typename A> struct Statement {
-  Statement(std::optional<long> &&lab, A &&s)
-    : label(std::move(lab)), statement(std::move(s)) {}
+template<typename A> struct UnlabeledStatement {
+  explicit UnlabeledStatement(A &&s) : statement(std::move(s)) {}
   CharBlock source;
-  std::optional<Label> label;
   A statement;
 };
+template<typename A> struct Statement : public UnlabeledStatement<A> {
+  Statement(std::optional<long> &&lab, A &&s)
+    : UnlabeledStatement<A>{std::move(s)}, label(std::move(lab)) {}
+  std::optional<Label> label;
+};
 
 // Error recovery marker
 EMPTY_CLASS(ErrorRecovery);
@@ -2003,7 +2006,9 @@ struct ForallAssignmentStmt {
 // R1055 forall-stmt -> FORALL concurrent-header forall-assignment-stmt
 struct ForallStmt {
   TUPLE_CLASS_BOILERPLATE(ForallStmt);
-  std::tuple<common::Indirection<ConcurrentHeader>, ForallAssignmentStmt> t;
+  std::tuple<common::Indirection<ConcurrentHeader>,
+      UnlabeledStatement<ForallAssignmentStmt>>
+      t;
 };
 
 // R1052 forall-body-construct ->
@@ -2249,7 +2254,7 @@ struct IfConstruct {
 // R1139 if-stmt -> IF ( scalar-logical-expr ) action-stmt
 struct IfStmt {
   TUPLE_CLASS_BOILERPLATE(IfStmt);
-  std::tuple<ScalarLogicalExpr, ActionStmt> t;
+  std::tuple<ScalarLogicalExpr, UnlabeledStatement<ActionStmt>> t;
 };
 
 // R1141 select-case-stmt -> [case-construct-name :] SELECT CASE ( case-expr )
diff --git a/flang/lib/parser/stmt-parser.h b/flang/lib/parser/stmt-parser.h
index fb7d6d6..88affd1 100644
--- a/flang/lib/parser/stmt-parser.h
+++ b/flang/lib/parser/stmt-parser.h
@@ -48,6 +48,15 @@ template<typename PA> inline constexpr auto statement(const PA &p) {
   return unterminatedStatement(p) / endOfStmt;
 }
 
+// unlabeledStatement() is basically statement() for those few situations
+// in Fortran where a statement cannot have a label.
+template<typename PA> inline constexpr auto unlabeledStatement(const PA &p) {
+  return skipStuffBeforeStatement >>
+      sourced(
+          construct<UnlabeledStatement<typename PA::resultType>>(space >> p)) /
+      endOfStmt;
+}
+
 // This unambiguousStatement() variant of statement() provides better error
 // recovery for contexts containing statements that might have trailing
 // garbage, but it must be used only when no instance of the statement in
diff --git a/flang/lib/semantics/assignment.cc b/flang/lib/semantics/assignment.cc
index f8e11d9..1077fc2 100644
--- a/flang/lib/semantics/assignment.cc
+++ b/flang/lib/semantics/assignment.cc
@@ -192,173 +192,180 @@ void AssignmentContext::Analyze(const parser::ForallStmt &stmt) {
   AssignmentContext nested{*this, forall};
   nested.Analyze(
       std::get<common::Indirection<parser::ConcurrentHeader>>(stmt.t));
-  nested.Analyze(std::get<parser::ForallAssignmentStmt>(stmt.t));
-}
-
-// N.B. Construct name matching is checked during label resolution;
-// index name distinction is checked during name resolution.
-void AssignmentContext::Analyze(const parser::ForallConstruct &construct) {
-  CHECK(!where_);
-  ForallContext forall{forall_};
-  AssignmentContext nested{*this, forall};
-  const auto &forallStmt{
-      std::get<parser::Statement<parser::ForallConstructStmt>>(construct.t)};
-  context_.set_location(&forallStmt.source);
-  nested.Analyze(std::get<common::Indirection<parser::ConcurrentHeader>>(
-      forallStmt.statement.t));
-  for (const auto &body :
-      std::get<std::list<parser::ForallBodyConstruct>>(construct.t)) {
-    nested.Analyze(body.u);
+  const auto &assign{
+      std::get<parser::UnlabeledStatement<parser::ForallAssignmentStmt>>(
+          stmt.t)};
+  auto restorer {
+    nested.messages_.SetLocation(assign.source);
+    nested.Analyze(assign.statement);
   }
-}
 
-void AssignmentContext::Analyze(
-    const parser::WhereConstruct::MaskedElsewhere &elsewhere) {
-  CHECK(where_ != nullptr);
-  const auto &elsewhereStmt{
-      std::get<parser::Statement<parser::MaskedElsewhereStmt>>(elsewhere.t)};
-  context_.set_location(&elsewhereStmt.source);
-  MaskExpr mask{
-      GetMask(std::get<parser::LogicalExpr>(elsewhereStmt.statement.t))};
-  MaskExpr copyCumulative{where_->cumulativeMaskExpr};
-  MaskExpr notOldMask{evaluate::LogicalNegation(std::move(copyCumulative))};
-  if (!evaluate::AreConformable(notOldMask, mask)) {
-    Say(elsewhereStmt.source,
-        "mask of ELSEWHERE statement is not conformable with "
-        "the prior mask(s) in its WHERE construct"_err_en_US);
-  }
-  MaskExpr copyMask{mask};
-  where_->cumulativeMaskExpr =
-      evaluate::BinaryLogicalOperation(evaluate::LogicalOperator::Or,
-          std::move(where_->cumulativeMaskExpr), std::move(copyMask));
-  where_->thisMaskExpr = evaluate::BinaryLogicalOperation(
-      evaluate::LogicalOperator::And, std::move(notOldMask), std::move(mask));
-  if (where_->outer != nullptr &&
-      !evaluate::AreConformable(
-          where_->outer->thisMaskExpr, where_->thisMaskExpr)) {
-    Say(elsewhereStmt.source,
-        "effective mask of ELSEWHERE statement is not conformable "
-        "with the mask of the surrounding WHERE construct"_err_en_US);
-  }
-  for (const auto &x :
-      std::get<std::list<parser::WhereBodyConstruct>>(elsewhere.t)) {
-    Analyze(x);
+  // N.B. Construct name matching is checked during label resolution;
+  // index name distinction is checked during name resolution.
+  void AssignmentContext::Analyze(const parser::ForallConstruct &construct) {
+    CHECK(!where_);
+    ForallContext forall{forall_};
+    AssignmentContext nested{*this, forall};
+    const auto &forallStmt{
+        std::get<parser::Statement<parser::ForallConstructStmt>>(construct.t)};
+    context_.set_location(&forallStmt.source);
+    nested.Analyze(std::get<common::Indirection<parser::ConcurrentHeader>>(
+        forallStmt.statement.t));
+    for (const auto &body :
+        std::get<std::list<parser::ForallBodyConstruct>>(construct.t)) {
+      nested.Analyze(body.u);
+    }
   }
-}
 
-void AssignmentContext::Analyze(
-    const parser::WhereConstruct::Elsewhere &elsewhere) {
-  CHECK(where_ != nullptr);
-  MaskExpr copyCumulative{where_->cumulativeMaskExpr};
-  where_->thisMaskExpr = evaluate::LogicalNegation(std::move(copyCumulative));
-  for (const auto &x :
-      std::get<std::list<parser::WhereBodyConstruct>>(elsewhere.t)) {
-    Analyze(x);
+  void AssignmentContext::Analyze(
+      const parser::WhereConstruct::MaskedElsewhere &elsewhere) {
+    CHECK(where_ != nullptr);
+    const auto &elsewhereStmt{
+        std::get<parser::Statement<parser::MaskedElsewhereStmt>>(elsewhere.t)};
+    context_.set_location(&elsewhereStmt.source);
+    MaskExpr mask{
+        GetMask(std::get<parser::LogicalExpr>(elsewhereStmt.statement.t))};
+    MaskExpr copyCumulative{where_->cumulativeMaskExpr};
+    MaskExpr notOldMask{evaluate::LogicalNegation(std::move(copyCumulative))};
+    if (!evaluate::AreConformable(notOldMask, mask)) {
+      Say(elsewhereStmt.source,
+          "mask of ELSEWHERE statement is not conformable with "
+          "the prior mask(s) in its WHERE construct"_err_en_US);
+    }
+    MaskExpr copyMask{mask};
+    where_->cumulativeMaskExpr =
+        evaluate::BinaryLogicalOperation(evaluate::LogicalOperator::Or,
+            std::move(where_->cumulativeMaskExpr), std::move(copyMask));
+    where_->thisMaskExpr = evaluate::BinaryLogicalOperation(
+        evaluate::LogicalOperator::And, std::move(notOldMask), std::move(mask));
+    if (where_->outer != nullptr &&
+        !evaluate::AreConformable(
+            where_->outer->thisMaskExpr, where_->thisMaskExpr)) {
+      Say(elsewhereStmt.source,
+          "effective mask of ELSEWHERE statement is not conformable "
+          "with the mask of the surrounding WHERE construct"_err_en_US);
+    }
+    for (const auto &x :
+        std::get<std::list<parser::WhereBodyConstruct>>(elsewhere.t)) {
+      Analyze(x);
+    }
   }
-}
 
-void AssignmentContext::Analyze(const parser::ConcurrentHeader &header) {
-  CHECK(forall_ != nullptr);
-  forall_->integerKind = GetIntegerKind(
-      std::get<std::optional<parser::IntegerTypeSpec>>(header.t));
-  for (const auto &control :
-      std::get<std::list<parser::ConcurrentControl>>(header.t)) {
-    const parser::CharBlock &name{std::get<parser::Name>(control.t).source};
-    bool inserted{forall_->activeNames.insert(name).second};
-    CHECK(inserted);
+  void AssignmentContext::Analyze(
+      const parser::WhereConstruct::Elsewhere &elsewhere) {
+    CHECK(where_ != nullptr);
+    MaskExpr copyCumulative{where_->cumulativeMaskExpr};
+    where_->thisMaskExpr = evaluate::LogicalNegation(std::move(copyCumulative));
+    for (const auto &x :
+        std::get<std::list<parser::WhereBodyConstruct>>(elsewhere.t)) {
+      Analyze(x);
+    }
   }
-}
 
-int AssignmentContext::GetIntegerKind(
-    const std::optional<parser::IntegerTypeSpec> &spec) {
-  std::optional<parser::KindSelector> empty;
-  evaluate::Expr<evaluate::SubscriptInteger> kind{AnalyzeKindSelector(
-      context_, TypeCategory::Integer, spec ? spec->v : empty)};
-  if (auto value{evaluate::ToInt64(kind)}) {
-    return static_cast<int>(*value);
-  } else {
-    Say("Kind of INTEGER type must be a constant value"_err_en_US);
-    return context_.defaultKinds().GetDefaultKind(TypeCategory::Integer);
+  void AssignmentContext::Analyze(const parser::ConcurrentHeader &header) {
+    CHECK(forall_ != nullptr);
+    forall_->integerKind = GetIntegerKind(
+        std::get<std::optional<parser::IntegerTypeSpec>>(header.t));
+    for (const auto &control :
+        std::get<std::list<parser::ConcurrentControl>>(header.t)) {
+      const parser::CharBlock &name{std::get<parser::Name>(control.t).source};
+      bool inserted{forall_->activeNames.insert(name).second};
+      CHECK(inserted);
+    }
   }
-}
 
-MaskExpr AssignmentContext::GetMask(
-    const parser::LogicalExpr &expr, bool defaultValue) const {
-  MaskExpr mask{defaultValue};
-  if (auto maybeExpr{AnalyzeExpr(context_, expr)}) {
-    auto *logical{
-        std::get_if<evaluate::Expr<evaluate::SomeLogical>>(&maybeExpr->u)};
-    CHECK(logical != nullptr);
-    mask = evaluate::ConvertTo(mask, std::move(*logical));
+  int AssignmentContext::GetIntegerKind(
+      const std::optional<parser::IntegerTypeSpec> &spec) {
+    std::optional<parser::KindSelector> empty;
+    evaluate::Expr<evaluate::SubscriptInteger> kind{AnalyzeKindSelector(
+        context_, TypeCategory::Integer, spec ? spec->v : empty)};
+    if (auto value{evaluate::ToInt64(kind)}) {
+      return static_cast<int>(*value);
+    } else {
+      Say("Kind of INTEGER type must be a constant value"_err_en_US);
+      return context_.defaultKinds().GetDefaultKind(TypeCategory::Integer);
+    }
   }
-  return mask;
-}
-
-void AnalyzeConcurrentHeader(
-    SemanticsContext &context, const parser::ConcurrentHeader &header) {
-  AssignmentContext{context}.Analyze(header);
-}
-
-AssignmentChecker::~AssignmentChecker() = default;
 
-AssignmentChecker::AssignmentChecker(SemanticsContext &context)
-  : context_{new AssignmentContext{context}} {}
-void AssignmentChecker::Enter(const parser::AssignmentStmt &x) {
-  context_.value().Analyze(x);
-}
-void AssignmentChecker::Enter(const parser::PointerAssignmentStmt &x) {
-  context_.value().Analyze(x);
-}
-void AssignmentChecker::Enter(const parser::WhereStmt &x) {
-  context_.value().Analyze(x);
-}
-void AssignmentChecker::Enter(const parser::WhereConstruct &x) {
-  context_.value().Analyze(x);
-}
-void AssignmentChecker::Enter(const parser::ForallStmt &x) {
-  context_.value().Analyze(x);
-}
-void AssignmentChecker::Enter(const parser::ForallConstruct &x) {
-  context_.value().Analyze(x);
-}
+  MaskExpr AssignmentContext::GetMask(
+      const parser::LogicalExpr &expr, bool defaultValue) const {
+    MaskExpr mask{defaultValue};
+    if (auto maybeExpr{AnalyzeExpr(context_, expr)}) {
+      auto *logical{
+          std::get_if<evaluate::Expr<evaluate::SomeLogical>>(&maybeExpr->u)};
+      CHECK(logical != nullptr);
+      mask = evaluate::ConvertTo(mask, std::move(*logical));
+    }
+    return mask;
+  }
 
-namespace {
-class Visitor {
-public:
-  Visitor(SemanticsContext &context) : context_{context} {}
+  void AnalyzeConcurrentHeader(
+      SemanticsContext & context, const parser::ConcurrentHeader &header) {
+    AssignmentContext{context}.Analyze(header);
+  }
 
-  template<typename A> bool Pre(const A &) { return true /* visit children */; }
-  template<typename A> void Post(const A &) {}
+  AssignmentChecker::~AssignmentChecker() = default;
 
-  bool Pre(const parser::Statement<parser::AssignmentStmt> &stmt) {
-    AssignmentContext{context_, stmt.source}.Analyze(stmt.statement);
-    return false;
+  AssignmentChecker::AssignmentChecker(SemanticsContext & context)
+    : context_{new AssignmentContext{context}} {}
+  void AssignmentChecker::Enter(const parser::AssignmentStmt &x) {
+    context_.value().Analyze(x);
   }
-  bool Pre(const parser::Statement<parser::PointerAssignmentStmt> &stmt) {
-    AssignmentContext{context_, stmt.source}.Analyze(stmt.statement);
-    return false;
+  void AssignmentChecker::Enter(const parser::PointerAssignmentStmt &x) {
+    context_.value().Analyze(x);
   }
-  bool Pre(const parser::Statement<parser::WhereStmt> &stmt) {
-    AssignmentContext{context_, stmt.source}.Analyze(stmt.statement);
-    return false;
+  void AssignmentChecker::Enter(const parser::WhereStmt &x) {
+    context_.value().Analyze(x);
   }
-  bool Pre(const parser::WhereConstruct &construct) {
-    AssignmentContext{context_}.Analyze(construct);
-    return false;
+  void AssignmentChecker::Enter(const parser::WhereConstruct &x) {
+    context_.value().Analyze(x);
   }
-  bool Pre(const parser::Statement<parser::ForallStmt> &stmt) {
-    AssignmentContext{context_, stmt.source}.Analyze(stmt.statement);
-    return false;
+  void AssignmentChecker::Enter(const parser::ForallStmt &x) {
+    context_.value().Analyze(x);
   }
-  bool Pre(const parser::ForallConstruct &construct) {
-    AssignmentContext{context_}.Analyze(construct);
-    return false;
+  void AssignmentChecker::Enter(const parser::ForallConstruct &x) {
+    context_.value().Analyze(x);
   }
 
-private:
-  SemanticsContext &context_;
-};
+  namespace {
+  class Visitor {
+  public:
+    Visitor(SemanticsContext &context) : context_{context} {}
 
-}
+    template<typename A> bool Pre(const A &) {
+      return true /* visit children */;
+    }
+    template<typename A> void Post(const A &) {}
+
+    bool Pre(const parser::Statement<parser::AssignmentStmt> &stmt) {
+      AssignmentContext{context_, stmt.source}.Analyze(stmt.statement);
+      return false;
+    }
+    bool Pre(const parser::Statement<parser::PointerAssignmentStmt> &stmt) {
+      AssignmentContext{context_, stmt.source}.Analyze(stmt.statement);
+      return false;
+    }
+    bool Pre(const parser::Statement<parser::WhereStmt> &stmt) {
+      AssignmentContext{context_, stmt.source}.Analyze(stmt.statement);
+      return false;
+    }
+    bool Pre(const parser::WhereConstruct &construct) {
+      AssignmentContext{context_}.Analyze(construct);
+      return false;
+    }
+    bool Pre(const parser::Statement<parser::ForallStmt> &stmt) {
+      AssignmentContext{context_, stmt.source}.Analyze(stmt.statement);
+      return false;
+    }
+    bool Pre(const parser::ForallConstruct &construct) {
+      AssignmentContext{context_}.Analyze(construct);
+      return false;
+    }
+
+  private:
+    SemanticsContext &context_;
+  };
+
+  }
 
 }  // namespace Fortran::semantics
diff --git a/flang/lib/semantics/check-if-stmt.cc b/flang/lib/semantics/check-if-stmt.cc
index 09ce6d6..bd2f8e6 100644
--- a/flang/lib/semantics/check-if-stmt.cc
+++ b/flang/lib/semantics/check-if-stmt.cc
@@ -26,13 +26,13 @@ void IfStmtChecker::Leave(const parser::IfStmt &ifStmt) {
   auto &expr{std::get<parser::ScalarLogicalExpr>(ifStmt.t).thing.thing.value()};
   CheckScalarLogicalExpr(expr, context_.messages());
   // C1143 Check that the action stmt is not an if stmt
-  auto &actionStmt{std::get<parser::ActionStmt>(ifStmt.t)};
+  const auto &body{std::get<parser::UnlabeledStmt>(ifStmt.t)};
+  const auto &actionStmt{body.statement};
   if (auto *actionIfStmt{
           std::get_if<common::Indirection<parser::IfStmt>>(&actionStmt.u)}) {
-    // TODO: get the source position from the action stmt
     suppress_unused_variable_warning(actionIfStmt);
     context_.messages().Say(
-        expr.source, "IF statement is not allowed in IF statement"_err_en_US);
+        body.source, "IF statement is not allowed in IF statement"_err_en_US);
   }
 }
 
-- 
2.7.4