[flang] C1167 : Check for exit statments in do-concurrent

Addresses flang-compiler/f18#288

Original-commit: flang-compiler/f18@2a99e1e
Reviewed-on: flang-compiler/f18#345

flang/lib/semantics/check-do-concurrent.cc

@@ -40,6 +40,7 @@ class DoConcurrentEnforcement {
 public:
   DoConcurrentEnforcement(parser::Messages &messages) : messages_{messages} {}
   std::set<parser::Label> labels() { return labels_; }
+  std::set<parser::CharBlock> names() { return names_; }
   template<typename T> bool Pre(const T &) { return true; }
   template<typename T> void Post(const T &) {}
   template<typename T> bool Pre(const parser::Statement<T> &statement) {
@@ -49,6 +50,47 @@ class DoConcurrentEnforcement {
     }
     return true;
   }
+  // C1167
+  bool Pre(const parser::WhereConstructStmt &s) {
+    addName(std::get<std::optional<parser::Name>>(s.t));
+    return true;
+  }
+  bool Pre(const parser::ForallConstructStmt &s) {
+    addName(std::get<std::optional<parser::Name>>(s.t));
+    return true;
+  }
+  bool Pre(const parser::ChangeTeamStmt &s) {
+    addName(std::get<std::optional<parser::Name>>(s.t));
+    return true;
+  }
+  bool Pre(const parser::CriticalStmt &s) {
+    addName(std::get<std::optional<parser::Name>>(s.t));
+    return true;
+  }
+  bool Pre(const parser::LabelDoStmt &s) {
+    addName(std::get<std::optional<parser::Name>>(s.t));
+    return true;
+  }
+  bool Pre(const parser::NonLabelDoStmt &s) {
+    addName(std::get<std::optional<parser::Name>>(s.t));
+    return true;
+  }
+  bool Pre(const parser::IfThenStmt &s) {
+    addName(std::get<std::optional<parser::Name>>(s.t));
+    return true;
+  }
+  bool Pre(const parser::SelectCaseStmt &s) {
+    addName(std::get<std::optional<parser::Name>>(s.t));
+    return true;
+  }
+  bool Pre(const parser::SelectRankStmt &s) {
+    addName(std::get<0>(s.t));
+    return true;
+  }
+  bool Pre(const parser::SelectTypeStmt &s) {
+    addName(std::get<0>(s.t));
+    return true;
+  }
   // C1136
   void Post(const parser::ReturnStmt &) {
     messages_.Say(currentStatementSourcePosition_,
@@ -160,25 +202,38 @@ class DoConcurrentEnforcement {
     }
     return false;
   }
+  void addName(const std::optional<parser::Name> &nm) {
+    if (nm.has_value()) {
+      names_.insert(nm.value().source);
+    }
+  }
 
+  std::set<parser::CharBlock> names_;
   std::set<parser::Label> labels_;
   parser::CharBlock currentStatementSourcePosition_;
   parser::Messages &messages_;
 };
 
 class DoConcurrentLabelEnforce {
 public:
-  DoConcurrentLabelEnforce(
-      parser::Messages &messages, std::set<parser::Label> &&labels)
-    : messages_{messages}, labels_{labels} {}
+  DoConcurrentLabelEnforce(parser::Messages &messages,
+      std::set<parser::Label> &&labels, std::set<parser::CharBlock> &&names,
+      parser::CharBlock doConcurrentSourcePosition)
+    : messages_{messages}, labels_{labels}, names_{names},
+      doConcurrentSourcePosition_{doConcurrentSourcePosition} {}
   template<typename T> bool Pre(const T &) { return true; }
   template<typename T> bool Pre(const parser::Statement<T> &statement) {
     currentStatementSourcePosition_ = statement.source;
     return true;
   }
+  bool Pre(const parser::DoConstruct &) {
+    ++do_depth_;
+    return true;
+  }
   template<typename T> void Post(const T &) {}
 
   // C1138: branch from within a DO CONCURRENT shall not target outside loop
+  void Post(const parser::ExitStmt &exitStmt) { checkName(exitStmt.v); }
   void Post(const parser::GotoStmt &gotoStmt) { checkLabelUse(gotoStmt.v); }
   void Post(const parser::ComputedGotoStmt &computedGotoStmt) {
     for (auto &i : std::get<std::list<parser::Label>>(computedGotoStmt.t)) {
@@ -204,6 +259,23 @@ class DoConcurrentLabelEnforce {
   void Post(const parser::ErrLabel &errLabel) { checkLabelUse(errLabel.v); }
   void Post(const parser::EndLabel &endLabel) { checkLabelUse(endLabel.v); }
   void Post(const parser::EorLabel &eorLabel) { checkLabelUse(eorLabel.v); }
+  void Post(const parser::DoConstruct &) { --do_depth_; }
+  void checkName(const std::optional<parser::Name> &nm) {
+    if (!nm.has_value()) {
+      if (do_depth_ == 0) {
+        messages_.Say(currentStatementSourcePosition_,
+            "exit from DO CONCURRENT construct (%s)"_err_en_US,
+            doConcurrentSourcePosition_.ToString().data());
+      }
+      // nesting of named constructs is assumed to have been previously checked
+      // by the name/label resolution pass
+    } else if (names_.find(nm.value().source) == names_.end()) {
+      messages_.Say(currentStatementSourcePosition_,
+          "exit from DO CONCURRENT construct (%s) to construct with name '%s'"_err_en_US,
+          doConcurrentSourcePosition_.ToString().data(),
+          nm.value().source.ToString().data());
+    }
+  }
   void checkLabelUse(const parser::Label &labelUsed) {
     if (labels_.find(labelUsed) == labels_.end()) {
       messages_.Say(currentStatementSourcePosition_,
@@ -214,7 +286,10 @@ class DoConcurrentLabelEnforce {
 private:
   parser::Messages &messages_;
   std::set<parser::Label> labels_;
+  std::set<parser::CharBlock> names_;
+  int do_depth_{0};
   parser::CharBlock currentStatementSourcePosition_{nullptr};
+  parser::CharBlock doConcurrentSourcePosition_{nullptr};
 };
 
 using CS = std::vector<const Symbol *>;
@@ -339,8 +414,9 @@ class DoConcurrentContext {
         DoConcurrentEnforcement doConcurrentEnforcement{messages_};
         parser::Walk(
             std::get<parser::Block>(doConstruct.t), doConcurrentEnforcement);
-        DoConcurrentLabelEnforce doConcurrentLabelEnforce{
-            messages_, doConcurrentEnforcement.labels()};
+        DoConcurrentLabelEnforce doConcurrentLabelEnforce{messages_,
+            doConcurrentEnforcement.labels(), doConcurrentEnforcement.names(),
+            currentStatementSourcePosition_};
         parser::Walk(
             std::get<parser::Block>(doConstruct.t), doConcurrentLabelEnforce);
         EnforceConcurrentLoopControl(*concurrent);

flang/test/semantics/doconcurrent05.f90

@@ -0,0 +1,66 @@
+! Copyright (c) 2019, Arm Ltd.  All rights reserved.
+!
+! Licensed under the Apache License, Version 2.0 (the "License");
+! you may not use this file except in compliance with the License.
+! You may obtain a copy of the License at
+!
+!     http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+
+! RUN: ${F18} -funparse-with-symbols %s 2>&1 | ${FileCheck} %s
+! CHECK: exit from DO CONCURRENT construct \\(mydoc: do concurrent\\(j=1:n\\)\\) to construct with name 'mydoc'
+! CHECK: exit from DO CONCURRENT construct \\(mydoc: do concurrent\\(j=1:n\\)\\)
+! CHECK: exit from DO CONCURRENT construct \\(mydoc: do concurrent\\(j=1:n\\)\\) to construct with name 'mytest3'
+! CHECK: exit from DO CONCURRENT construct \\(do concurrent\\(k=1:n\\)\\)
+! CHECK: exit from DO CONCURRENT construct \\(do concurrent\\(k=1:n\\)\\) to construct with name 'mytest4'
+! CHECK: exit from DO CONCURRENT construct \\(mydoc: do concurrent\\(j=1:n\\)\\) to construct with name 'mytest4'
+
+subroutine do_concurrent_test1(n)
+  implicit none
+  integer :: n
+  integer :: j,k
+  mydoc: do concurrent(j=1:n)
+  mydo:    do k=1,n
+             if (k==5) exit mydoc
+             if (j==10) exit mydo
+           end do mydo
+         end do mydoc
+end subroutine do_concurrent_test1
+
+subroutine do_concurrent_test2(n)
+  implicit none
+  integer :: j,k,n
+  mydoc: do concurrent(j=1:n)
+           if (k==5) exit
+         end do mydoc
+end subroutine do_concurrent_test2
+
+subroutine do_concurrent_test3(n)
+  implicit none
+  integer :: j,k,n
+  mytest3: if (n>0) then
+  mydoc:    do concurrent(j=1:n)
+              do k=1,n
+                if (j==10) exit mytest3
+              end do
+            end do mydoc
+          end if mytest3
+end subroutine do_concurrent_test3
+
+subroutine do_concurrent_test4(n)
+  implicit none
+  integer :: j,k,n
+  mytest4: if (n>0) then
+  mydoc:    do concurrent(j=1:n)
+              do concurrent(k=1:n)
+                if (k==5) exit
+                if (j==10) exit mytest4
+              end do
+            end do mydoc
+          end if mytest4
+end subroutine do_concurrent_test4

flang/test/semantics/doconcurrent06.f90

@@ -0,0 +1,82 @@
+! Copyright (c) 2019, Arm Ltd.  All rights reserved.
+!
+! Licensed under the Apache License, Version 2.0 (the "License");
+! you may not use this file except in compliance with the License.
+! You may obtain a copy of the License at
+!
+!     http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+
+! RUN: ${F18} -funparse-with-symbols %s 2>&1 | ${FileCheck} %s
+! CHECK: exit from DO CONCURRENT construct \\(nc5: do concurrent\\(i5=1:n\\)\\) to construct with name 'mytest1'
+! CHECK: exit from DO CONCURRENT construct \\(nc3: do concurrent\\(i3=1:n\\)\\) to construct with name 'mytest1'
+! CHECK: exit from DO CONCURRENT construct \\(nc1: do concurrent\\(i1=1:n\\)\\) to construct with name 'mytest1'
+! CHECK: exit from DO CONCURRENT construct \\(nc5: do concurrent\\(i5=1:n\\)\\) to construct with name 'nc3'
+! CHECK: exit from DO CONCURRENT construct \\(nc3: do concurrent\\(i3=1:n\\)\\) to construct with name 'nc3'
+! CHECK: exit from DO CONCURRENT construct \\(nc3: do concurrent\\(i3=1:n\\)\\) to construct with name 'nc2'
+
+subroutine do_concurrent_test1(n)
+  implicit none
+  integer :: i1,i2,i3,i4,i5,i6,n
+  mytest1: if (n>0) then
+  nc1:       do concurrent(i1=1:n)
+  nc2:         do i2=1,n
+  nc3:           do concurrent(i3=1:n)
+  nc4:             do i4=1,n
+  nc5:               do concurrent(i5=1:n)
+  nc6:                 do i6=1,n
+                         if (i6==10) exit mytest1
+                       end do nc6
+                     end do nc5
+                   end do nc4
+                 end do nc3
+               end do nc2
+             end do nc1
+           end if mytest1
+end subroutine do_concurrent_test1
+
+subroutine do_concurrent_test2(n)
+  implicit none
+  integer :: i1,i2,i3,i4,i5,i6,n
+  mytest2: if (n>0) then
+  nc1:       do concurrent(i1=1:n)
+  nc2:         do i2=1,n
+  nc3:           do concurrent(i3=1:n)
+  nc4:             do i4=1,n
+  nc5:               do concurrent(i5=1:n)
+  nc6:                 do i6=1,n
+                         if (i6==10) exit nc3
+                       end do nc6
+                     end do nc5
+                   end do nc4
+                 end do nc3
+               end do nc2
+             end do nc1
+           end if mytest2
+end subroutine do_concurrent_test2
+
+subroutine do_concurrent_test3(n)
+  implicit none
+  integer :: i1,i2,i3,i4,i5,i6,n
+  mytest3: if (n>0) then
+  nc1:       do concurrent(i1=1:n)
+  nc2:         do i2=1,n
+  nc3:           do concurrent(i3=1:n)
+                   if (i3==4) exit nc2
+  nc4:             do i4=1,n
+  nc5:               do concurrent(i5=1:n)
+  nc6:                 do i6=1,n
+                         if (i6==10) print *, "hello"
+                       end do nc6
+                     end do nc5
+                   end do nc4
+                 end do nc3
+               end do nc2
+             end do nc1
+           end if mytest3
+end subroutine do_concurrent_test3

flang/test/semantics/doconcurrent07.f90

@@ -0,0 +1,56 @@
+! Copyright (c) 2019, Arm Ltd.  All rights reserved.
+!
+! Licensed under the Apache License, Version 2.0 (the "License");
+! you may not use this file except in compliance with the License.
+! You may obtain a copy of the License at
+!
+!     http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+
+! RUN: ${F18} -funparse-with-symbols %s 2>&1 | ${FileCheck} %s
+! CHECK-NOT: exit from DO CONCURRENT construct
+
+subroutine do_concurrent_test1(n)
+  implicit none
+  integer :: j,k,l,n
+  mytest: if (n>0) then
+  mydoc:    do concurrent(j=1:n)
+              mydo: do k=1,n
+                      if (k==5) exit
+                      if (k==6) exit mydo
+                    end do mydo
+              do concurrent(l=1:n)
+                if (l==5) print *, "test"
+              end do
+            end do mydoc
+            do k=1,n
+              if (k==5) exit mytest
+            end do
+          end if mytest
+end subroutine do_concurrent_test1
+
+subroutine do_concurrent_test2(n)
+  implicit none
+  integer :: i1,i2,i3,i4,i5,i6,n
+  mytest2: if (n>0) then
+  nc1:       do concurrent(i1=1:n)
+  nc2:         do i2=1,n
+  nc3:           do concurrent(i3=1:n)
+  nc4:             do i4=1,n
+                     if (i3==4) exit nc4
+  nc5:               do concurrent(i5=1:n)
+  nc6:                 do i6=1,n
+                         if (i6==10) print *, "hello"
+                       end do nc6
+                     end do nc5
+                   end do nc4
+                 end do nc3
+               end do nc2
+             end do nc1
+           end if mytest2
+end subroutine do_concurrent_test2