Skip to content

Commit 8204f52

Browse files
gridaphobemrd
gridaphobe
authored and
mrd
committed
add tests for Fortran77Legacy
1 parent 25b48be commit 8204f52

File tree

4 files changed

+201
-13
lines changed

4 files changed

+201
-13
lines changed

‎src/Language/Fortran/Lexer/FixedForm.x‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -80,7 +80,7 @@ tokens :-
8080

8181
<0,st,keyword,iif,assn,doo> \n { resetPar >> toSC 0 >> addSpan TNewline }
8282
<0,st,keyword,iif,assn,doo> \r ;
83-
<0,st,keyword,iif,assn,doo> ";" { resetPar >> toSC 0 >> addSpan TNewline }
83+
<0,st,keyword,iif,assn,doo> ";" { resetPar >> toSC keyword >> addSpan TNewline }
8484

8585
<st> "(" { addSpan TLeftPar }
8686
<keyword> "(" / { legacy77P } { addSpan TLeftPar }

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

Lines changed: 4 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -893,21 +893,13 @@ RELATIONAL_OPERATOR
893893

894894
SUBSCRIPT :: { Expression A0 }
895895
SUBSCRIPT
896-
: SUBSCRIPT '.' SUBSCRIPT_ITEM
896+
: SUBSCRIPT '.' VARIABLE
897897
{ ExpDataRef () (getTransSpan $1 $3) $1 $3 }
898-
| SUBSCRIPT_ITEM
899-
{ $1 }
900-
901-
SUBSCRIPT_ITEM :: { Expression A0 }
902-
SUBSCRIPT_ITEM
903-
: VARIABLE { $1 }
904-
| VARIABLE '(' ')'
898+
| SUBSCRIPT '(' ')'
905899
{ ExpFunctionCall () (getTransSpan $1 $3) $1 Nothing }
906-
| VARIABLE '(' INDICIES ')'
900+
| SUBSCRIPT '(' INDICIES ')'
907901
{ ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3) }
908-
| VARIABLE '(' INDICIES ')' '(' INDICIES ')'
909-
{ let innerSub = ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3)
910-
in ExpSubscript () (getTransSpan $1 $7) innerSub (fromReverseList $6) }
902+
| VARIABLE { $1 }
911903

912904
INDICIES :: { [ Index A0 ] }
913905
: INDICIES ',' INDEX { $3 : $1 }

‎test/Language/Fortran/Lexer/FixedFormSpec.hs‎

