Skip to content

Commit 1e80049

Browse files
raehikraehik
committed
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.
1 parent 3ad155a commit 1e80049

File tree

7 files changed

+149
-101
lines changed

7 files changed

+149
-101
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/Fortran77.y‎

Lines changed: 13 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -275,6 +275,7 @@ BLOCKS
275275
BLOCK :: { Block A0 }
276276
BLOCK
277277
: IF_BLOCK NEWLINE { $1 }
278+
| DO_BLOCK NEWLINE { $1 }
278279
| LABEL_IN_6COLUMN STATEMENT NEWLINE { BlStatement () (getTransSpan $1 $2) (Just $1) $2 }
279280
| STATEMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 }
280281
| COMMENT_BLOCK { $1 }
@@ -299,6 +300,17 @@ ELSE_BLOCKS
299300
{ (getSpan $6, $5, [Nothing], [reverse $4]) }
300301
| maybe(LABEL_IN_6COLUMN) endif { (getSpan $2, $1, [], []) }
301302

303+
DO_BLOCK :: { Block A0 }
304+
DO_BLOCK
305+
: do DO_SPECIFICATION NEWLINE BLOCKS enddo
306+
{ BlDo () (getTransSpan $1 $5) Nothing Nothing Nothing (Just $2) $4 Nothing }
307+
| LABEL_IN_6COLUMN do DO_SPECIFICATION NEWLINE BLOCKS enddo
308+
{ BlDo () (getTransSpan $1 $6) (Just $1) Nothing Nothing (Just $3) $5 Nothing }
309+
| doWhile '(' EXPRESSION ')' NEWLINE BLOCKS enddo
310+
{ BlDoWhile () (getTransSpan $1 $7) Nothing Nothing Nothing $3 $6 Nothing }
311+
| LABEL_IN_6COLUMN doWhile '(' EXPRESSION ')' NEWLINE BLOCKS enddo
312+
{ BlDoWhile () (getTransSpan $1 $8) (Just $1) Nothing Nothing $4 $7 Nothing }
313+
302314
COMMENT_BLOCK :: { Block A0 }
303315
COMMENT_BLOCK
304316
: comment NEWLINE { let (TComment s c) = $1 in BlComment () s (Comment c) }
@@ -322,8 +334,6 @@ DO_STATEMENT :: { Statement A0 }
322334
DO_STATEMENT
323335
: do LABEL_IN_STATEMENT DO_SPECIFICATION { StDo () (getTransSpan $1 $3) Nothing (Just $2) (Just $3) }
324336
| do LABEL_IN_STATEMENT ',' DO_SPECIFICATION { StDo () (getTransSpan $1 $4) Nothing (Just $2) (Just $4) }
325-
| do DO_SPECIFICATION { StDo () (getTransSpan $1 $2) Nothing Nothing (Just $2) }
326-
| do { StDo () (getSpan $1) Nothing Nothing Nothing }
327337

328338
DO_SPECIFICATION :: { DoSpecification A0 }
329339
DO_SPECIFICATION
@@ -336,13 +346,11 @@ EXECUTABLE_STATEMENT
336346
| assign LABEL_IN_STATEMENT to VARIABLE { StLabelAssign () (getTransSpan $1 $4) $2 $4 }
337347
| GOTO_STATEMENT { $1 }
338348
| if '(' EXPRESSION ')' LABEL_IN_STATEMENT ',' LABEL_IN_STATEMENT ',' LABEL_IN_STATEMENT { StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 }
339-
| doWhile '(' EXPRESSION ')'
340-
{ StDoWhile () (getTransSpan $1 $4) Nothing Nothing $3 }
341349
| do LABEL_IN_STATEMENT while '(' EXPRESSION ')'
342350
{ StDoWhile () (getTransSpan $1 $6) Nothing (Just $2) $5 }
343351
| do LABEL_IN_STATEMENT ',' while '(' EXPRESSION ')'
344352
{ StDoWhile () (getTransSpan $1 $7) Nothing (Just $2) $6 }
345-
| enddo { StEnddo () (getSpan $1) Nothing }
353+
-- | enddo { StEnddo () (getSpan $1) Nothing }
346354
| call VARIABLE ARGUMENTS
347355
{ StCall () (getTransSpan $1 $3) $2 $ Just $3 }
348356
| call VARIABLE { StCall () (getTransSpan $1 $2) $2 Nothing }

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

