Skip to content

Commit

Permalink
Fix block parsing
Browse files Browse the repository at this point in the history 
The way it currently worked meant it would fail to parse includes that
didn't end with a newline, which is valid. To allow this the block
parsing had to be reorganized, with the block parser not expecting
trailing newlines, but otherwise behaves the same.
  • Loading branch information
Raoul Hidalgo Charman committed Jun 22, 2022
1 parent 44a7002 commit 78f5211
Show file tree
Hide file tree
Showing 6 changed files with 68 additions and 63 deletions.
1 change: 1 addition & 0 deletions fortran-src.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -26,6 +26,7 @@ extra-source-files:
README.md
CHANGELOG.md
test-data/f77-include/foo.f
test-data/f77-include/no-newline/foo.f
test-data/rewriter/replacementsmap-columnlimit/001_foo.f
test-data/rewriter/replacementsmap-columnlimit/001_foo.f.expected
test-data/rewriter/replacementsmap-columnlimit/002_other.f
Expand Down
4 changes: 1 addition & 3 deletions src/Language/Fortran/Parser.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -280,9 +280,7 @@ f77lIncludesInline dirs seen st = case st of
Just blocks' -> pure $ StInclude a s e (Just blocks')
Nothing -> do
(fullPath, inc) <- liftIO $ readInDirs dirs path
-- Append newline to include, as grammar is defined to expect a
-- newline at the end of most blocks
case f77lIncludesInner fullPath (B.snoc inc '\n') of
case f77lIncludesInner fullPath inc of
Right blocks -> do
blocks' <- descendBiM (f77lIncludesInline dirs (path:seen)) blocks
modify (Map.insert path blocks')
Expand Down
52 changes: 25 additions & 27 deletions src/Language/Fortran/Parser/Fixed/Fortran77.y
View file
Original file line number Diff line number Diff line change
Expand Up @@ -194,16 +194,16 @@ PROGRAM_UNITS :: { [ ProgramUnit A0 ] }
| maybe(LABEL_IN_6COLUMN) PROGRAM_UNIT maybe(NEWLINE) { [ $2 ] }

PROGRAM_UNIT :: { ProgramUnit A0 }
: program NAME NEWLINE BLOCKS ENDPROG
{ PUMain () (getTransSpan $1 $5) (Just $2) (reverse $4) Nothing }
| TYPE_SPEC function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS ENDFUN
{ PUFunction () (getTransSpan $1 $7) (Just $1) emptyPrefixSuffix $3 $4 Nothing (reverse $6) Nothing }
| function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS ENDFUN
{ PUFunction () (getTransSpan $1 $6) Nothing emptyPrefixSuffix $2 $3 Nothing (reverse $5) Nothing }
| subroutine NAME MAYBE_ARGUMENTS NEWLINE BLOCKS ENDSUB
{ PUSubroutine () (getTransSpan $1 $6) emptyPrefixSuffix $2 $3 (reverse $5) Nothing }
| blockData NEWLINE BLOCKS END { PUBlockData () (getTransSpan $1 $4) Nothing (reverse $3) }
| blockData NAME NEWLINE BLOCKS END { PUBlockData () (getTransSpan $1 $5) (Just $2) (reverse $4) }
: program NAME BLOCKS NEWLINE ENDPROG
{ PUMain () (getTransSpan $1 $5) (Just $2) (reverse $3) Nothing }
| TYPE_SPEC function NAME MAYBE_ARGUMENTS BLOCKS NEWLINE ENDFUN
{ PUFunction () (getTransSpan $1 $7) (Just $1) emptyPrefixSuffix $3 $4 Nothing (reverse $5) Nothing }
| function NAME MAYBE_ARGUMENTS BLOCKS NEWLINE ENDFUN
{ PUFunction () (getTransSpan $1 $6) Nothing emptyPrefixSuffix $2 $3 Nothing (reverse $4) Nothing }
| subroutine NAME MAYBE_ARGUMENTS BLOCKS NEWLINE ENDSUB
{ PUSubroutine () (getTransSpan $1 $6) emptyPrefixSuffix $2 $3 (reverse $4) Nothing }
| blockData BLOCKS NEWLINE END { PUBlockData () (getTransSpan $1 $4) Nothing (reverse $2) }
| blockData NAME BLOCKS NEWLINE END { PUBlockData () (getTransSpan $1 $5) (Just $2) (reverse $3) }
| comment { let (TComment s c) = $1 in PUComment () s (Comment c) }

END :: { Token }
Expand Down Expand Up @@ -236,38 +236,36 @@ MAYBE_ID :: { Maybe Name }
NAME :: { Name } : id { let (TId _ name) = $1 in name }

INCLUDES :: { [ Block A0 ] }
: maybe(NEWLINE) list(BLOCK) { $2 }
: BLOCKS maybe(NEWLINE) { $1 }

BLOCKS :: { [ Block A0 ] }
: BLOCKS BLOCK { $2 : $1 }
: BLOCKS NEWLINE BLOCK { $3 : $1 }
| BLOCK { [ $1 ] }
| {- EMPTY -} { [ ] }

BLOCK :: { Block A0 }
: IF_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 }
: IF_BLOCK { $1 }
| LABEL_IN_6COLUMN STATEMENT { BlStatement () (getTransSpan $1 $2) (Just $1) $2 }
| STATEMENT { BlStatement () (getSpan $1) Nothing $1 }
| comment { let (TComment s c) = $1 in BlComment () s (Comment c) }