Lines changed: 107 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -149,6 +149,113 @@ spec =
149149
resetSrcSpan (collectFixedTokens' Fortran77 " INTEGER IF")
150150
`shouldBe` resetSrcSpan [TType u "integer", TId u "if", TEOF u]
151151

152+
describe "Fortran 77 Legacy" $ do
153+
it "lexes inline comments" $ do
154+
resetSrcSpan (collectFixedTokens' Fortran77Legacy " integer foo ! bar")
155+
`shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TEOF u]
156+
157+
it "lexes continuation lines separated by comments" $ do
158+
let src = unlines [ " integer foo,"
159+
, "C hello"
160+
, " + bar"
161+
]
162+
resetSrcSpan (collectFixedTokens' Fortran77Legacy src)
163+
`shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TComma u, TId u "bar", TNewline u, TEOF u]
164+
let src = unlines [ " integer foo, ! hello"
165+
, " + bar"
166+
]
167+
resetSrcSpan (collectFixedTokens' Fortran77Legacy src)
168+
`shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TComma u, TId u "bar", TNewline u, TEOF u]
169+
let src = unlines [ " integer foo,"
170+
, ""
171+
, " + bar"
172+
]
173+
resetSrcSpan (collectFixedTokens' Fortran77Legacy src)
174+
`shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TComma u, TId u "bar", TNewline u, TEOF u]
175+
let src = unlines [ " integer foo,"
176+
, " " -- the space is intentional
177+
, " + bar"
178+
]
179+
resetSrcSpan (collectFixedTokens' Fortran77Legacy src)
180+
`shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TComma u, TId u "bar", TNewline u, TEOF u]
181+
182+
it "lexes the older TYPE statement" $ do
183+
resetSrcSpan (collectFixedTokens' Fortran77Legacy " type *, 'hello'")
184+
`shouldBe` resetSrcSpan [TTypePrint u, TStar u, TComma u, TString u "hello", TEOF u]
185+
186+
it "lexes width-specific type declarations" $ do
187+
resetSrcSpan (collectFixedTokens' Fortran77Legacy " integer*4 i")
188+
`shouldBe` resetSrcSpan [TType u "integer", TStar u, TInt u "4", TId u "i", TEOF u]
189+
190+
resetSrcSpan (collectFixedTokens' Fortran77Legacy " integer*4 function foo()")
191+
`shouldBe` resetSrcSpan [TType u "integer", TStar u, TInt u "4", TFunction u, TId u "foo", TLeftPar u, TRightPar u, TEOF u]
192+
193+
resetSrcSpan (collectFixedTokens' Fortran77Legacy " character*4 s")
194+
`shouldBe` resetSrcSpan [TType u "character", TStar u, TInt u "4", TId u "s", TEOF u]
195+
196+
resetSrcSpan (collectFixedTokens' Fortran77Legacy " character*(*) s")
197+
`shouldBe` resetSrcSpan [TType u "character", TStar u, TLeftPar u, TStar u, TRightPar u, TId u "s", TEOF u]
198+
199+
resetSrcSpan (collectFixedTokens' Fortran77Legacy " character s*(*)")
200+
`shouldBe` resetSrcSpan [TType u "character", TId u "s", TStar u, TLeftPar u, TStar u, TRightPar u, TEOF u]
201+
202+
it "lexes strings case-sensitively" $ do
203+
resetSrcSpan (collectFixedTokens' Fortran77Legacy " c = 'Hello'")
204+
`shouldBe` resetSrcSpan [TId u "c", TOpAssign u, TString u "Hello", TEOF u]
205+
206+
it "lexes strings delimited by '\"'" $ do
207+
resetSrcSpan (collectFixedTokens' Fortran77Legacy " c = \"hello\"")
208+
`shouldBe` resetSrcSpan [TId u "c", TOpAssign u, TString u "hello", TEOF u]
209+
210+
it "lexes Hollerith constants" $ do
211+
resetSrcSpan (collectFixedTokens' Fortran77Legacy " x = 7hmistral")
212+
`shouldBe` resetSrcSpan [TId u "x", TOpAssign u, THollerith u "mistral", TEOF u]
213+
214+
resetSrcSpan (collectFixedTokens' Fortran77Legacy " x = 7hshort\n")
215+
`shouldBe` resetSrcSpan [TId u "x", TOpAssign u, THollerith u "short ", TNewline u, TEOF u]
216+
217+
it "lexes BOZ constants" $ do
218+
resetSrcSpan (collectFixedTokens' Fortran77Legacy " integer i, j, k / b'0101', o'0755', z'ab01' /")
219+
`shouldBe` resetSrcSpan [ TType u "integer", TId u "i", TComma u, TId u "j", TComma u, TId u"k"
220+
, TSlash u, TBozInt u "b'0101'", TComma u, TBozInt u "o'0755'", TComma u, TBozInt u "z'ab01'", TSlash u
221+
, TEOF u ]
222+
223+
it "lexes non-standard identifiers" $ do
224+
resetSrcSpan (collectFixedTokens' Fortran77Legacy " integer _this_is_a_long_identifier$")
225+
`shouldBe` resetSrcSpan [TType u "integer", TId u "_this_is_a_long_identifier$", TEOF u]
226+
227+
it "lexes ';' as a line-terminator" $ do
228+
resetSrcSpan (collectFixedTokens' Fortran77Legacy " integer i; integer j")
229+
`shouldBe` resetSrcSpan [TType u "integer", TId u "i", TNewline u, TType u "integer", TId u "j", TEOF u]
230+
231+
it "lexes subscripts in assignments" $ do
232+
resetSrcSpan (collectFixedTokens' Fortran77Legacy " x(0,0) = 0")
233+
`shouldBe` resetSrcSpan [TId u "x", TLeftPar u, TInt u "0", TComma u, TInt u "0", TRightPar u, TOpAssign u, TInt u "0", TEOF u]
234+
235+
it "lexes labeled DO WHILE blocks" $ do
236+
resetSrcSpan (collectFixedTokens' Fortran77Legacy " do 10 while (.true.)")
237+
`shouldBe` resetSrcSpan [TDo u, TInt u "10", TWhile u, TLeftPar u, TBool u ".true.", TRightPar u, TEOF u]
238+
239+
240+
it "lexes structure/union/map blocks" $ do
241+
let src = unlines [ " structure /foo/"
242+
, " union"
243+
, " map"
244+
, " integer i"
245+
, " real r"
246+
, " end map"
247+
, " end union"
248+
, " end structure"]
249+
resetSrcSpan (collectFixedTokens' Fortran77Legacy src)
250+
`shouldBe` resetSrcSpan [ TStructure u, TSlash u, TId u "foo", TSlash u, TNewline u
251+
, TUnion u, TNewline u
252+
, TMap u, TNewline u
253+
, TType u "integer", TId u "i", TNewline u
254+
, TType u "real", TId u "r", TNewline u
255+
, TEndMap u, TNewline u
256+
, TEndUnion u, TNewline u
257+
, TEndStructure u, TNewline u
258+
, TEOF u ]
152259

153260
example1 = unlines [
154261
" intEGerix",

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

Lines changed: 89 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -21,6 +21,10 @@ sParser :: String -> Statement ()
2121
sParser sourceCode =
2222
evalParse statementParser $ initParseState (B.pack sourceCode) Fortran77 "<unknown>"
2323

24+
slParser :: String -> Statement ()
25+
slParser sourceCode =
26+
evalParse statementParser $ initParseState (B.pack sourceCode) Fortran77Legacy "<unknown>"
27+
2428
iParser :: String -> [Block ()]
2529
iParser sourceCode =
2630
fromParseResultUnsafe $ includeParser Fortran77Legacy (B.pack sourceCode) "<unknown>"
@@ -200,6 +204,91 @@ spec =
200204
let bl = BlStatement () u Nothing st
201205
iParser " integer a" `shouldBe'` [bl]
202206

207+
describe "Legacy Extensions" $ do
208+
it "parses structure/union/map blocks" $ do
209+
let src = init
210+
$ unlines [ " structure /foo/"
211+
, " union"
212+
, " map"
213+
, " integer i"
214+
, " end map"
215+
, " map"
216+
, " real r"
217+
, " end map"
218+
, " end union"
219+
, " end structure"]
220+
let ds = [ UnionMap () u $ AList () u
221+
[StructFields () u (TypeSpec () u TypeInteger Nothing) Nothing $
222+
AList () u [DeclVariable () u (varGen "i") Nothing Nothing]]
223+
, UnionMap () u $ AList () u
224+
[StructFields () u (TypeSpec () u TypeReal Nothing) Nothing $
225+
AList () u [DeclVariable () u (varGen "r") Nothing Nothing]]
226+
]
227+
let st = StStructure () u (Just "foo") $ AList () u [StructUnion () u $ AList () u ds]
228+
resetSrcSpan (slParser src) `shouldBe` st
229+
230+
it "parses character declarations with unspecfied lengths" $ do
231+
let src = " character s*(*)"
232+
let st = StDeclaration () u (TypeSpec () u TypeCharacter Nothing) Nothing $
233+
AList () u [DeclVariable () u
234+
(ExpValue () u (ValVariable "s"))
235+
(Just (ExpValue () u ValStar))
236+
Nothing]
237+
resetSrcSpan (slParser src) `shouldBe` st
238+
239+
it "parses array initializers" $ do
240+
let src = " integer xs(3) / 1, 2, 3 /"
241+
let inits = [ExpValue () u (ValInteger "1"), ExpValue () u (ValInteger "2"), ExpValue () u (ValInteger "3")]
242+
let st = StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing $
243+
AList () u [DeclArray () u
244+
(ExpValue () u (ValVariable "xs"))
245+
(AList () u [DimensionDeclarator () u Nothing (Just (ExpValue () u (ValInteger "3")))])
246+
Nothing
247+
(Just (ExpInitialisation () u $ AList () u inits))]
248+
resetSrcSpan (slParser src) `shouldBe` st
249+
250+
let src = " character xs(2)*5 / 'hello', 'world' /"
251+
let inits = [ExpValue () u (ValString "hello"), ExpValue () u (ValString "world")]
252+
let st = StDeclaration () u (TypeSpec () u TypeCharacter Nothing) Nothing $
253+
AList () u [DeclArray () u
254+
(ExpValue () u (ValVariable "xs"))
255+
(AList () u [DimensionDeclarator () u Nothing (Just (ExpValue () u (ValInteger "2")))])
256+
(Just (ExpValue () u (ValInteger "5")))
257+
(Just (ExpInitialisation () u $ AList () u inits))]
258+
resetSrcSpan (slParser src) `shouldBe` st
259+
260+
let src = " character xs*5(2) / 'hello', 'world' /"
261+
let inits = [ExpValue () u (ValString "hello"), ExpValue () u (ValString "world")]
262+
let st = StDeclaration () u (TypeSpec () u TypeCharacter Nothing) Nothing $
263+
AList () u [DeclArray () u
264+
(ExpValue () u (ValVariable "xs"))
265+
(AList () u [DimensionDeclarator () u Nothing (Just (ExpValue () u (ValInteger "2")))])
266+
(Just (ExpValue () u (ValInteger "5")))
267+
(Just (ExpInitialisation () u $ AList () u inits))]
268+
resetSrcSpan (slParser src) `shouldBe` st
269+
270+
it "parses subscripts in assignments" $ do
271+
let mkIdx i = IxSingle () u Nothing (ExpValue () u (ValInteger i))
272+
273+
let src = " x(0,1) = 0"
274+
let tgt = ExpSubscript () u (ExpValue () u (ValVariable "x")) (AList () u [mkIdx "0", mkIdx "1"])
275+
let st = StExpressionAssign () u tgt (ExpValue () u (ValInteger "0"))
276+
resetSrcSpan (slParser src) `shouldBe` st
277+
278+
let src = " x(0).foo = 0"
279+
let tgt = ExpDataRef () u (ExpSubscript () u (ExpValue () u (ValVariable "x")) (AList () u [mkIdx "0"])) (ExpValue () u (ValVariable "foo"))
280+
let st = StExpressionAssign () u tgt (ExpValue () u (ValInteger "0"))
281+
resetSrcSpan (slParser src) `shouldBe` st
282+
283+
let src = " x.foo = 0"
284+
let tgt = ExpDataRef () u (ExpValue () u (ValVariable "x")) (ExpValue () u (ValVariable "foo"))
285+
let st = StExpressionAssign () u tgt (ExpValue () u (ValInteger "0"))
286+
resetSrcSpan (slParser src) `shouldBe` st
287+
288+
let src = " x.foo(0) = 0"
289+
let tgt = ExpSubscript () u (ExpDataRef () u (ExpValue () u (ValVariable "x")) (ExpValue () u (ValVariable "foo"))) (AList () u [mkIdx "0"])
290+
let st = StExpressionAssign () u tgt (ExpValue () u (ValInteger "0"))
291+
resetSrcSpan (slParser src) `shouldBe` st
203292

204293
exampleProgram1 = unlines
205294
[ " program hello"

0 commit comments

Comments
 (0)