From 1e80049725e07b4c7115b1649d13b5e87a4662be Mon Sep 17 00:00:00 2001 From: Ben Orchard Date: Mon, 26 Jul 2021 10:30:43 +0100 Subject: [PATCH] Parse DO blocks block-based in parsers And disable relevant transformation GroupDo -- GroupLabelledDo is still important for the "nonblock" DO construct. Original code by RaoulHC. --- src/Language/Fortran/Parser/Fortran2003.y | 57 ++++++++++++------- src/Language/Fortran/Parser/Fortran77.y | 18 ++++-- src/Language/Fortran/Parser/Fortran90.y | 56 +++++++++++------- src/Language/Fortran/Parser/Fortran95.y | 57 ++++++++++++------- src/Language/Fortran/Transformer.hs | 2 +- test/Language/Fortran/Parser/Fortran90Spec.hs | 28 ++++----- test/Language/Fortran/Parser/Fortran95Spec.hs | 32 +++++------ 7 files changed, 149 insertions(+), 101 deletions(-) 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/Fortran77.y b/src/Language/Fortran/Parser/Fortran77.y index b59a20d6..a0570b6c 100644 --- a/src/Language/Fortran/Parser/Fortran77.y +++ b/src/Language/Fortran/Parser/Fortran77.y @@ -275,6 +275,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 } @@ -299,6 +300,17 @@ ELSE_BLOCKS { (getSpan $6, $5, [Nothing], [reverse $4]) } | maybe(LABEL_IN_6COLUMN) endif { (getSpan $2, $1, [], []) } +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) } @@ -322,8 +334,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 @@ -336,13 +346,11 @@ 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 } +-- | 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 index 4ceca563..98227bd4 100644 --- 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 } @@ -317,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; @@ -343,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) } @@ -353,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) } @@ -402,6 +400,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 } @@ -544,26 +575,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/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/src/Language/Fortran/Transformer.hs b/src/Language/Fortran/Transformer.hs index cc2c41e3..738fefad 100644 --- a/src/Language/Fortran/Transformer.hs +++ b/src/Language/Fortran/Transformer.hs @@ -53,7 +53,7 @@ defaultTransformations = \case , DisambiguateFunction ] Fortran77 -> defaultTransformations Fortran66 - Fortran77Legacy -> GroupDo : defaultTransformations Fortran77 + Fortran77Legacy -> defaultTransformations Fortran77 Fortran77Extended -> defaultTransformations Fortran77Legacy Fortran90 -> defaultTransformations Fortran77Extended Fortran95 -> defaultTransformations Fortran77Extended 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