diff --git a/src/Language/Fortran/Parser/Fortran2003.y b/src/Language/Fortran/Parser/Fortran2003.y
index 2a01aa40..02fa6333 100644
--- a/src/Language/Fortran/Parser/Fortran2003.y
+++ b/src/Language/Fortran/Parser/Fortran2003.y
@@ -358,6 +358,7 @@ BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] }
 BLOCK :: { Block A0 }
 : IF_BLOCK MAYBE_COMMENT NEWLINE { $1 }
 | CASE_BLOCK MAYBE_COMMENT NEWLINE { $1 }
+| DO_BLOCK MAYBE_COMMENT NEWLINE { $1 }
 | INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE
   { BlStatement () (getTransSpan $1 $2) (Just $1) $2 }
 | STATEMENT MAYBE_COMMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 }
@@ -368,7 +369,6 @@ BLOCK :: { Block A0 }
 | COMMENT_BLOCK { $1 }
 
 IF_BLOCK :: { Block A0 }
-IF_BLOCK
 :                        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
   { let { startSpan = getSpan $1;
           (endSpan, conds, blocks, endLabel) = $9;
@@ -394,7 +394,6 @@ IF_BLOCK
      in BlIf () span startLabel (Just startName) ((Just $6):conds) ((reverse $11):blocks) endLabel }
 
 ELSE_BLOCKS :: { (SrcSpan, [Maybe (Expression A0)], [[Block A0]], Maybe (Expression A0)) }
-ELSE_BLOCKS
 : maybe(INTEGER_LITERAL) elsif '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
   { let (endSpan, conds, blocks, endLabel) = $10
     in (endSpan, Just $4 : conds, reverse $9 : blocks, endLabel) }
@@ -404,14 +403,12 @@ ELSE_BLOCKS
 | END_IF { let (endSpan, endLabel) = $1 in (endSpan, [], [], endLabel) }
 
 END_IF :: { (SrcSpan, Maybe (Expression A0)) }
-END_IF
 : endif { (getSpan $1, Nothing) }
 | endif id { (getSpan $2, Nothing) }
 | INTEGER_LITERAL endif { (getSpan $2, Just $1) }
 | INTEGER_LITERAL endif id { (getSpan $3, Just $1) }
 
 CASE_BLOCK :: { Block A0 }
-CASE_BLOCK
 :                        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
   { let { (caseRanges, blocks, endLabel, endSpan) = $7;
           span = getTransSpan $1 endSpan }
@@ -454,6 +451,39 @@ END_SELECT :: { (Maybe (Expression A0), SrcSpan) }
 : maybe(INTEGER_LITERAL) endselect maybe(id)
   { ($1, maybe (getSpan $2) getSpan $3) }
 
+DO_BLOCK :: { Block A0 }
+: START_DO                          MAYBE_COMMENT NEWLINE BLOCKS END_DO
+  {% let { (startSpan, startConstruct, startLabel) = $1;
+           (endSpan, endConstruct, endLabel) = $5; }
+      in if startConstruct /= endConstruct
+         then fail $ "Unexpected id for end do " <> show endConstruct <> " at " <> show endSpan
+         else return $ BlDo () (getTransSpan startSpan endSpan) startLabel startConstruct Nothing Nothing (reverse $4) endLabel }
+| START_DO DO_SPECIFICATION         MAYBE_COMMENT NEWLINE BLOCKS END_DO
+  {% let { (startSpan, startConstruct, startLabel) = $1;
+           (endSpan, endConstruct, endLabel) = $6; }
+      in if startConstruct /= endConstruct
+         then fail $ "Unexpected id for end do " <> show endConstruct <> " at " <> show endSpan
+         else return $ BlDo () (getTransSpan startSpan endSpan) startLabel startConstruct Nothing (Just $2) (reverse $5) endLabel }
+| START_DO while '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE BLOCKS END_DO
+  {% let { (startSpan, startConstruct, startLabel) = $1;
+           (endSpan, endConstruct, endLabel) = $9; }
+     in if startConstruct /= endConstruct
+        then fail $ "Unexpected id for end do " <> show endConstruct <> " at " <> show endSpan
+        else return $ BlDoWhile () (getTransSpan startSpan endSpan) startLabel startConstruct Nothing $4 (reverse $8) endLabel
+  }
+
+START_DO :: { (SrcSpan, Maybe String, Maybe (Expression A0)) }
+: do { (getSpan $1, Nothing, Nothing)}
+| id ':' do { let TId s id = $1 in (s, Just id, Nothing) }
+| INTEGER_LITERAL do { (getSpan $1, Nothing, Just $1) }
+| INTEGER_LITERAL id ':' do { let TId _ id = $2 in (getSpan $1, Just id, Just $1) }
+
+END_DO :: { (SrcSpan, Maybe String, Maybe (Expression A0)) }
+: enddo { (getSpan $1, Nothing, Nothing) }
+| INTEGER_LITERAL enddo { (getSpan $2, Nothing, Just $1)}
+| enddo id { let TId s id = $2 in (s, Just id, Nothing)}
+| INTEGER_LITERAL enddo id { let TId s id = $3 in (s, Just id, Just $1) }
+
 ABSTRACTP :: { Bool }
 : abstract { True }
 | {- EMPTY -} { False }
@@ -658,26 +688,13 @@ EXECUTABLE_STATEMENT :: { Statement A0 }
 | endwhere { StEndWhere () (getSpan $1) Nothing }
 | if '(' EXPRESSION ')' INTEGER_LITERAL ',' INTEGER_LITERAL ',' INTEGER_LITERAL
   { StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 }
-| do { StDo () (getSpan $1) Nothing Nothing Nothing }
-| id ':' do
-  { let TId s id = $1
-    in StDo () (getTransSpan s $3) (Just id) Nothing Nothing }
 | do INTEGER_LITERAL MAYBE_COMMA DO_SPECIFICATION
   { StDo () (getTransSpan $1 $4) Nothing (Just $2) (Just $4) }
-| do DO_SPECIFICATION { StDo () (getTransSpan $1 $2) Nothing Nothing (Just $2) }
-| id ':' do DO_SPECIFICATION
-  { let TId s id = $1
-    in StDo () (getTransSpan s $4) (Just id) Nothing (Just $4) }
 | do INTEGER_LITERAL MAYBE_COMMA while '(' EXPRESSION ')'
   { StDoWhile () (getTransSpan $1 $7) Nothing (Just $2) $6 }
-| do while '(' EXPRESSION ')'
-  { StDoWhile () (getTransSpan $1 $5) Nothing Nothing $4 }
-| id ':' do while '(' EXPRESSION ')'
-  { let TId s id = $1
-    in StDoWhile () (getTransSpan s $7) (Just id) Nothing $6 }
-| enddo { StEnddo () (getSpan $1) Nothing }
-| enddo id
-  { let TId s id = $2 in StEnddo () (getTransSpan $1 s) (Just id) }
+-- | enddo { StEnddo () (getSpan $1) Nothing }
+-- | enddo id
+--  { let TId s id = $2 in StEnddo () (getTransSpan $1 s) (Just id) }
 | cycle { StCycle () (getSpan $1) Nothing }
 | cycle VARIABLE { StCycle () (getTransSpan $1 $2) (Just $2) }
 | exit { StExit () (getSpan $1) Nothing }
diff --git a/src/Language/Fortran/Parser/Fortran90.y b/src/Language/Fortran/Parser/Fortran90.y
index 4407bb3b..98227bd4 100644
--- a/src/Language/Fortran/Parser/Fortran90.y
+++ b/src/Language/Fortran/Parser/Fortran90.y
@@ -318,7 +318,6 @@ BLOCK :: { Block A0 }
 | COMMENT_BLOCK { $1 }
 
 IF_BLOCK :: { Block A0 }
-IF_BLOCK
 :                        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
   { let { startSpan = getSpan $1;
           (endSpan, conds, blocks, endLabel) = $9;
@@ -344,7 +343,6 @@ IF_BLOCK
      in BlIf () span startLabel (Just startName) ((Just $6):conds) ((reverse $11):blocks) endLabel }
 
 ELSE_BLOCKS :: { (SrcSpan, [Maybe (Expression A0)], [[Block A0]], Maybe (Expression A0)) }
-ELSE_BLOCKS
 : maybe(INTEGER_LITERAL) elsif '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
   { let (endSpan, conds, blocks, endLabel) = $10
     in (endSpan, Just $4 : conds, reverse $9 : blocks, endLabel) }
@@ -354,7 +352,6 @@ ELSE_BLOCKS
 | END_IF { let (endSpan, endLabel) = $1 in (endSpan, [], [], endLabel) }
 
 END_IF :: { (SrcSpan, Maybe (Expression A0)) }
-END_IF
 : endif { (getSpan $1, Nothing) }
 | endif id { (getSpan $2, Nothing) }
 | INTEGER_LITERAL endif { (getSpan $2, Just $1) }
@@ -404,7 +401,6 @@ END_SELECT :: { (Maybe (Expression A0), SrcSpan) }
   { ($1, maybe (getSpan $2) getSpan $3) }
 
 DO_BLOCK :: { Block A0 }
-DO_BLOCK
 : START_DO                          MAYBE_COMMENT NEWLINE BLOCKS END_DO
   {% let { (startSpan, startConstruct, startLabel) = $1;
            (endSpan, endConstruct, endLabel) = $5; }
@@ -426,14 +422,12 @@ DO_BLOCK
   }
 
 START_DO :: { (SrcSpan, Maybe String, Maybe (Expression A0)) }
-START_DO
 : do { (getSpan $1, Nothing, Nothing)}
 | id ':' do { let TId s id = $1 in (s, Just id, Nothing) }
 | INTEGER_LITERAL do { (getSpan $1, Nothing, Just $1) }
 | INTEGER_LITERAL id ':' do { let TId _ id = $2 in (getSpan $1, Just id, Just $1) }
 
 END_DO :: { (SrcSpan, Maybe String, Maybe (Expression A0)) }
-END_DO
 : enddo { (getSpan $1, Nothing, Nothing) }
 | INTEGER_LITERAL enddo { (getSpan $2, Nothing, Just $1)}
 | enddo id { let TId s id = $2 in (s, Just id, Nothing)}
diff --git a/src/Language/Fortran/Parser/Fortran95.y b/src/Language/Fortran/Parser/Fortran95.y
index a8d0e083..685a76df 100644
--- a/src/Language/Fortran/Parser/Fortran95.y
+++ b/src/Language/Fortran/Parser/Fortran95.y
@@ -318,6 +318,7 @@ BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] }
 BLOCK :: { Block A0 }
 : IF_BLOCK MAYBE_COMMENT NEWLINE { $1 }
 | CASE_BLOCK MAYBE_COMMENT NEWLINE { $1 }
+| DO_BLOCK MAYBE_COMMENT NEWLINE { $1 }
 | INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE
   { BlStatement () (getTransSpan $1 $2) (Just $1) $2 }
 | STATEMENT MAYBE_COMMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 }