IF_BLOCK :: { Block A0 }
: if '(' EXPRESSION ')' then NEWLINE BLOCKS ELSE_BLOCKS
: if '(' EXPRESSION ')' then BLOCKS NEWLINE ELSE_BLOCKS
{ let (clauses, elseBlock, endSpan, endLabel) = $8
in BlIf () (getTransSpan $1 endSpan) Nothing Nothing (($3, reverse $7) :| clauses) elseBlock endLabel }
| LABEL_IN_6COLUMN if '(' EXPRESSION ')' then NEWLINE BLOCKS ELSE_BLOCKS
in BlIf () (getTransSpan $1 endSpan) Nothing Nothing (($3, reverse $6) :| clauses) elseBlock endLabel }
| LABEL_IN_6COLUMN if '(' EXPRESSION ')' then BLOCKS NEWLINE ELSE_BLOCKS
{ let (clauses, elseBlock, endSpan, endLabel) = $9
in BlIf () (getTransSpan $1 endSpan) (Just $1) Nothing (($4, reverse $8) :| clauses) elseBlock endLabel }
in BlIf () (getTransSpan $1 endSpan) (Just $1) Nothing (($4, reverse $7) :| clauses) elseBlock endLabel }

ELSE_BLOCKS :: { ([(Expression A0, [Block A0])], Maybe [Block A0], SrcSpan, Maybe (Expression A0)) }
: maybe(LABEL_IN_6COLUMN) elsif '(' EXPRESSION ')' then NEWLINE BLOCKS ELSE_BLOCKS
: maybe(LABEL_IN_6COLUMN) elsif '(' EXPRESSION ')' then BLOCKS NEWLINE ELSE_BLOCKS
{ let (clauses, elseBlock, endSpan, endLabel) = $9
in (($4, reverse $8) : clauses, elseBlock, endSpan, endLabel) }
| maybe(LABEL_IN_6COLUMN) else NEWLINE BLOCKS maybe(LABEL_IN_6COLUMN) endif
{ ([], Just (reverse $4), getSpan $6, $5) }
in (($4, reverse $7) : clauses, elseBlock, endSpan, endLabel) }
| maybe(LABEL_IN_6COLUMN) else BLOCKS NEWLINE maybe(LABEL_IN_6COLUMN) endif
{ ([], Just (reverse $3), getSpan $6, $5) }
| maybe(LABEL_IN_6COLUMN) endif
{ ([], Nothing, getSpan $2, $1) }

COMMENT_BLOCK :: { Block A0 }
: comment NEWLINE { let (TComment s c) = $1 in BlComment () s (Comment c) }

NEWLINE :: { Token }
: NEWLINE newline { $1 }
| newline { $1 }
Expand Down
1 change: 1 addition & 0 deletions test-data/f77-include/no-newline/foo.f
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1 @@
integer a
46 changes: 25 additions & 21 deletions test/Language/Fortran/Parser/Fixed/Fortran77/IncludeSpec.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -22,31 +22,35 @@ spec =
" include 'foo.f'",
" end"
]
inc = "./test-data/f77-include"
name = "bar"
pf = ProgramFile mi77' [pu]
puSpan = makeSrcR (6,7,1,"<unknown>") (48,9,3,"<unknown>")
st1Span = makeSrcR (24,7,2,"<unknown>") (38,21,2,"<unknown>")
expSpan = makeSrcR (32,15,2,"<unknown>") (38,21,2,"<unknown>")
pf inc = ProgramFile mi77' [pu]
where
-- the expansion returns the span in the included file
-- it should return the span at the inclusion
foo = inc </> "foo.f"
st2Span = makeSrcR (6,7,1, foo) (14,15,1,foo)
declSpan = makeSrcR (6,7,1,foo) (14,15,1,foo)
typeSpan = makeSrcR (6,7,1,foo) (12,13,1,foo)
blockSpan = makeSrcR (14,15,1,foo) (14,15,1,foo)
varGen' str = ExpValue () blockSpan $ ValVariable str

