TMP Parse DO blocks block-based in parser (F90)

camfort · Jul 26, 2021 · 36a3465 · 36a3465
1 parent 29833b5
commit 36a3465
Showing 1 changed file with 40 additions and 16 deletions.
diff --git a/src/Language/Fortran/Parser/Fortran90.y b/src/Language/Fortran/Parser/Fortran90.y
@@ -307,6 +307,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 }
@@ -402,6 +403,42 @@ END_SELECT :: { (Maybe (Expression A0), SrcSpan) }
 : maybe(INTEGER_LITERAL) endselect maybe(id)
   { ($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; }
+      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)) }
+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 }
@@ -544,26 +581,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 }