[flang] Fix construct names on labeled DO

flang/include/flang/Parser/parse-tree.h

@@ -2259,15 +2259,18 @@ struct LoopControl {
 };
 
 // R1121 label-do-stmt -> [do-construct-name :] DO label [loop-control]
+// A label-do-stmt with a do-construct-name is parsed as a non-label-do-stmt.
 struct LabelDoStmt {
   TUPLE_CLASS_BOILERPLATE(LabelDoStmt);
-  std::tuple<std::optional<Name>, Label, std::optional<LoopControl>> t;
+  std::tuple<Label, std::optional<LoopControl>> t;
 };
 
 // R1122 nonlabel-do-stmt -> [do-construct-name :] DO [loop-control]
 struct NonLabelDoStmt {
   TUPLE_CLASS_BOILERPLATE(NonLabelDoStmt);
-  std::tuple<std::optional<Name>, std::optional<LoopControl>> t;
+  std::tuple<std::optional<Name>, std::optional<Label>,
+      std::optional<LoopControl>>
+      t;
 };
 
 // R1132 end-do-stmt -> END DO [do-construct-name]

flang/lib/Parser/executable-parsers.cpp

@@ -279,13 +279,17 @@ TYPE_CONTEXT_PARSER("loop control"_en_US,
                 many(Parser<LocalitySpec>{})))))
 
 // R1121 label-do-stmt -> [do-construct-name :] DO label [loop-control]
+// A label-do-stmt with a do-construct-name is parsed as a nonlabel-do-stmt
+// with an optional label.
 TYPE_CONTEXT_PARSER("label DO statement"_en_US,
-    construct<LabelDoStmt>(
-        maybe(name / ":"), "DO" >> label, maybe(loopControl)))
+    construct<LabelDoStmt>("DO" >> label, maybe(loopControl)))
 
 // R1122 nonlabel-do-stmt -> [do-construct-name :] DO [loop-control]
 TYPE_CONTEXT_PARSER("nonlabel DO statement"_en_US,
-    construct<NonLabelDoStmt>(maybe(name / ":"), "DO" >> maybe(loopControl)))
+    construct<NonLabelDoStmt>(
+        name / ":", "DO" >> maybe(label), maybe(loopControl)) ||
+        construct<NonLabelDoStmt>(construct<std::optional<Name>>(),
+            construct<std::optional<Label>>(), "DO" >> maybe(loopControl)))
 
 // R1132 end-do-stmt -> END DO [do-construct-name]
 TYPE_CONTEXT_PARSER("END DO statement"_en_US,

flang/lib/Parser/unparse.cpp

@@ -1001,13 +1001,14 @@ class UnparseVisitor {
     Walk(std::get<Statement<EndDoStmt>>(x.t));
   }
   void Unparse(const LabelDoStmt &x) { // R1121
-    Walk(std::get<std::optional<Name>>(x.t), ": ");
     Word("DO "), Walk(std::get<Label>(x.t));
     Walk(" ", std::get<std::optional<LoopControl>>(x.t));
   }
   void Unparse(const NonLabelDoStmt &x) { // R1122
     Walk(std::get<std::optional<Name>>(x.t), ": ");
-    Word("DO "), Walk(std::get<std::optional<LoopControl>>(x.t));
+    Word("DO ");
+    Walk(std::get<std::optional<Label>>(x.t), " ");
+    Walk(std::get<std::optional<LoopControl>>(x.t));
   }
   void Unparse(const LoopControl &x) { // R1123
     common::visit(common::visitors{

flang/lib/Semantics/canonicalize-do.cpp

@@ -117,16 +117,15 @@ class CanonicalizationOfDoLoops {
             std::get<ExecutableConstruct>(doLoop->u).u)};
         auto &loopControl{
             std::get<std::optional<LoopControl>>(labelDo.statement.value().t)};
-        auto &name{std::get<std::optional<Name>>(labelDo.statement.value().t)};
         Statement<NonLabelDoStmt> nonLabelDoStmt{std::move(labelDo.label),
-            NonLabelDoStmt{
-                std::make_tuple(common::Clone(name), std::move(loopControl))}};
+            NonLabelDoStmt{std::make_tuple(std::optional<Name>{},
+                std::optional<Label>{}, std::move(loopControl))}};
         nonLabelDoStmt.source = originalSource;
         std::get<ExecutableConstruct>(doLoop->u).u =
             common::Indirection<DoConstruct>{
                 std::make_tuple(std::move(nonLabelDoStmt), std::move(block),
-                    Statement<EndDoStmt>{
-                        std::optional<Label>{}, EndDoStmt{std::move(name)}})};
+                    Statement<EndDoStmt>{std::optional<Label>{},
+                        EndDoStmt{std::optional<Name>{}}})};
         stack.pop_back();
       } while (!stack.empty() && stack.back().label == currentLabel);
       i = --next;