-- the expansion returns the span in the included file
-- it should return the span at the inclusion
foo = inc </> "foo.f"
st2Span = makeSrcR (6,7,1, foo) (14,15,1,foo)
declSpan = makeSrcR (6,7,1,foo) (14,15,1,foo)
typeSpan = makeSrcR (6,7,1,foo) (12,13,1,foo)
blockSpan = makeSrcR (14,15,1,foo) (14,15,1,foo)
varGen' str = ExpValue () blockSpan $ ValVariable str

pu = PUMain () puSpan (Just name) blocks Nothing
blocks = [bl1]
decl = Declarator () blockSpan (varGen' "a") ScalarDecl Nothing Nothing
typeSpec = TypeSpec () typeSpan TypeInteger Nothing
st2 = StDeclaration () st2Span typeSpec Nothing (AList () blockSpan [decl])
bl1 = BlStatement () st1Span Nothing st1
st1 = StInclude () st1Span ex (Just [bl2])
ex = ExpValue () expSpan (ValString "foo.f")
bl2 = BlStatement () declSpan Nothing st2
pu = PUMain () puSpan (Just name) blocks Nothing
blocks = [bl1]
decl = Declarator () blockSpan (varGen' "a") ScalarDecl Nothing Nothing
typeSpec = TypeSpec () typeSpan TypeInteger Nothing
st2 = StDeclaration () st2Span typeSpec Nothing (AList () blockSpan [decl])
bl1 = BlStatement () st1Span Nothing st1
st1 = StInclude () st1Span ex (Just [bl2])
ex = ExpValue () expSpan (ValString "foo.f")
bl2 = BlStatement () declSpan Nothing st2
it "includes some files and expands them" $ do
let inc = "." </> "test-data" </> "f77-include"
pfParsed <- iParser [inc] source
pfParsed `shouldBe` pf inc
it "includes without a newline behave the same" $ do
let inc = "." </> "test-data" </> "f77-include" </> "no-newline"
pfParsed <- iParser [inc] source
pfParsed `shouldBe` pf
pfParsed `shouldBe` pf inc
27 changes: 15 additions & 12 deletions test/Language/Fortran/Parser/Fixed/Fortran77/ParserSpec.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,6 +11,7 @@ import qualified Language.Fortran.Parser.Fixed.Fortran77 as F77
import qualified Language.Fortran.Parser.Fixed.Lexer as Fixed

import Prelude hiding ( exp )
import Data.List ( intercalate )
import qualified Data.ByteString.Char8 as B

parseWith :: FortranVersion -> Parse Fixed.AlexInput Fixed.Token a -> String -> a
Expand Down Expand Up @@ -217,23 +218,25 @@ spec =

it "unlabelled" $ do
let bl = BlIf () u Nothing Nothing ((valTrue, inner) :| []) (Just inner) Nothing
src = unlines [ " if (.true.) then ! comment if"
, " print *, 'foo'"
, " else ! comment else"
, " print *, 'foo'"
, " endif ! comment end"
]
src = intercalate "\n"
[ " if (.true.) then ! comment if"
, " print *, 'foo'"
, " else ! comment else"
, " print *, 'foo'"
, " endif ! comment end"
]
bParser src `shouldBe'` bl

it "labelled" $ do
let label = Just . intGen
bl = BlIf () u (label 10) Nothing ((valTrue, inner) :| []) (Just inner) (label 30)
src = unlines [ "10 if (.true.) then ! comment if"
, " print *, 'foo'"
, "20 else ! comment else"
, " print *, 'foo'"
, "30 endif ! comment end"
]
src = intercalate "\n"
[ "10 if (.true.) then ! comment if"
, " print *, 'foo'"
, "20 else ! comment else"
, " print *, 'foo'"
, "30 endif ! comment end"
]
bParser src `shouldBe'` bl

describe "Legacy Extensions" $ do
Expand Down

0 comments on commit 78f5211

Please sign in to comment.