Lines changed: 37 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -307,6 +307,7 @@ BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] }
307307
BLOCK :: { Block A0 }
308308
: IF_BLOCK MAYBE_COMMENT NEWLINE { $1 }
309309
| CASE_BLOCK MAYBE_COMMENT NEWLINE { $1 }
310+
| DO_BLOCK MAYBE_COMMENT NEWLINE { $1 }
310311
| INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE
311312
{ BlStatement () (getTransSpan $1 $2) (Just $1) $2 }
312313
| STATEMENT MAYBE_COMMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 }
@@ -317,7 +318,6 @@ BLOCK :: { Block A0 }
317318
| COMMENT_BLOCK { $1 }
318319

319320
IF_BLOCK :: { Block A0 }
320-
IF_BLOCK
321321
: if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
322322
{ let { startSpan = getSpan $1;
323323
(endSpan, conds, blocks, endLabel) = $9;
@@ -343,7 +343,6 @@ IF_BLOCK
343343
in BlIf () span startLabel (Just startName) ((Just $6):conds) ((reverse $11):blocks) endLabel }
344344

345345
ELSE_BLOCKS :: { (SrcSpan, [Maybe (Expression A0)], [[Block A0]], Maybe (Expression A0)) }
346-
ELSE_BLOCKS
347346
: maybe(INTEGER_LITERAL) elsif '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
348347
{ let (endSpan, conds, blocks, endLabel) = $10
349348
in (endSpan, Just $4 : conds, reverse $9 : blocks, endLabel) }
@@ -353,7 +352,6 @@ ELSE_BLOCKS
353352
| END_IF { let (endSpan, endLabel) = $1 in (endSpan, [], [], endLabel) }
354353

355354
END_IF :: { (SrcSpan, Maybe (Expression A0)) }
356-
END_IF
357355
: endif { (getSpan $1, Nothing) }
358356
| endif id { (getSpan $2, Nothing) }
359357
| INTEGER_LITERAL endif { (getSpan $2, Just $1) }
@@ -402,6 +400,39 @@ END_SELECT :: { (Maybe (Expression A0), SrcSpan) }
402400
: maybe(INTEGER_LITERAL) endselect maybe(id)
403401
{ ($1, maybe (getSpan $2) getSpan $3) }
404402

403+
DO_BLOCK :: { Block A0 }
404+
: START_DO MAYBE_COMMENT NEWLINE BLOCKS END_DO
405+
{% let { (startSpan, startConstruct, startLabel) = $1;
406+
(endSpan, endConstruct, endLabel) = $5; }
407+
in if startConstruct /= endConstruct
408+
then fail $ "Unexpected id for end do " <> show endConstruct <> " at " <> show endSpan
409+
else return $ BlDo () (getTransSpan startSpan endSpan) startLabel startConstruct Nothing Nothing (reverse $4) endLabel }
410+
| START_DO DO_SPECIFICATION MAYBE_COMMENT NEWLINE BLOCKS END_DO
411+
{% let { (startSpan, startConstruct, startLabel) = $1;
412+
(endSpan, endConstruct, endLabel) = $6; }
413+
in if startConstruct /= endConstruct
414+
then fail $ "Unexpected id for end do " <> show endConstruct <> " at " <> show endSpan
415+
else return $ BlDo () (getTransSpan startSpan endSpan) startLabel startConstruct Nothing (Just $2) (reverse $5) endLabel }
416+
| START_DO while '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE BLOCKS END_DO
417+
{% let { (startSpan, startConstruct, startLabel) = $1;
418+
(endSpan, endConstruct, endLabel) = $9; }
419+
in if startConstruct /= endConstruct
420+
then fail $ "Unexpected id for end do " <> show endConstruct <> " at " <> show endSpan
421+
else return $ BlDoWhile () (getTransSpan startSpan endSpan) startLabel startConstruct Nothing $4 (reverse $8) endLabel
422+
}
423+
424+
START_DO :: { (SrcSpan, Maybe String, Maybe (Expression A0)) }
425+
: do { (getSpan $1, Nothing, Nothing)}
426+
| id ':' do { let TId s id = $1 in (s, Just id, Nothing) }
427+
| INTEGER_LITERAL do { (getSpan $1, Nothing, Just $1) }
428+
| INTEGER_LITERAL id ':' do { let TId _ id = $2 in (getSpan $1, Just id, Just $1) }
429+
430+
END_DO :: { (SrcSpan, Maybe String, Maybe (Expression A0)) }
431+
: enddo { (getSpan $1, Nothing, Nothing) }
432+
| INTEGER_LITERAL enddo { (getSpan $2, Nothing, Just $1)}
433+
| enddo id { let TId s id = $2 in (s, Just id, Nothing)}
434+
| INTEGER_LITERAL enddo id { let TId s id = $3 in (s, Just id, Just $1) }
435+
405436
MAYBE_EXPRESSION :: { Maybe (Expression A0) }
406437
: EXPRESSION { Just $1 }
407438
| {- EMPTY -} { Nothing }
@@ -544,26 +575,13 @@ EXECUTABLE_STATEMENT :: { Statement A0 }
544575
| endwhere { StEndWhere () (getSpan $1) Nothing }
545576
| if '(' EXPRESSION ')' INTEGER_LITERAL ',' INTEGER_LITERAL ',' INTEGER_LITERAL
546577
{ StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 }
547-
| do { StDo () (getSpan $1) Nothing Nothing Nothing }
548-
| id ':' do
549-
{ let TId s id = $1
550-
in StDo () (getTransSpan s $3) (Just id) Nothing Nothing }
551578
| do INTEGER_LITERAL MAYBE_COMMA DO_SPECIFICATION
552579
{ StDo () (getTransSpan $1 $4) Nothing (Just $2) (Just $4) }
553-
| do DO_SPECIFICATION { StDo () (getTransSpan $1 $2) Nothing Nothing (Just $2) }
554-
| id ':' do DO_SPECIFICATION
555-
{ let TId s id = $1
556-
in StDo () (getTransSpan s $4) (Just id) Nothing (Just $4) }
557580
| do INTEGER_LITERAL MAYBE_COMMA while '(' EXPRESSION ')'
558581
{ StDoWhile () (getTransSpan $1 $7) Nothing (Just $2) $6 }
559-
| do while '(' EXPRESSION ')'
560-
{ StDoWhile () (getTransSpan $1 $5) Nothing Nothing $4 }
561-
| id ':' do while '(' EXPRESSION ')'
562-
{ let TId s id = $1
563-
in StDoWhile () (getTransSpan s $7) (Just id) Nothing $6 }
564-
| enddo { StEnddo () (getSpan $1) Nothing }
565-
| enddo id
566-
{ let TId s id = $2 in StEnddo () (getTransSpan $1 s) (Just id) }
582+
-- | enddo { StEnddo () (getSpan $1) Nothing }
583+
-- | enddo id
584+
-- { let TId s id = $2 in StEnddo () (getTransSpan $1 s) (Just id) }
567585
| cycle { StCycle () (getSpan $1) Nothing }
568586
| cycle VARIABLE { StCycle () (getTransSpan $1 $2) (Just $2) }
569587
| exit { StExit () (getSpan $1) 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 }

‎src/Language/Fortran/Transformer.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -53,7 +53,7 @@ defaultTransformations = \case
5353
, DisambiguateFunction
5454
]
5555
Fortran77 -> defaultTransformations Fortran66
56-
Fortran77Legacy -> GroupDo : defaultTransformations Fortran77
56+
Fortran77Legacy -> defaultTransformations Fortran77
5757
Fortran77Extended -> defaultTransformations Fortran77Legacy
5858
Fortran90 -> defaultTransformations Fortran77Extended
5959
Fortran95 -> defaultTransformations Fortran77Extended

0 commit comments

Comments
 (0)