WIP context free do block parsing

camfort · Jun 11, 2021 · 04fd6f8 · 04fd6f8
1 parent b4cd1f1
commit 04fd6f8
Show file tree

Hide file tree

Showing 6 changed files with 113 additions and 74 deletions.
diff --git a/src/Language/Fortran/Parser/Fortran77.y b/src/Language/Fortran/Parser/Fortran77.y
@@ -273,6 +273,7 @@ BLOCKS
 BLOCK :: { Block A0 }
 BLOCK
 : IF_BLOCK NEWLINE { $1 }
+| DO_BLOCK NEWLINE { $1 }
 | LABEL_IN_6COLUMN STATEMENT NEWLINE { BlStatement () (getTransSpan $1 $2) (Just $1) $2 }
 | STATEMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 }
 | COMMENT_BLOCK { $1 }
@@ -297,6 +298,17 @@ ELSE_BLOCKS
 | else NEWLINE BLOCKS endif { (getSpan $4, [Nothing], [reverse $3]) }
 | maybe(LABEL_IN_6COLUMN) endif { (getSpan $2, [], []) }
 
+DO_BLOCK :: { Block A0 }
+DO_BLOCK
+: do DO_SPECIFICATION NEWLINE BLOCKS enddo
+  { BlDo () (getTransSpan $1 $5) Nothing Nothing Nothing (Just $2) $4 Nothing }
+| LABEL_IN_6COLUMN do DO_SPECIFICATION NEWLINE BLOCKS enddo
+  { BlDo () (getTransSpan $1 $6) (Just $1) Nothing Nothing (Just $3) $5 Nothing }
+| doWhile '(' EXPRESSION ')' NEWLINE BLOCKS enddo
+  { BlDoWhile () (getTransSpan $1 $7) Nothing Nothing Nothing $3 $6 Nothing } 
+| LABEL_IN_6COLUMN doWhile '(' EXPRESSION ')' NEWLINE BLOCKS enddo
+  { BlDoWhile () (getTransSpan $1 $8) (Just $1) Nothing Nothing $4 $7 Nothing } 
+
 COMMENT_BLOCK :: { Block A0 }
 COMMENT_BLOCK
 : comment NEWLINE { let (TComment s c) = $1 in BlComment () s (Comment c) }
@@ -320,8 +332,6 @@ DO_STATEMENT :: { Statement A0 }
 DO_STATEMENT
 : do LABEL_IN_STATEMENT DO_SPECIFICATION { StDo () (getTransSpan $1 $3) Nothing (Just $2) (Just $3) }
 | do LABEL_IN_STATEMENT ',' DO_SPECIFICATION { StDo () (getTransSpan $1 $4) Nothing (Just $2) (Just $4) }
-| do DO_SPECIFICATION { StDo () (getTransSpan $1 $2) Nothing Nothing (Just $2) }
-| do { StDo () (getSpan $1) Nothing Nothing Nothing }
 
 DO_SPECIFICATION :: { DoSpecification A0 }
 DO_SPECIFICATION
@@ -334,13 +344,10 @@ EXECUTABLE_STATEMENT
 | assign LABEL_IN_STATEMENT to VARIABLE { StLabelAssign () (getTransSpan $1 $4) $2 $4 }
 | GOTO_STATEMENT { $1 }
 | if '(' EXPRESSION ')' LABEL_IN_STATEMENT ',' LABEL_IN_STATEMENT ',' LABEL_IN_STATEMENT { StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 }
-| doWhile '(' EXPRESSION ')'
-  { StDoWhile () (getTransSpan $1 $4) Nothing Nothing $3 }
 | do LABEL_IN_STATEMENT while '(' EXPRESSION ')'
   { StDoWhile () (getTransSpan $1 $6) Nothing (Just $2) $5 }
 | do LABEL_IN_STATEMENT ',' while '(' EXPRESSION ')'
   { StDoWhile () (getTransSpan $1 $7) Nothing (Just $2) $6 }
-| enddo { StEnddo () (getSpan $1) Nothing }
 | call VARIABLE ARGUMENTS
   { StCall () (getTransSpan $1 $3) $2 $ Just $3 }
 | call VARIABLE { StCall () (getTransSpan $1 $2) $2 Nothing }

diff --git a/src/Language/Fortran/Parser/Fortran90.y b/src/Language/Fortran/Parser/Fortran90.y
@@ -302,6 +302,7 @@ BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] }
 
 BLOCK :: { Block A0 }
 : IF_BLOCK NEWLINE { $1 }
+| DO_BLOCK NEWLINE { $1 }
 | INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE
   { BlStatement () (getTransSpan $1 $2) (Just $1) $2 }
 | STATEMENT MAYBE_COMMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 }
