Skip to content

Commit 7271c0a

Browse files
raehikraehik
committed
TMP Parse DO blocks block-based in parser (all)
1 parent 36a3465 commit 7271c0a

File tree

5 files changed

+98
-82
lines changed

5 files changed

+98
-82
lines changed

‎src/Language/Fortran/Parser/Fortran2003.y‎

Lines changed: 37 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -358,6 +358,7 @@ BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] }
358358
BLOCK :: { Block A0 }
359359
: IF_BLOCK MAYBE_COMMENT NEWLINE { $1 }
360360
| CASE_BLOCK MAYBE_COMMENT NEWLINE { $1 }
361+
| DO_BLOCK MAYBE_COMMENT NEWLINE { $1 }
361362
| INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE
362363
{ BlStatement () (getTransSpan $1 $2) (Just $1) $2 }
363364
| STATEMENT MAYBE_COMMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 }
@@ -368,7 +369,6 @@ BLOCK :: { Block A0 }
368369
| COMMENT_BLOCK { $1 }
369370

370371
IF_BLOCK :: { Block A0 }
371-
IF_BLOCK
372372
: if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
373373
{ let { startSpan = getSpan $1;
374374
(endSpan, conds, blocks, endLabel) = $9;
@@ -394,7 +394,6 @@ IF_BLOCK
394394
in BlIf () span startLabel (Just startName) ((Just $6):conds) ((reverse $11):blocks) endLabel }
395395

396396
ELSE_BLOCKS :: { (SrcSpan, [Maybe (Expression A0)], [[Block A0]], Maybe (Expression A0)) }
397-
ELSE_BLOCKS
398397
: maybe(INTEGER_LITERAL) elsif '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
399398
{ let (endSpan, conds, blocks, endLabel) = $10
400399
in (endSpan, Just $4 : conds, reverse $9 : blocks, endLabel) }
@@ -404,14 +403,12 @@ ELSE_BLOCKS
404403
| END_IF { let (endSpan, endLabel) = $1 in (endSpan, [], [], endLabel) }
405404

406405
END_IF :: { (SrcSpan, Maybe (Expression A0)) }
407-
END_IF
408406
: endif { (getSpan $1, Nothing) }
409407
| endif id { (getSpan $2, Nothing) }
410408
| INTEGER_LITERAL endif { (getSpan $2, Just $1) }
411409
| INTEGER_LITERAL endif id { (getSpan $3, Just $1) }
412410

413411
CASE_BLOCK :: { Block A0 }
414-
CASE_BLOCK
415412
: selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
416413
{ let { (caseRanges, blocks, endLabel, endSpan) = $7;
417414
span = getTransSpan $1 endSpan }
@@ -454,6 +451,39 @@ END_SELECT :: { (Maybe (Expression A0), SrcSpan) }
454451
: maybe(INTEGER_LITERAL) endselect maybe(id)
455452
{ ($1, maybe (getSpan $2) getSpan $3) }
456453

454+
DO_BLOCK :: { Block A0 }
455+
: START_DO MAYBE_COMMENT NEWLINE BLOCKS END_DO
456+
{% let { (startSpan, startConstruct, startLabel) = $1;
457+
(endSpan, endConstruct, endLabel) = $5; }
458+
in if startConstruct /= endConstruct
459+
then fail $ "Unexpected id for end do " <> show endConstruct <> " at " <> show endSpan
460+
else return $ BlDo () (getTransSpan startSpan endSpan) startLabel startConstruct Nothing Nothing (reverse $4) endLabel }
461+
| START_DO DO_SPECIFICATION MAYBE_COMMENT NEWLINE BLOCKS END_DO
462+
{% let { (startSpan, startConstruct, startLabel) = $1;
463+
(endSpan, endConstruct, endLabel) = $6; }
464+
in if startConstruct /= endConstruct
465+
then fail $ "Unexpected id for end do " <> show endConstruct <> " at " <> show endSpan
466+
else return $ BlDo () (getTransSpan startSpan endSpan) startLabel startConstruct Nothing (Just $2) (reverse $5) endLabel }
467+
| START_DO while '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE BLOCKS END_DO
468+
{% let { (startSpan, startConstruct, startLabel) = $1;
469+
(endSpan, endConstruct, endLabel) = $9; }
470+
in if startConstruct /= endConstruct
471+
then fail $ "Unexpected id for end do " <> show endConstruct <> " at " <> show endSpan
472+
else return $ BlDoWhile () (getTransSpan startSpan endSpan) startLabel startConstruct Nothing $4 (reverse $8) endLabel
473+
}
474+
475+
START_DO :: { (SrcSpan, Maybe String, Maybe (Expression A0)) }
476+
: do { (getSpan $1, Nothing, Nothing)}
477+
| id ':' do { let TId s id = $1 in (s, Just id, Nothing) }
478+
| INTEGER_LITERAL do { (getSpan $1, Nothing, Just $1) }
479+
| INTEGER_LITERAL id ':' do { let TId _ id = $2 in (getSpan $1, Just id, Just $1) }
480+
481+
END_DO :: { (SrcSpan, Maybe String, Maybe (Expression A0)) }
482+
: enddo { (getSpan $1, Nothing, Nothing) }
483+
| INTEGER_LITERAL enddo { (getSpan $2, Nothing, Just $1)}
484+
| enddo id { let TId s id = $2 in (s, Just id, Nothing)}
485+
| INTEGER_LITERAL enddo id { let TId s id = $3 in (s, Just id, Just $1) }
486+
457487
ABSTRACTP :: { Bool }
458488
: abstract { True }
459489
| {- EMPTY -} { False }
@@ -658,26 +688,13 @@ EXECUTABLE_STATEMENT :: { Statement A0 }
658688
| endwhere { StEndWhere () (getSpan $1) Nothing }
659689
| if '(' EXPRESSION ')' INTEGER_LITERAL ',' INTEGER_LITERAL ',' INTEGER_LITERAL
660690
{ StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 }
661-
| do { StDo () (getSpan $1) Nothing Nothing Nothing }
662-
| id ':' do
663-
{ let TId s id = $1
664-
in StDo () (getTransSpan s $3) (Just id) Nothing Nothing }
665691
| do INTEGER_LITERAL MAYBE_COMMA DO_SPECIFICATION
666692
{ StDo () (getTransSpan $1 $4) Nothing (Just $2) (Just $4) }
667-
| do DO_SPECIFICATION { StDo () (getTransSpan $1 $2) Nothing Nothing (Just $2) }
668-
| id ':' do DO_SPECIFICATION
669-
{ let TId s id = $1
670-
in StDo () (getTransSpan s $4) (Just id) Nothing (Just $4) }
671693
| do INTEGER_LITERAL MAYBE_COMMA while '(' EXPRESSION ')'
672694
{ StDoWhile () (getTransSpan $1 $7) Nothing (Just $2) $6 }
673-
| do while '(' EXPRESSION ')'
674-
{ StDoWhile () (getTransSpan $1 $5) Nothing Nothing $4 }
675-
| id ':' do while '(' EXPRESSION ')'
676-
{ let TId s id = $1
677-
in StDoWhile () (getTransSpan s $7) (Just id) Nothing $6 }
678-
| enddo { StEnddo () (getSpan $1) Nothing }
679-
| enddo id
680-
{ let TId s id = $2 in StEnddo () (getTransSpan $1 s) (Just id) }
695+
-- | enddo { StEnddo () (getSpan $1) Nothing }
696+
-- | enddo id
697+
-- { let TId s id = $2 in StEnddo () (getTransSpan $1 s) (Just id) }
681698
| cycle { StCycle () (getSpan $1) Nothing }
682699
| cycle VARIABLE { StCycle () (getTransSpan $1 $2) (Just $2) }
683700
| exit { StExit () (getSpan $1) Nothing }

‎src/Language/Fortran/Parser/Fortran90.y‎

Lines changed: 0 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -318,7 +318,6 @@ BLOCK :: { Block A0 }
318318
| COMMENT_BLOCK { $1 }
319319

320320
IF_BLOCK :: { Block A0 }
321-
IF_BLOCK
322321
: if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
323322
{ let { startSpan = getSpan $1;
324323
(endSpan, conds, blocks, endLabel) = $9;
@@ -344,7 +343,6 @@ IF_BLOCK
344343
in BlIf () span startLabel (Just startName) ((Just $6):conds) ((reverse $11):blocks) endLabel }
345344

346345
ELSE_BLOCKS :: { (SrcSpan, [Maybe (Expression A0)], [[Block A0]], Maybe (Expression A0)) }
347-
ELSE_BLOCKS
348346
: maybe(INTEGER_LITERAL) elsif '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
349347
{ let (endSpan, conds, blocks, endLabel) = $10
350348
in (endSpan, Just $4 : conds, reverse $9 : blocks, endLabel) }
@@ -354,7 +352,6 @@ ELSE_BLOCKS
354352
| END_IF { let (endSpan, endLabel) = $1 in (endSpan, [], [], endLabel) }
355353

356354
END_IF :: { (SrcSpan, Maybe (Expression A0)) }
357-
END_IF
358355
: endif { (getSpan $1, Nothing) }
359356
| endif id { (getSpan $2, Nothing) }
360357
| INTEGER_LITERAL endif { (getSpan $2, Just $1) }
@@ -404,7 +401,6 @@ END_SELECT :: { (Maybe (Expression A0), SrcSpan) }
404401
{ ($1, maybe (getSpan $2) getSpan $3) }
405402

406403
DO_BLOCK :: { Block A0 }
407-
DO_BLOCK
408404
: START_DO MAYBE_COMMENT NEWLINE BLOCKS END_DO
409405
{% let { (startSpan, startConstruct, startLabel) = $1;
410406
(endSpan, endConstruct, endLabel) = $5; }
@@ -426,14 +422,12 @@ DO_BLOCK
426422
}
427423

428424
START_DO :: { (SrcSpan, Maybe String, Maybe (Expression A0)) }
429-
START_DO
430425
: do { (getSpan $1, Nothing, Nothing)}
431426
| id ':' do { let TId s id = $1 in (s, Just id, Nothing) }
432427
| INTEGER_LITERAL do { (getSpan $1, Nothing, Just $1) }
433428
| INTEGER_LITERAL id ':' do { let TId _ id = $2 in (getSpan $1, Just id, Just $1) }
434429

435430
END_DO :: { (SrcSpan, Maybe String, Maybe (Expression A0)) }
436-
END_DO
437431
: enddo { (getSpan $1, Nothing, Nothing) }
438432
| INTEGER_LITERAL enddo { (getSpan $2, Nothing, Just $1)}
439433
| enddo id { let TId s id = $2 in (s, Just id, Nothing)}

‎src/Language/Fortran/Parser/Fortran95.y‎

Lines changed: 37 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -318,6 +318,7 @@ BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] }
318318
BLOCK :: { Block A0 }
319319
: IF_BLOCK MAYBE_COMMENT NEWLINE { $1 }
320320
| CASE_BLOCK MAYBE_COMMENT NEWLINE { $1 }
321+
| DO_BLOCK MAYBE_COMMENT NEWLINE { $1 }
321322
| INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE
322323
{ BlStatement () (getTransSpan $1 $2) (Just $1) $2 }
323324
| STATEMENT MAYBE_COMMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 }
@@ -328,7 +329,6 @@ BLOCK :: { Block A0 }
328329
| COMMENT_BLOCK { $1 }
329330