flang/lib/Semantics/resolve-labels.cpp

@@ -275,7 +275,29 @@ class ParseTreeAnalyzer {
     return PushConstructName(criticalConstruct);
   }
   bool Pre(const parser::DoConstruct &doConstruct) {
-    return PushConstructName(doConstruct);
+    const auto &optionalName{std::get<std::optional<parser::Name>>(
+        std::get<parser::Statement<parser::NonLabelDoStmt>>(doConstruct.t)
+            .statement.t)};
+    if (optionalName) {
+      constructNames_.emplace_back(optionalName->ToString());
+    }
+    // Allow FORTRAN '66 extended DO ranges
+    PushScope().isExteriorGotoFatal = false;
+    // Process labels of the DO and END DO statements, but not the
+    // statements themselves, so that a non-construct END DO
+    // can be distinguished (below).
+    Pre(std::get<parser::Statement<parser::NonLabelDoStmt>>(doConstruct.t));
+    Walk(std::get<parser::Block>(doConstruct.t), *this);
+    Pre(std::get<parser::Statement<parser::EndDoStmt>>(doConstruct.t));
+    PopConstructName(doConstruct);
+    return false;
+  }
+  void Post(const parser::EndDoStmt &endDoStmt) {
+    // Visited only for non-construct labeled DO termination
+    if (const auto &name{endDoStmt.v}) {
+      context_.Say(name->source, "Unexpected DO construct name '%s'"_err_en_US,
+          name->source);
+    }
   }
   bool Pre(const parser::IfConstruct &ifConstruct) {
     return PushConstructName(ifConstruct);
@@ -330,9 +352,6 @@ class ParseTreeAnalyzer {
   void Post(const parser::CriticalConstruct &criticalConstruct) {
     PopConstructName(criticalConstruct);
   }
-  void Post(const parser::DoConstruct &doConstruct) {
-    PopConstructName(doConstruct);
-  }
   void Post(const parser::IfConstruct &ifConstruct) {
     PopConstructName(ifConstruct);
   }
@@ -716,6 +735,22 @@ class ParseTreeAnalyzer {
   // C1131
   void CheckName(const parser::DoConstruct &doConstruct) {
     CheckEndName<parser::NonLabelDoStmt, parser::EndDoStmt>("DO", doConstruct);
+    if (auto label{std::get<std::optional<parser::Label>>(
+            std::get<parser::Statement<parser::NonLabelDoStmt>>(doConstruct.t)
+                .statement.t)}) {
+      const auto &endDoStmt{
+          std::get<parser::Statement<parser::EndDoStmt>>(doConstruct.t)};
+      if (!endDoStmt.label || *endDoStmt.label != *label) {
+        context_
+            .Say(endDoStmt.source,
+                "END DO statement must have the label '%d' matching its DO statement"_err_en_US,
+                *label)
+            .Attach(std::get<parser::Statement<parser::NonLabelDoStmt>>(
+                        doConstruct.t)
+                        .source,
+                "corresponding DO statement"_en_US);
+      }
+    }
   }
   // C1035
   void CheckName(const parser::ForallConstruct &forallConstruct) {

flang/test/Semantics/dosemantics13.f90

@@ -0,0 +1,29 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+program main
+
+  integer j, k
+
+  lab1: do j=1,10
+    cycle lab1
+    exit lab1
+  end do lab1
+
+  lab2: do 2 j=1,10
+    cycle lab2
+    exit lab2
+  2 end do lab2
+
+  lab3: do 3 j=1,10
+    cycle lab3
+    exit lab3
+    !ERROR: DO construct name required but missing
+  3 end do
+
+  do 4 j=1,10
+  !ERROR: Unexpected DO construct name 'lab4'
+  4 end do lab4
+
+  lab5: do 5 j=1,10
+  !ERROR: END DO statement must have the label '5' matching its DO statement
+  666 end do lab5
+end

flang/test/Semantics/dosemantics14.f90

@@ -0,0 +1,12 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+subroutine bad1
+  lab1: do 1 j=1,10
+  1 continue
+!ERROR: expected 'END DO'
+end
+
+subroutine bad2
+  lab2: do 2 j=1,10
+  2 k = j
+!ERROR: expected 'END DO'
+end