@@ -362,6 +363,43 @@ END_IF
 | INTEGER_LITERAL endif { (getSpan $2, Just $1, Nothing) }
 | INTEGER_LITERAL endif id { let TId s id = $3 in (s, Just $1, Just id) }
 
+
+DO_BLOCK :: { Block A0 }
+DO_BLOCK
+: START_DO NEWLINE BLOCKS END_DO
+  {% let { (startSpan, startConstruct, startLabel) = $1;
+           (endSpan, endConstruct, endLabel) = $4; }
+      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 $3) endLabel }
+| START_DO DO_SPECIFICATION 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 (Just $2) (reverse $4) endLabel }
+| START_DO while '(' EXPRESSION ')' NEWLINE BLOCKS END_DO
+  {% let { (startSpan, startConstruct, startLabel) = $1;
+           (endSpan, endConstruct, endLabel) = $8; }
+     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 $7) endLabel
+  }
+
+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)}
+| 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 }
@@ -504,26 +542,10 @@ 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) }
 | 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/Fortran95.y b/src/Language/Fortran/Parser/Fortran95.y
@@ -312,15 +312,16 @@ NAME :: { Name } : id { let (TId _ name) = $1 in name }
 BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] }
 
 BLOCK :: { Block A0 }
-: INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE
+: IF_BLOCK NEWLINE { $1 }
+| DO_BLOCK NEWLINE { $1 }
+| INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE
   { BlStatement () (getTransSpan $1 $2) (Just $1) $2 }
 | STATEMENT MAYBE_COMMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 }
 | interface MAYBE_EXPRESSION MAYBE_COMMENT NEWLINE SUBPROGRAM_UNITS2 MODULE_PROCEDURES INTERFACE_END MAYBE_COMMENT NEWLINE
   { BlInterface () (getTransSpan $1 $9) $2 False (reverse $5) (reverse $6) }
 | interface MAYBE_EXPRESSION MAYBE_COMMENT NEWLINE MODULE_PROCEDURES INTERFACE_END MAYBE_COMMENT NEWLINE
   { BlInterface () (getTransSpan $1 $8) $2 False [ ] (reverse $5) }
 | COMMENT_BLOCK { $1 }
-| IF_BLOCK NEWLINE { $1 }
 
 IF_BLOCK :: { Block A0 }
 IF_BLOCK
@@ -373,6 +374,43 @@ END_IF
 | INTEGER_LITERAL endif { (getSpan $2, Just $1, Nothing) }
 | INTEGER_LITERAL endif id { let TId s id = $3 in (s, Just $1, Just id) }
 
+DO_BLOCK :: { Block A0 }
+DO_BLOCK
+: START_DO NEWLINE BLOCKS END_DO
+  {% let { (startSpan, startConstruct, startLabel) = $1;
+           (endSpan, endConstruct, endLabel) = $4; }
+      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 $3) endLabel }
+| START_DO DO_SPECIFICATION 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 (Just $2) $4 endLabel }
+| START_DO while '(' EXPRESSION ')' NEWLINE BLOCKS END_DO
+  {% let { (startSpan, startConstruct, startLabel) = $1;
+           (endSpan, endConstruct, endLabel) = $8; }
+     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 $7 endLabel
+  }
+
+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 $2, Nothing, Just $1) }
+| INTEGER_LITERAL id ':' do { let TId s id = $2 in (s, 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)}
+| 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 }
@@ -521,26 +559,10 @@ 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) }
 | cycle { StCycle () (getSpan $1) Nothing }
 | cycle VARIABLE { StCycle () (getTransSpan $1 $2) (Just $2) }
 | exit { StExit () (getSpan $1) Nothing }

diff --git a/src/Language/Fortran/Transformer.hs b/src/Language/Fortran/Transformer.hs
@@ -57,7 +57,7 @@ defaultTransformations = \case
     , DisambiguateFunction
     ]
   Fortran77         -> defaultTransformations Fortran66
-  Fortran77Legacy   -> GroupDo   : defaultTransformations Fortran77
+  Fortran77Legacy   -> defaultTransformations Fortran77
   Fortran77Extended -> GroupCase : defaultTransformations Fortran77Legacy
   Fortran90   -> defaultTransformations Fortran77Extended
   Fortran95   -> defaultTransformations Fortran77Extended

diff --git a/test/Language/Fortran/Parser/Fortran90Spec.hs b/test/Language/Fortran/Parser/Fortran90Spec.hs
@@ -489,23 +489,17 @@ spec =
         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
-
-      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
+      let yeetBl = BlStatement () u Nothing (StCall () u (ExpValue () u (ValVariable "yeet")) Nothing)
+      it "parses 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 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
@@ -538,23 +538,17 @@ spec =
             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
-
-      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
+      let yeetBl = BlStatement () u Nothing (StCall () u (ExpValue () u (ValVariable "yeet")) Nothing)
+      it "parses 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 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