@@ -328,7 +329,6 @@ BLOCK :: { Block A0 }
 | COMMENT_BLOCK { $1 }
 
 IF_BLOCK :: { Block A0 }
-IF_BLOCK
 :                        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
   { let { startSpan = getSpan $1;
           (endSpan, conds, blocks, endLabel) = $9;
@@ -354,7 +354,6 @@ IF_BLOCK
      in BlIf () span startLabel (Just startName) ((Just $6):conds) ((reverse $11):blocks) endLabel }
 
 ELSE_BLOCKS :: { (SrcSpan, [Maybe (Expression A0)], [[Block A0]], Maybe (Expression A0)) }
-ELSE_BLOCKS
 : maybe(INTEGER_LITERAL) elsif '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
   { let (endSpan, conds, blocks, endLabel) = $10
     in (endSpan, Just $4 : conds, reverse $9 : blocks, endLabel) }
@@ -364,14 +363,12 @@ ELSE_BLOCKS
 | END_IF { let (endSpan, endLabel) = $1 in (endSpan, [], [], endLabel) }
 
 END_IF :: { (SrcSpan, Maybe (Expression A0)) }
-END_IF
 : endif { (getSpan $1, Nothing) }
 | endif id { (getSpan $2, Nothing) }
 | INTEGER_LITERAL endif { (getSpan $2, Just $1) }
 | INTEGER_LITERAL endif id { (getSpan $3, Just $1) }
 
 CASE_BLOCK :: { Block A0 }
-CASE_BLOCK
 :                        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
   { let { (caseRanges, blocks, endLabel, endSpan) = $7;
           span = getTransSpan $1 endSpan }
@@ -414,6 +411,39 @@ END_SELECT :: { (Maybe (Expression A0), SrcSpan) }
 : maybe(INTEGER_LITERAL) endselect maybe(id)
   { ($1, maybe (getSpan $2) getSpan $3) }
 
+DO_BLOCK :: { Block A0 }
+: START_DO                          MAYBE_COMMENT NEWLINE BLOCKS END_DO
+  {% let { (startSpan, startConstruct, startLabel) = $1;
+           (endSpan, endConstruct, endLabel) = $5; }
+      in if startConstruct /= endConstruct
+         then fail $ "Unexpected id for end do " <> show endConstruct <> " at " <> show endSpan
+         else return $ BlDo () (getTransSpan startSpan endSpan) startLabel startConstruct Nothing Nothing (reverse $4) endLabel }
+| START_DO DO_SPECIFICATION         MAYBE_COMMENT NEWLINE BLOCKS END_DO
+  {% let { (startSpan, startConstruct, startLabel) = $1;
+           (endSpan, endConstruct, endLabel) = $6; }
+      in if startConstruct /= endConstruct
+         then fail $ "Unexpected id for end do " <> show endConstruct <> " at " <> show endSpan
+         else return $ BlDo () (getTransSpan startSpan endSpan) startLabel startConstruct Nothing (Just $2) (reverse $5) endLabel }
+| START_DO while '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE BLOCKS END_DO
+  {% let { (startSpan, startConstruct, startLabel) = $1;
+           (endSpan, endConstruct, endLabel) = $9; }
+     in if startConstruct /= endConstruct
+        then fail $ "Unexpected id for end do " <> show endConstruct <> " at " <> show endSpan
+        else return $ BlDoWhile () (getTransSpan startSpan endSpan) startLabel startConstruct Nothing $4 (reverse $8) endLabel
+  }
+
+START_DO :: { (SrcSpan, Maybe String, Maybe (Expression A0)) }
+: do { (getSpan $1, Nothing, Nothing)}
+| id ':' do { let TId s id = $1 in (s, Just id, Nothing) }
+| INTEGER_LITERAL do { (getSpan $1, Nothing, Just $1) }
+| INTEGER_LITERAL id ':' do { let TId _ id = $2 in (getSpan $1, Just id, Just $1) }
+
+END_DO :: { (SrcSpan, Maybe String, Maybe (Expression A0)) }
+: enddo { (getSpan $1, Nothing, Nothing) }
+| INTEGER_LITERAL enddo { (getSpan $2, Nothing, Just $1)}
+| enddo id { let TId s id = $2 in (s, Just id, Nothing)}
+| INTEGER_LITERAL enddo id { let TId s id = $3 in (s, Just id, Just $1) }
+
 MAYBE_EXPRESSION :: { Maybe (Expression A0) }
 : EXPRESSION { Just $1 }
 | {- EMPTY -} { Nothing }
@@ -562,26 +592,13 @@ EXECUTABLE_STATEMENT :: { Statement A0 }
 | endwhere { StEndWhere () (getSpan $1) Nothing }
 | if '(' EXPRESSION ')' INTEGER_LITERAL ',' INTEGER_LITERAL ',' INTEGER_LITERAL
   { StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 }
-| do { StDo () (getSpan $1) Nothing Nothing Nothing }
-| id ':' do
-  { let TId s id = $1
-    in StDo () (getTransSpan s $3) (Just id) Nothing Nothing }
 | do INTEGER_LITERAL MAYBE_COMMA DO_SPECIFICATION
   { StDo () (getTransSpan $1 $4) Nothing (Just $2) (Just $4) }
-| do DO_SPECIFICATION { StDo () (getTransSpan $1 $2) Nothing Nothing (Just $2) }
-| id ':' do DO_SPECIFICATION
-  { let TId s id = $1
-    in StDo () (getTransSpan s $4) (Just id) Nothing (Just $4) }
 | do INTEGER_LITERAL MAYBE_COMMA while '(' EXPRESSION ')'
   { StDoWhile () (getTransSpan $1 $7) Nothing (Just $2) $6 }
-| do while '(' EXPRESSION ')'
-  { StDoWhile () (getTransSpan $1 $5) Nothing Nothing $4 }
-| id ':' do while '(' EXPRESSION ')'
-  { let TId s id = $1
-    in StDoWhile () (getTransSpan s $7) (Just id) Nothing $6 }
-| enddo { StEnddo () (getSpan $1) Nothing }
-| enddo id
-  { let TId s id = $2 in StEnddo () (getTransSpan $1 s) (Just id) }
+-- | enddo { StEnddo () (getSpan $1) Nothing }
+-- | enddo id
+--  { let TId s id = $2 in StEnddo () (getTransSpan $1 s) (Just id) }
 | cycle { StCycle () (getSpan $1) Nothing }
 | cycle VARIABLE { StCycle () (getTransSpan $1 $2) (Just $2) }
 | exit { StExit () (getSpan $1) Nothing }
diff --git a/test/Language/Fortran/Parser/Fortran90Spec.hs b/test/Language/Fortran/Parser/Fortran90Spec.hs
index 2feaf892..946ebc9b 100644
--- a/test/Language/Fortran/Parser/Fortran90Spec.hs
+++ b/test/Language/Fortran/Parser/Fortran90Spec.hs
@@ -509,29 +509,23 @@ spec =
         blParser src `shouldBe'` block
 
     describe "Do" $ do
-      it "parses do statement with label" $ do
+      it "parses labelled do statement (non-block construct)" $ do
         let assign = StExpressionAssign () u (varGen "i") (intGen 0)
         let doSpec = DoSpecification () u assign (intGen 42) Nothing
         let st = StDo () u Nothing (Just $ intGen 24) (Just doSpec)
         sParser "do 24, i = 0, 42" `shouldBe'` st
 
-      it "parses do statement without label" $ do
-        let assign = StExpressionAssign () u (varGen "i") (intGen 0)
-        let doSpec = DoSpecification () u assign (intGen 42) Nothing
-        let st = StDo () u Nothing Nothing (Just doSpec)
-        sParser "do i = 0, 42" `shouldBe'` st
-
-      it "parses infinite do" $ do
-        let st = StDo () u Nothing Nothing Nothing
-        sParser "do" `shouldBe'` st
+      let yeetBl = BlStatement () u Nothing (StCall () u (ExpValue () u (ValVariable "yeet")) Nothing)
+      it "parses unlabelled do block" $ do
+        let doBlockSrc = unlines [ "do", "call yeet", "end do"]
+            doBlock = BlDo () u Nothing Nothing Nothing Nothing [yeetBl] Nothing
+        blParser doBlockSrc `shouldBe'` doBlock
 
-      it "parses end do statement" $ do
-        let st = StEnddo () u (Just "constructor")
-        sParser "end do constructor" `shouldBe'` st
-
-      it "parses end do while statement" $ do
-        let st = StDoWhile () u (Just "name") Nothing valTrue
-        sParser "name: do while (.true.)" `shouldBe'` st
+      it "parses named do while" $ do
+        let doBlockSrc = unlines ["mylabel : do while (.true.)", "call yeet", "end do mylabel"]
+            trueLit = ExpValue () u (ValLogical ".true.")
+            doBlock = BlDoWhile () u Nothing (Just "mylabel") Nothing trueLit [yeetBl] Nothing
+        blParser doBlockSrc `shouldBe'` doBlock
 
     describe "Goto" $ do
       it "parses vanilla goto" $ do
diff --git a/test/Language/Fortran/Parser/Fortran95Spec.hs b/test/Language/Fortran/Parser/Fortran95Spec.hs
index 47f65201..ee0c9c83 100644
--- a/test/Language/Fortran/Parser/Fortran95Spec.hs
+++ b/test/Language/Fortran/Parser/Fortran95Spec.hs
@@ -558,29 +558,23 @@ spec =
         blParser src `shouldBe'` block
 
     describe "Do" $ do
-      it "parses do statement with label" $ do
+      it "parses labelled do statement (non-block construct)" $ do
         let assign = StExpressionAssign () u (varGen "i") (intGen 0)
-            doSpec = DoSpecification () u assign (intGen 42) Nothing
-            st = StDo () u Nothing (Just $ intGen 24) (Just doSpec)
+        let doSpec = DoSpecification () u assign (intGen 42) Nothing
+        let st = StDo () u Nothing (Just $ intGen 24) (Just doSpec)
         sParser "do 24, i = 0, 42" `shouldBe'` st
 
-      it "parses do statement without label" $ do
-        let assign = StExpressionAssign () u (varGen "i") (intGen 0)
-            doSpec = DoSpecification () u assign (intGen 42) Nothing
-            st = StDo () u Nothing Nothing (Just doSpec)
-        sParser "do i = 0, 42" `shouldBe'` st
-
-      it "parses infinite do" $ do
-        let st = StDo () u Nothing Nothing Nothing
-        sParser "do" `shouldBe'` st
+      let yeetBl = BlStatement () u Nothing (StCall () u (ExpValue () u (ValVariable "yeet")) Nothing)
+      it "parses unlabelled do block" $ do
+        let doBlockSrc = unlines [ "do", "call yeet", "end do"]
+            doBlock = BlDo () u Nothing Nothing Nothing Nothing [yeetBl] Nothing
+        blParser doBlockSrc `shouldBe'` doBlock
 
-      it "parses end do statement" $ do
-        let st = StEnddo () u (Just "constructor")
-        sParser "end do constructor" `shouldBe'` st
-
-      it "parses end do while statement" $ do
-        let st = StDoWhile () u (Just "name") Nothing valTrue
-        sParser "name: do while (.true.)" `shouldBe'` st
+      it "parses named do while" $ do
+        let doBlockSrc = unlines ["mylabel : do while (.true.)", "call yeet", "end do mylabel"]
+            trueLit = ExpValue () u (ValLogical ".true.")
+            doBlock = BlDoWhile () u Nothing (Just "mylabel") Nothing trueLit [yeetBl] Nothing
+        blParser doBlockSrc `shouldBe'` doBlock
 
     describe "Goto" $ do
       it "parses vanilla goto" $ do