330331
IF_BLOCK :: { Block A0 }
331-
IF_BLOCK
332332
: if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
333333
{ let { startSpan = getSpan $1;
334334
(endSpan, conds, blocks, endLabel) = $9;
@@ -354,7 +354,6 @@ IF_BLOCK
354354
in BlIf () span startLabel (Just startName) ((Just $6):conds) ((reverse $11):blocks) endLabel }
355355

356356
ELSE_BLOCKS :: { (SrcSpan, [Maybe (Expression A0)], [[Block A0]], Maybe (Expression A0)) }
357-
ELSE_BLOCKS
358357
: maybe(INTEGER_LITERAL) elsif '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
359358
{ let (endSpan, conds, blocks, endLabel) = $10
360359
in (endSpan, Just $4 : conds, reverse $9 : blocks, endLabel) }
@@ -364,14 +363,12 @@ ELSE_BLOCKS
364363
| END_IF { let (endSpan, endLabel) = $1 in (endSpan, [], [], endLabel) }
365364

366365
END_IF :: { (SrcSpan, Maybe (Expression A0)) }
367-
END_IF
368366
: endif { (getSpan $1, Nothing) }
369367
| endif id { (getSpan $2, Nothing) }
370368
| INTEGER_LITERAL endif { (getSpan $2, Just $1) }
371369
| INTEGER_LITERAL endif id { (getSpan $3, Just $1) }
372370

373371
CASE_BLOCK :: { Block A0 }
374-
CASE_BLOCK
375372
: selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
376373
{ let { (caseRanges, blocks, endLabel, endSpan) = $7;
377374
span = getTransSpan $1 endSpan }
@@ -414,6 +411,39 @@ END_SELECT :: { (Maybe (Expression A0), SrcSpan) }
414411
: maybe(INTEGER_LITERAL) endselect maybe(id)
415412
{ ($1, maybe (getSpan $2) getSpan $3) }
416413

414+
DO_BLOCK :: { Block A0 }
415+
: START_DO MAYBE_COMMENT NEWLINE BLOCKS END_DO
416+
{% let { (startSpan, startConstruct, startLabel) = $1;
417+
(endSpan, endConstruct, endLabel) = $5; }
418+
in if startConstruct /= endConstruct
419+
then fail $ "Unexpected id for end do " <> show endConstruct <> " at " <> show endSpan
420+
else return $ BlDo () (getTransSpan startSpan endSpan) startLabel startConstruct Nothing Nothing (reverse $4) endLabel }
421+
| START_DO DO_SPECIFICATION MAYBE_COMMENT NEWLINE BLOCKS END_DO
422+
{% let { (startSpan, startConstruct, startLabel) = $1;
423+
(endSpan, endConstruct, endLabel) = $6; }
424+
in if startConstruct /= endConstruct
425+
then fail $ "Unexpected id for end do " <> show endConstruct <> " at " <> show endSpan
426+
else return $ BlDo () (getTransSpan startSpan endSpan) startLabel startConstruct Nothing (Just $2) (reverse $5) endLabel }
427+
| START_DO while '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE BLOCKS END_DO
428+
{% let { (startSpan, startConstruct, startLabel) = $1;
429+
(endSpan, endConstruct, endLabel) = $9; }
430+
in if startConstruct /= endConstruct
431+
then fail $ "Unexpected id for end do " <> show endConstruct <> " at " <> show endSpan
432+
else return $ BlDoWhile () (getTransSpan startSpan endSpan) startLabel startConstruct Nothing $4 (reverse $8) endLabel
433+
}
434+
435+
START_DO :: { (SrcSpan, Maybe String, Maybe (Expression A0)) }
436+
: do { (getSpan $1, Nothing, Nothing)}
437+
| id ':' do { let TId s id = $1 in (s, Just id, Nothing) }
438+
| INTEGER_LITERAL do { (getSpan $1, Nothing, Just $1) }
439+
| INTEGER_LITERAL id ':' do { let TId _ id = $2 in (getSpan $1, Just id, Just $1) }
440+
441+
END_DO :: { (SrcSpan, Maybe String, Maybe (Expression A0)) }
442+
: enddo { (getSpan $1, Nothing, Nothing) }
443+
| INTEGER_LITERAL enddo { (getSpan $2, Nothing, Just $1)}
444+
| enddo id { let TId s id = $2 in (s, Just id, Nothing)}
445+
| INTEGER_LITERAL enddo id { let TId s id = $3 in (s, Just id, Just $1) }
446+
417447
MAYBE_EXPRESSION :: { Maybe (Expression A0) }
418448
: EXPRESSION { Just $1 }
419449
| {- EMPTY -} { Nothing }
@@ -562,26 +592,13 @@ EXECUTABLE_STATEMENT :: { Statement A0 }
562592
| endwhere { StEndWhere () (getSpan $1) Nothing }
563593
| if '(' EXPRESSION ')' INTEGER_LITERAL ',' INTEGER_LITERAL ',' INTEGER_LITERAL
564594
{ StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 }
565-
| do { StDo () (getSpan $1) Nothing Nothing Nothing }
566-
| id ':' do
567-
{ let TId s id = $1
568-
in StDo () (getTransSpan s $3) (Just id) Nothing Nothing }
569595
| do INTEGER_LITERAL MAYBE_COMMA DO_SPECIFICATION
570596
{ StDo () (getTransSpan $1 $4) Nothing (Just $2) (Just $4) }
571-
| do DO_SPECIFICATION { StDo () (getTransSpan $1 $2) Nothing Nothing (Just $2) }
572-
| id ':' do DO_SPECIFICATION
573-
{ let TId s id = $1
574-
in StDo () (getTransSpan s $4) (Just id) Nothing (Just $4) }
575597
| do INTEGER_LITERAL MAYBE_COMMA while '(' EXPRESSION ')'
576598
{ StDoWhile () (getTransSpan $1 $7) Nothing (Just $2) $6 }
577-
| do while '(' EXPRESSION ')'
578-
{ StDoWhile () (getTransSpan $1 $5) Nothing Nothing $4 }
579-
| id ':' do while '(' EXPRESSION ')'
580-
{ let TId s id = $1
581-
in StDoWhile () (getTransSpan s $7) (Just id) Nothing $6 }
582-
| enddo { StEnddo () (getSpan $1) Nothing }
583-
| enddo id
584-
{ let TId s id = $2 in StEnddo () (getTransSpan $1 s) (Just id) }
599+
-- | enddo { StEnddo () (getSpan $1) Nothing }
600+
-- | enddo id
601+
-- { let TId s id = $2 in StEnddo () (getTransSpan $1 s) (Just id) }
585602
| cycle { StCycle () (getSpan $1) Nothing }
586603
| cycle VARIABLE { StCycle () (getTransSpan $1 $2) (Just $2) }
587604
| exit { StExit () (getSpan $1) Nothing }

‎test/Language/Fortran/Parser/Fortran90Spec.hs‎

Lines changed: 11 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -509,29 +509,23 @@ spec =
509509
blParser src `shouldBe'` block
510510

511511
describe "Do" $ do
512-
it "parses do statement with label" $ do
512+
it "parses labelled do statement (non-block construct)" $ do
513513
let assign = StExpressionAssign () u (varGen "i") (intGen 0)
514514
let doSpec = DoSpecification () u assign (intGen 42) Nothing
515515
let st = StDo () u Nothing (Just $ intGen 24) (Just doSpec)
516516
sParser "do 24, i = 0, 42" `shouldBe'` st
517517

518-
it "parses do statement without label" $ do
519-
let assign = StExpressionAssign () u (varGen "i") (intGen 0)
520-
let doSpec = DoSpecification () u assign (intGen 42) Nothing
521-
let st = StDo () u Nothing Nothing (Just doSpec)
522-
sParser "do i = 0, 42" `shouldBe'` st
523-
524-
it "parses infinite do" $ do
525-
let st = StDo () u Nothing Nothing Nothing
526-
sParser "do" `shouldBe'` st
518+
let yeetBl = BlStatement () u Nothing (StCall () u (ExpValue () u (ValVariable "yeet")) Nothing)
519+
it "parses unlabelled do block" $ do
520+
let doBlockSrc = unlines [ "do", "call yeet", "end do"]
521+
doBlock = BlDo () u Nothing Nothing Nothing Nothing [yeetBl] Nothing
522+
blParser doBlockSrc `shouldBe'` doBlock
527523

528-
it "parses end do statement" $ do
529-
let st = StEnddo () u (Just "constructor")
530-
sParser "end do constructor" `shouldBe'` st
531-
532-
it "parses end do while statement" $ do
533-
let st = StDoWhile () u (Just "name") Nothing valTrue
534-
sParser "name: do while (.true.)" `shouldBe'` st
524+
it "parses named do while" $ do
525+
let doBlockSrc = unlines ["mylabel : do while (.true.)", "call yeet", "end do mylabel"]
526+
trueLit = ExpValue () u (ValLogical ".true.")
527+
doBlock = BlDoWhile () u Nothing (Just "mylabel") Nothing trueLit [yeetBl] Nothing
528+
blParser doBlockSrc `shouldBe'` doBlock
535529

536530
describe "Goto" $ do
537531
it "parses vanilla goto" $ do

‎test/Language/Fortran/Parser/Fortran95Spec.hs‎

Lines changed: 13 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -558,29 +558,23 @@ spec =
558558
blParser src `shouldBe'` block
559559

560560
describe "Do" $ do
561-
it "parses do statement with label" $ do
561+
it "parses labelled do statement (non-block construct)" $ do
562562
let assign = StExpressionAssign () u (varGen "i") (intGen 0)
563-
doSpec = DoSpecification () u assign (intGen 42) Nothing
564-
st = StDo () u Nothing (Just $ intGen 24) (Just doSpec)
563+
let doSpec = DoSpecification () u assign (intGen 42) Nothing
564+
let st = StDo () u Nothing (Just $ intGen 24) (Just doSpec)
565565
sParser "do 24, i = 0, 42" `shouldBe'` st
566566

567-
it "parses do statement without label" $ do
568-
let assign = StExpressionAssign () u (varGen "i") (intGen 0)
569-
doSpec = DoSpecification () u assign (intGen 42) Nothing
570-
st = StDo () u Nothing Nothing (Just doSpec)
571-
sParser "do i = 0, 42" `shouldBe'` st
572-
573-
it "parses infinite do" $ do
574-
let st = StDo () u Nothing Nothing Nothing
575-
sParser "do" `shouldBe'` st
567+
let yeetBl = BlStatement () u Nothing (StCall () u (ExpValue () u (ValVariable "yeet")) Nothing)
568+
it "parses unlabelled do block" $ do
569+
let doBlockSrc = unlines [ "do", "call yeet", "end do"]
570+
doBlock = BlDo () u Nothing Nothing Nothing Nothing [yeetBl] Nothing
571+
blParser doBlockSrc `shouldBe'` doBlock
576572

577-
it "parses end do statement" $ do
578-
let st = StEnddo () u (Just "constructor")
579-
sParser "end do constructor" `shouldBe'` st
580-
581-
it "parses end do while statement" $ do
582-
let st = StDoWhile () u (Just "name") Nothing valTrue
583-
sParser "name: do while (.true.)" `shouldBe'` st
573+
it "parses named do while" $ do
574+
let doBlockSrc = unlines ["mylabel : do while (.true.)", "call yeet", "end do mylabel"]
575+
trueLit = ExpValue () u (ValLogical ".true.")
576+
doBlock = BlDoWhile () u Nothing (Just "mylabel") Nothing trueLit [yeetBl] Nothing
577+
blParser doBlockSrc `shouldBe'` doBlock
584578

585579
describe "Goto" $ do
586580
it "parses vanilla goto" $ do

0 commit comments

Comments
 (0)