From 8a4b595bf63cf219dda4686617761ff1c4685bf9 Mon Sep 17 00:00:00 2001
From: Jean Perier <jperier@nvidia.com>
Date: Tue, 9 Jul 2019 10:40:14 -0700
Subject: [PATCH] [flang] Answer comments * Support target label of label-do on
 all executable constructs as well as   forall and where. * Re-oder and rename
 related checks in resolve-labels.cc

Original-commit: flang-compiler/f18@e5ac8a1660511a7e48f0b2075f87ca1d8dbe23d9
Reviewed-on: https://github.com/flang-compiler/f18/pull/552
Tree-same-pre-rewrite: false
---
 flang/lib/semantics/canonicalize-do.cc |  34 ++++++++--
 flang/lib/semantics/resolve-labels.cc  |  66 +++++++++---------
 flang/test/semantics/label14.f90       | 119 ++++++++++++++++++++++++++++++---
 3 files changed, 172 insertions(+), 47 deletions(-)

diff --git a/flang/lib/semantics/canonicalize-do.cc b/flang/lib/semantics/canonicalize-do.cc
index 9f70fbf..995e100 100644
--- a/flang/lib/semantics/canonicalize-do.cc
+++ b/flang/lib/semantics/canonicalize-do.cc
@@ -34,16 +34,34 @@ public:
             common::visitors{
                 [](auto &) {},
                 // Labels on end-stmt of constructs are accepted by f18 for
-                // compatibility purposes, even-though they are technically
-                // not in the same scope as the label-do-stmt.
-                [&](common::Indirection<IfConstruct> &ifConstruct) {
+                // as an extension.
+                [&](common::Indirection<AssociateConstruct> &associate) {
                   CanonicalizeIfMatch(block, stack, i,
-                      std::get<Statement<EndIfStmt>>(ifConstruct.value().t));
+                      std::get<Statement<EndAssociateStmt>>(
+                          associate.value().t));
+                },
+                [&](common::Indirection<BlockConstruct> &blockConstruct) {
+                  CanonicalizeIfMatch(block, stack, i,
+                      std::get<Statement<EndBlockStmt>>(
+                          blockConstruct.value().t));
+                },
+                [&](common::Indirection<ChangeTeamConstruct> &changeTeam) {
+                  CanonicalizeIfMatch(block, stack, i,
+                      std::get<Statement<EndChangeTeamStmt>>(
+                          changeTeam.value().t));
+                },
+                [&](common::Indirection<CriticalConstruct> &critical) {
+                  CanonicalizeIfMatch(block, stack, i,
+                      std::get<Statement<EndCriticalStmt>>(critical.value().t));
                 },
                 [&](common::Indirection<DoConstruct> &doConstruct) {
                   CanonicalizeIfMatch(block, stack, i,
                       std::get<Statement<EndDoStmt>>(doConstruct.value().t));
                 },
+                [&](common::Indirection<IfConstruct> &ifConstruct) {
+                  CanonicalizeIfMatch(block, stack, i,
+                      std::get<Statement<EndIfStmt>>(ifConstruct.value().t));
+                },
                 [&](common::Indirection<CaseConstruct> &caseConstruct) {
                   CanonicalizeIfMatch(block, stack, i,
                       std::get<Statement<EndSelectStmt>>(
@@ -57,6 +75,14 @@ public:
                   CanonicalizeIfMatch(block, stack, i,
                       std::get<Statement<EndSelectStmt>>(selectType.value().t));
                 },
+                [&](common::Indirection<ForallConstruct> &forall) {
+                  CanonicalizeIfMatch(block, stack, i,
+                      std::get<Statement<EndForallStmt>>(forall.value().t));
+                },
+                [&](common::Indirection<WhereConstruct> &where) {
+                  CanonicalizeIfMatch(block, stack, i,
+                      std::get<Statement<EndWhereStmt>>(where.value().t));
+                },
                 [&](Statement<common::Indirection<LabelDoStmt>> &labelDoStmt) {
                   auto &label{std::get<Label>(labelDoStmt.statement.value().t)};
                   stack.push_back(LabelInfo{i, label});
diff --git a/flang/lib/semantics/resolve-labels.cc b/flang/lib/semantics/resolve-labels.cc
index e5b3b74..8fda3f6 100644
--- a/flang/lib/semantics/resolve-labels.cc
+++ b/flang/lib/semantics/resolve-labels.cc
@@ -38,7 +38,7 @@ struct LabeledStatementInfoTuplePOD {
   ProxyForScope proxyForScope;
   parser::CharBlock parserCharBlock;
   LabeledStmtClassificationSet labeledStmtClassificationSet;
-  bool legacyAcceptedInDirectSubscope;
+  bool isExecutableConstructEndStmt;
 };
 using TargetStmtMap = std::map<parser::Label, LabeledStatementInfoTuplePOD>;
 struct SourceStatementInfoTuplePOD {
@@ -62,6 +62,12 @@ constexpr Legality IsLegalDoTerm(const parser::Statement<A> &) {
   if (std::is_same_v<A, common::Indirection<parser::EndDoStmt>> ||
       std::is_same_v<A, parser::EndDoStmt>) {
     return Legality::always;
+  } else if (std::is_same_v<A, parser::EndForallStmt> ||
+      std::is_same_v<A, parser::EndWhereStmt>) {
+    // Executable construct end statements are also supported as
+    // an extension but they need special care because the associated
+    // construct create there own scope.
+    return Legality::formerly;
   } else {
     return Legality::never;
   }
@@ -210,13 +216,13 @@ const parser::CharBlock *GetStmtName(const parser::Statement<A> &stmt) {
   return nullptr;
 }
 
+using ExecutableConstructEndStmts = std::tuple<parser::EndIfStmt,
+    parser::EndDoStmt, parser::EndSelectStmt, parser::EndChangeTeamStmt,
+    parser::EndBlockStmt, parser::EndCriticalStmt, parser::EndAssociateStmt>;
+
 template<typename A>
-static constexpr bool LabelDoTargetAcceptedInDirectSubscopeOn(
-    const parser::Statement<A> &statement) {
-  return (std::is_same_v<A, parser::EndIfStmt> ||
-      std::is_same_v<A, parser::EndDoStmt> ||
-      std::is_same_v<A, parser::EndSelectStmt>);
-}
+static constexpr bool IsExecutableConstructEndStmt{
+    common::HasMember<A, ExecutableConstructEndStmts>};
 
 class ParseTreeAnalyzer {
 public:
@@ -232,7 +238,6 @@ public:
     if (statement.label.has_value()) {
       auto label{statement.label.value()};
       auto targetFlags{ConstructBranchTargetFlags(statement)};
-      bool canBeParentLabel{LabelDoTargetAcceptedInDirectSubscopeOn(statement)};
       if constexpr (std::is_same_v<A, parser::AssociateStmt> ||
           std::is_same_v<A, parser::BlockStmt> ||
           std::is_same_v<A, parser::ChangeTeamStmt> ||
@@ -244,11 +249,11 @@ public:
           std::is_same_v<A, parser::SelectTypeStmt>) {
         constexpr bool useParent{true};
         AddTargetLabelDefinition(
-            useParent, label, targetFlags, canBeParentLabel);
+            useParent, label, targetFlags, IsExecutableConstructEndStmt<A>);
       } else {
         constexpr bool useParent{false};
         AddTargetLabelDefinition(
-            useParent, label, targetFlags, canBeParentLabel);
+            useParent, label, targetFlags, IsExecutableConstructEndStmt<A>);
       }
     }
     return true;
@@ -750,12 +755,12 @@ private:
   // 6.2.5., paragraph 2
   void AddTargetLabelDefinition(bool useParent, parser::Label label,
       LabeledStmtClassificationSet labeledStmtClassificationSet,
-      bool legacyAcceptedInDirectSubscope) {
+      bool isExecutableConstructEndStmt) {
     CheckLabelInRange(label);
     const auto pair{programUnits_.back().targetStmts.emplace(label,
         LabeledStatementInfoTuplePOD{
             (useParent ? ParentScope() : currentScope_), currentPosition_,
-            labeledStmtClassificationSet, legacyAcceptedInDirectSubscope})};
+            labeledStmtClassificationSet, isExecutableConstructEndStmt})};
     if (!pair.second) {
       errorHandler_.Say(currentPosition_,
           parser::MessageFormattedText{
@@ -905,30 +910,25 @@ void CheckLabelDoConstraints(const SourceStmtList &dos,
           parser::MessageFormattedText{
               "label '%u' doesn't lexically follow DO stmt"_err_en_US,
               SayLabel(label)});
+
+    } else if ((InInclusiveScope(scopes, scope, doTarget.proxyForScope) &&
+                   doTarget.labeledStmtClassificationSet.test(
+                       TargetStatementEnum::CompatibleDo)) ||
+        (doTarget.isExecutableConstructEndStmt &&
+            ParentScope(scopes, doTarget.proxyForScope) == scope)) {
+      // Accepted for legacy support
+      errorHandler.Say(doTarget.parserCharBlock,
+          parser::MessageFormattedText{
+              "A DO loop should terminate with an END DO or CONTINUE"_en_US});
     } else if (!InInclusiveScope(scopes, scope, doTarget.proxyForScope)) {
-      // C1133
-      if (doTarget.legacyAcceptedInDirectSubscope &&
-          ParentScope(scopes, doTarget.proxyForScope) == scope) {
-        errorHandler.Say(doTarget.parserCharBlock,
-            parser::MessageFormattedText{
-                "A DO loop should terminate with an END DO or CONTINUE inside its scope"_en_US});
-      } else {
-        errorHandler.Say(position,
-            parser::MessageFormattedText{
-                "label '%u' is not in scope"_err_en_US, SayLabel(label)});
-      }
+      errorHandler.Say(position,
+          parser::MessageFormattedText{
+              "label '%u' is not in DO loop scope"_err_en_US, SayLabel(label)});
     } else if (!doTarget.labeledStmtClassificationSet.test(
                    TargetStatementEnum::Do)) {
-      if (!doTarget.labeledStmtClassificationSet.test(
-              TargetStatementEnum::CompatibleDo)) {
-        errorHandler.Say(doTarget.parserCharBlock,
-            parser::MessageFormattedText{
-                "A DO loop should terminate with an END DO or CONTINUE"_err_en_US});
-      } else {
-        errorHandler.Say(doTarget.parserCharBlock,
-            parser::MessageFormattedText{
-                "A DO loop should terminate with an END DO or CONTINUE"_en_US});
-      }
+      errorHandler.Say(doTarget.parserCharBlock,
+          parser::MessageFormattedText{
+              "A DO loop should terminate with an END DO or CONTINUE"_err_en_US});
     } else {
       loopBodies.emplace_back(SkipLabel(position), doTarget.parserCharBlock);
     }
diff --git a/flang/test/semantics/label14.f90 b/flang/test/semantics/label14.f90
index 36f582f..9b3666f 100644
--- a/flang/test/semantics/label14.f90
+++ b/flang/test/semantics/label14.f90
@@ -13,22 +13,121 @@
 ! limitations under the License.
 
 ! RUN: ${F18} -funparse-with-symbols %s 2>&1 | ${FileCheck} %s
-! CHECK: A DO loop should terminate with an END DO or CONTINUE inside its scope
-! CHECK: A DO loop should terminate with an END DO or CONTINUE inside its scope
-! CHECK: A DO loop should terminate with an END DO or CONTINUE inside its scope
 
+module iso_fortran_env
+  type :: team_type
+  end type
+end
+
+subroutine foo0()
   do 1 j=1,2
     if (.true.) then
+! CHECK: A DO loop should terminate with an END DO or CONTINUE
 1   end if
   do 2 k=1,2
     do i=3,4
       print*, i+k
+! CHECK: A DO loop should terminate with an END DO or CONTINUE
 2    end do
   do 3 l=1,2
-    select case (l)
-    case default
-      print*, "default"
-    case (1)
-      print*, "start"
-3    end select
-  end
+    do 3 m=1,2
+      select case (l)
+      case default
+        print*, "default", m, l
+      case (1)
+        print*, "start"
+! CHECK: A DO loop should terminate with an END DO or CONTINUE
+! CHECK: A DO loop should terminate with an END DO or CONTINUE
+3     end select
+end subroutine
+
+subroutine foo1()
+  real :: a(10, 10), b(10, 10) = 1.0
+  do 4 k=1,2
+    forall (i = 1:10, j = 1:10, b(i, j) /= 0.0)
+      a(i, j) = real (i + j - k)
+      b(i, j) = a(i, j) + b(i, j) * real (i * j)
+! CHECK: A DO loop should terminate with an END DO or CONTINUE
+4   end forall
+end subroutine
+
+subroutine foo2()
+  real :: a(10, 10), b(10, 10) = 1.0
+  do 4 k=1,4
+    where (a<k)
+      a = a + b
+      b = a - b
+    elsewhere
+      a = a*2
+! CHECK: A DO loop should terminate with an END DO or CONTINUE
+4   end where
+end subroutine
+
+subroutine foo3()
+  real :: a(10, 10), b(10, 10) = 1.0
+  do 4 k=1,4
+    associate (x=>a(k+1, 2*k), y=>b(k, 2*k-1))
+      x = 4*x*x + x*y -2*y
+! CHECK: A DO loop should terminate with an END DO or CONTINUE
+4   end associate
+end subroutine
+
+subroutine foo4()
+  real :: a(10, 10), b(10, 10) = 1.0
+  do 4 k=1,4
+    block
+      real b
+      b = a(k, k)
+      a(k, k) = k*b
+! CHECK: A DO loop should terminate with an END DO or CONTINUE
+4   end block
+end subroutine
+
+subroutine foo5()
+  real :: a(10, 10), b(10, 10) = 1.0
+  do 4 k=1,4
+    critical
+      b(k+1, k) = a(k, k+1)
+! CHECK: A DO loop should terminate with an END DO or CONTINUE
+4   end critical
+end subroutine
+
+subroutine foo6(a)
+  type whatever
+    class(*), allocatable :: x
+  end type
+  type(whatever) :: a(10)
+  do 4 k=1,10
+    select type (ax => a(k)%x)
+      type is (integer)
+        print*, "integer: ", ax
+      class default
+        print*, "not useable"
+! CHECK: A DO loop should terminate with an END DO or CONTINUE
+4   end select
+end subroutine
+
+subroutine foo7(a)
+  integer :: a(..)
+  do 4 k=1,10
+    select rank (a)
+      rank (0)
+        a = a+k
+      rank (1)
+        a(k) = a(k)+k
+      rank default
+        print*, "error"
+! CHECK: A DO loop should terminate with an END DO or CONTINUE
+4   end select
+end subroutine
+
+subroutine foo8()
+  use  :: iso_fortran_env, only : team_type
+  type(team_type) :: odd_even
+  do 1 k=1,10
+    change team (odd_even)
+! CHECK: A DO loop should terminate with an END DO or CONTINUE
+1   end team
+end subroutine
+
+end
-- 
2.7.4