diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,6 @@ +### 0.16.9 + * Added support for legacy features in Fortran 90 free-form style + ### 0.16.8 * Package build support up to GHC 9.12 * Fixed pretty printing of array semantic types diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -64,7 +64,7 @@ ``` Usage: fortran-src [OPTION...] --version show fortran-src version - -v VERSION, -F VERSION --fortranVersion=VERSION Fortran version to use, format: Fortran[66/77/77Legacy/77Extended/90/2003] + -v VERSION, -F VERSION --fortranVersion=VERSION Fortran version to use, format: Fortran[66/77/77Legacy/77Extended/90/90Legacy/2003] -a ACTION --action=ACTION choose the action, possible values: lex|parse -t --typecheck parse and run typechecker -R --rename parse and rename variables diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -51,7 +51,7 @@ programName = "fortran-src" showVersion :: String -showVersion = "0.16.8" +showVersion = "0.16.9" main :: IO () main = do @@ -348,7 +348,7 @@ , Option ['v','F'] ["fortranVersion"] (ReqArg (\v opts -> opts { fortranVersion = selectFortranVersion v }) "VERSION") - "Fortran version to use, format: Fortran[66/77/77Legacy/77Extended/90/2003]" + "Fortran version to use, format: Fortran[66/77/77Legacy/77Extended/90/90Legacy/2003]" , Option ['a'] ["action"] (ReqArg (\a opts -> opts { action = read a }) "ACTION") diff --git a/fortran-src.cabal b/fortran-src.cabal --- a/fortran-src.cabal +++ b/fortran-src.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.38.1. +-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack name: fortran-src -version: 0.16.8 +version: 0.16.9 synopsis: Parsers and analyses for Fortran standards 66, 77, 90, 95 and 2003 (partial). description: Provides lexing, parsing, and basic analyses of Fortran code covering standards: FORTRAN 66, FORTRAN 77, Fortran 90, Fortran 95, Fortran 2003 (partial) and some legacy extensions. Includes data flow and basic block analysis, a renamer, and type analysis. For example usage, see the @@ project, which uses fortran-src as its front end. category: Language @@ -27,12 +27,9 @@ test-data/f77-include/foo.f test-data/f77-include/no-newline/foo.f test-data/module/leaf.f90 - test-data/module/leaf.mod test-data/module/mid1.f90 test-data/module/mid2.f90 test-data/module/top.f90 - test-data/pragma.f90 - test-data/pragma.f90.expected 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 @@ -64,10 +61,6 @@ test-data/rewriter/replacementsmap-simple/005_unicode.f test-data/rewriter/replacementsmap-simple/005_unicode.f.expected test-data/rewriter/temp-failure/fail.f - test-data/small.f90 - test-data/small.f90.expected - test-data/st.expected - test-data/st2.expected source-repository head type: git diff --git a/src/Language/Fortran/Parser/Free/Fortran90.y b/src/Language/Fortran/Parser/Free/Fortran90.y --- a/src/Language/Fortran/Parser/Free/Fortran90.y +++ b/src/Language/Fortran/Parser/Free/Fortran90.y @@ -21,6 +21,7 @@ import Prelude hiding ( EQ, LT, GT ) -- Same constructors exist in the AST import Data.Either ( partitionEithers ) import qualified Data.List as List +import Data.Maybe ( fromJust, isNothing, isJust ) } @@ -87,6 +88,14 @@ endBlockData { TEndBlockData _ } module { TModule _ } endModule { TEndModule _ } + structure { TStructure _ } + union { TUnion _ } + map { TMap _ } + endstructure { TEndStructure _ } + endunion { TEndUnion _ } + endmap { TEndMap _ } + automatic { TAutomatic _ } + static { TStatic _ } contains { TContains _ } use { TUse _ } only { TOnly _ } @@ -528,6 +537,43 @@ -- Must be fixed in the future. TODO | format blob { let TBlob s blob = $2 in StFormatBogus () (getTransSpan $1 s) blob } +| structure MAYBE_NAME NEWLINE STRUCTURE_DECLARATIONS endstructure + { StStructure () (getTransSpan $1 $5) $2 (fromReverseList $4) } +| automatic INITIALIZED_DECLARATOR_LIST + { let alist = fromReverseList $2 + in StAutomatic () (getTransSpan $1 alist) alist } +| static INITIALIZED_DECLARATOR_LIST + { let alist = fromReverseList $2 + in StStatic () (getTransSpan $1 alist) alist } + +MAYBE_NAME :: { Maybe Name } +: '/' NAME '/' { Just $2 } +| {- empty -} { Nothing } + +STRUCTURE_DECLARATIONS :: { [StructureItem A0] } +: STRUCTURE_DECLARATIONS STRUCTURE_DECLARATION_STATEMENT + { if isNothing $2 then $1 else fromJust $2 : $1 } +| STRUCTURE_DECLARATION_STATEMENT { if isNothing $1 then [] else [fromJust $1] } + +STRUCTURE_DECLARATION_STATEMENT :: { Maybe (StructureItem A0) } +: DECLARATION_STATEMENT NEWLINE + { let StDeclaration () s t attrs decls = $1 + in Just $ StructFields () s t attrs decls } +| union NEWLINE UNION_MAPS endunion NEWLINE + { Just $ StructUnion () (getTransSpan $1 $5) (fromReverseList $3) } +| structure MAYBE_NAME NAME NEWLINE STRUCTURE_DECLARATIONS endstructure NEWLINE + { Just $ StructStructure () (getTransSpan $1 $7) $2 $3 (fromReverseList $5) } +| comment NEWLINE { Nothing } + +UNION_MAPS :: { [ UnionMap A0 ] } +: UNION_MAPS UNION_MAP { if isNothing $2 then $1 else fromJust $2 : $1 } +| UNION_MAP { if isNothing $1 then [] else [fromJust $1] } + +UNION_MAP :: { Maybe (UnionMap A0) } +: map NEWLINE STRUCTURE_DECLARATIONS endmap NEWLINE + { Just $ UnionMap () (getTransSpan $1 $5) (fromReverseList $3) } +| comment NEWLINE { Nothing } + EXECUTABLE_STATEMENT :: { Statement A0 } : allocate '(' DATA_REFS MAYBE_ALLOC_OPT_LIST ')' diff --git a/src/Language/Fortran/Parser/Free/Lexer.x b/src/Language/Fortran/Parser/Free/Lexer.x --- a/src/Language/Fortran/Parser/Free/Lexer.x +++ b/src/Language/Fortran/Parser/Free/Lexer.x @@ -146,6 +146,14 @@ <0,scI> "return" { addSpan TReturn } <0> "entry" { addSpan TEntry } <0> "include" { addSpan TInclude } +<0> "structure" / { legacy90P } { addSpan TStructure } +<0> "end"\ *"structure" / { legacy90P } { addSpan TEndStructure } +<0> "union" / { legacy90P } { addSpan TUnion } +<0> "end"\ *"union" / { legacy90P } { addSpan TEndUnion } +<0> "map" { addSpan TMap } +<0> "end"\ *"map" { addSpan TEndMap } +<0> "automatic" / { legacy90P } { addSpan TAutomatic } +<0> "static" / { legacy90P } { addSpan TStatic } -- Type def related <0,scT> "type" { addSpan TType } @@ -643,6 +651,9 @@ -- Lexer helpers -------------------------------------------------------------------------------- +legacy90P :: User -> AlexInput -> Int -> AlexInput -> Bool +legacy90P (User fv _) _ _ _ = fv == Fortran90Legacy + adjustComment :: LexAction (Maybe Token) -> LexAction (Maybe Token) adjustComment action = do mTok <- action @@ -1261,6 +1272,14 @@ | TReturn SrcSpan | TEntry SrcSpan | TInclude SrcSpan + | TStructure SrcSpan + | TEndStructure SrcSpan + | TUnion SrcSpan + | TEndUnion SrcSpan + | TMap SrcSpan + | TEndMap SrcSpan + | TAutomatic SrcSpan + | TStatic SrcSpan -- language-binding-spec | TBind SrcSpan | TC SrcSpan diff --git a/src/Language/Fortran/PrettyPrint.hs b/src/Language/Fortran/PrettyPrint.hs --- a/src/Language/Fortran/PrettyPrint.hs +++ b/src/Language/Fortran/PrettyPrint.hs @@ -480,7 +480,7 @@ | otherwise = prettyError "unhandled version" pprint' v (StStructure _ _ mName itemList) = - olderThan Fortran77Legacy "Structure" v $ + continueOnlyFor [Fortran77Legacy, Fortran90Legacy] "Structure" v $ "structure" <+> (if isJust mName then "/" <> pprint' v mName <> "/" else empty) <> newline @@ -545,11 +545,11 @@ | otherwise = "data" <+> hsep (map (pprint' v) dataGroups) pprint' v (StAutomatic _ _ decls) = - continueOnlyFor [Fortran77Extended, Fortran77Legacy] "Automatic statement" v $ + continueOnlyFor [Fortran77Extended, Fortran77Legacy, Fortran90Legacy] "Automatic statement" v $ "automatic" <+> pprint' v decls pprint' v (StStatic _ _ decls) = - continueOnlyFor [Fortran77Extended, Fortran77Legacy] "Static statement" v $ + continueOnlyFor [Fortran77Extended, Fortran77Legacy, Fortran90Legacy] "Static statement" v $ "static" <+> pprint' v decls pprint' v (StNamelist _ _ namelist) diff --git a/src/Language/Fortran/Util/Files.hs b/src/Language/Fortran/Util/Files.hs --- a/src/Language/Fortran/Util/Files.hs +++ b/src/Language/Fortran/Util/Files.hs @@ -12,7 +12,7 @@ import qualified Data.Text.Encoding.Error as T import qualified Data.ByteString.Char8 as B import System.Directory (listDirectory, canonicalizePath, - doesDirectoryExist, getDirectoryContents) + doesDirectoryExist, getDirectoryContents, doesFileExist) import System.FilePath ((), takeExtension) import System.IO.Temp (withSystemTempDirectory) import System.Process (callProcess) diff --git a/src/Language/Fortran/Version.hs b/src/Language/Fortran/Version.hs --- a/src/Language/Fortran/Version.hs +++ b/src/Language/Fortran/Version.hs @@ -24,6 +24,7 @@ | Fortran77Extended -- ^ F77 with some extensions | Fortran77Legacy -- ^ F77 with most extensions | Fortran90 + | Fortran90Legacy -- ^ F90 with legacy extensions | Fortran95 | Fortran2003 | Fortran2008 @@ -35,6 +36,7 @@ show Fortran77Extended = "Fortran 77 Extended" show Fortran77Legacy = "Fortran 77 Legacy" show Fortran90 = "Fortran 90" + show Fortran90Legacy = "Fortran 90 Legacy" show Fortran95 = "Fortran 95" show Fortran2003 = "Fortran 2003" show Fortran2008 = "Fortran 2008" @@ -48,6 +50,7 @@ , ("77l", Fortran77Legacy) , ("77" , Fortran77) , ("90" , Fortran90) + , ("90l", Fortran90Legacy) , ("95" , Fortran95) , ("03" , Fortran2003) , ("08" , Fortran2008) ] diff --git a/test-data/module/leaf.mod b/test-data/module/leaf.mod deleted file mode 100644 Binary files a/test-data/module/leaf.mod and /dev/null differ diff --git a/test-data/pragma.f90 b/test-data/pragma.f90 deleted file mode 100644 --- a/test-data/pragma.f90 +++ /dev/null @@ -1,30 +0,0 @@ -module foo - implicit none - != unit s :: j - integer :: j -#ifdef PRAGMALAND - use iso_c_binding -#endif - != unit t :: k - integer :: k - -!! Example with a CPP ifdef - contains - subroutine main() - integer :: x - x = simple(k) + simple(1) - x = simple(j) - end subroutine - function simple(x) result(i) - integer :: x - integer :: i - i = x * x - ! thest -#ifdef CAM_PROFILE - print *, "Hello from simple" - i = i + 0 -#endif - ! thingummy - print *, "Hello from simple" - end function -end module diff --git a/test-data/pragma.f90.expected b/test-data/pragma.f90.expected deleted file mode 100644 --- a/test-data/pragma.f90.expected +++ /dev/null @@ -1,292 +0,0 @@ -ProgramFile {programFileMeta = MetaInfo {miVersion = Fortran90, - miFilename = "test-data/pragma.f90"}, - programFileProgramUnits = [PUModule () - (1:0)-(30:9) - "foo" - [BlStatement () - (2:2)-(2:14) - Nothing - (StImplicit () - (2:2)-(2:14) - Nothing), - BlComment () - (3:2)-(3:15) - (Comment "= unit s :: j"), - BlStatement () - (4:2)-(4:13) - Nothing - (StDeclaration () - (4:2)-(4:13) - (TypeSpec - {typeSpecAnno = (), - typeSpecSpan = (4:2)-(4:8), - typeSpecBaseType = TypeInteger, - typeSpecSelector = Nothing}) - Nothing - (AList - {alistAnno = (), - alistSpan = (4:13)-(4:13), - alistList = [Declarator {declaratorAnno = (), - declaratorSpan = (4:13)-(4:13), - declaratorVariable = ExpValue () - (4:13)-(4:13) - (ValVariable "j"), - declaratorType = ScalarDecl, - declaratorLength = Nothing, - declaratorInitial = Nothing}]})), - BlStatement () - (6:2)-(6:18) - Nothing - (StUse () - (6:2)-(6:18) - (ExpValue () - (6:6)-(6:18) - (ValVariable "iso_c_binding")) - Nothing - Permissive - Nothing), - BlComment () - (8:2)-(8:15) - (Comment "= unit t :: k"), - BlStatement () - (9:2)-(9:13) - Nothing - (StDeclaration () - (9:2)-(9:13) - (TypeSpec - {typeSpecAnno = (), - typeSpecSpan = (9:2)-(9:8), - typeSpecBaseType = TypeInteger, - typeSpecSelector = Nothing}) - Nothing - (AList - {alistAnno = (), - alistSpan = (9:13)-(9:13), - alistList = [Declarator {declaratorAnno = (), - declaratorSpan = (9:13)-(9:13), - declaratorVariable = ExpValue () - (9:13)-(9:13) - (ValVariable "k"), - declaratorType = ScalarDecl, - declaratorLength = Nothing, - declaratorInitial = Nothing}]})), - BlComment () - (11:0)-(11:26) - (Comment "! example with a cpp ifdef")] - (Just [PUSubroutine () - (13:4)-(17:17) - (Nothing, - Nothing) - "main" - Nothing - [BlStatement () - (14:6)-(14:17) - Nothing - (StDeclaration () - (14:6)-(14:17) - (TypeSpec - {typeSpecAnno = (), - typeSpecSpan = (14:6)-(14:12), - typeSpecBaseType = TypeInteger, - typeSpecSelector = Nothing}) - Nothing - (AList - {alistAnno = (), - alistSpan = (14:17)-(14:17), - alistList = [Declarator {declaratorAnno = (), - declaratorSpan = (14:17)-(14:17), - declaratorVariable = ExpValue () - (14:17)-(14:17) - (ValVariable "x"), - declaratorType = ScalarDecl, - declaratorLength = Nothing, - declaratorInitial = Nothing}]})), - BlStatement () - (15:6)-(15:30) - Nothing - (StExpressionAssign () - (15:6)-(15:30) - (ExpValue () - (15:6)-(15:6) - (ValVariable "x")) - (ExpBinary () - (15:10)-(15:30) - Addition - (ExpFunctionCall () - (15:10)-(15:18) - (ExpValue () - (15:10)-(15:15) - (ValVariable "simple")) - (AList - {alistAnno = (), - alistSpan = (15:17)-(15:17), - alistList = [Argument {argumentAnno = (), - argumentSpan = (15:17)-(15:17), - argumentName = Nothing, - argumentExpr = ArgExpr (ExpValue () - (15:17)-(15:17) - (ValVariable "k"))}]})) - (ExpFunctionCall () - (15:22)-(15:30) - (ExpValue () - (15:22)-(15:27) - (ValVariable "simple")) - (AList - {alistAnno = (), - alistSpan = (15:29)-(15:29), - alistList = [Argument {argumentAnno = (), - argumentSpan = (15:29)-(15:29), - argumentName = Nothing, - argumentExpr = ArgExpr (ExpValue () - (15:29)-(15:29) - (ValInteger "1" - Nothing))}]})))), - BlStatement () - (16:6)-(16:18) - Nothing - (StExpressionAssign () - (16:6)-(16:18) - (ExpValue () - (16:6)-(16:6) - (ValVariable "x")) - (ExpFunctionCall () - (16:10)-(16:18) - (ExpValue () - (16:10)-(16:15) - (ValVariable "simple")) - (AList - {alistAnno = (), - alistSpan = (16:17)-(16:17), - alistList = [Argument {argumentAnno = (), - argumentSpan = (16:17)-(16:17), - argumentName = Nothing, - argumentExpr = ArgExpr (ExpValue () - (16:17)-(16:17) - (ValVariable "j"))}]})))] - Nothing, - PUFunction () - (18:4)-(29:15) - Nothing - (Nothing, - Nothing) - "simple" - (Just AList {alistAnno = (), - alistSpan = (18:20)-(18:20), - alistList = [ExpValue () - (18:20)-(18:20) - (ValVariable "x")]}) - (Just ExpValue () - (18:30)-(18:30) - (ValVariable "i")) - [BlStatement () - (19:8)-(19:19) - Nothing - (StDeclaration () - (19:8)-(19:19) - (TypeSpec - {typeSpecAnno = (), - typeSpecSpan = (19:8)-(19:14), - typeSpecBaseType = TypeInteger, - typeSpecSelector = Nothing}) - Nothing - (AList - {alistAnno = (), - alistSpan = (19:19)-(19:19), - alistList = [Declarator {declaratorAnno = (), - declaratorSpan = (19:19)-(19:19), - declaratorVariable = ExpValue () - (19:19)-(19:19) - (ValVariable "x"), - declaratorType = ScalarDecl, - declaratorLength = Nothing, - declaratorInitial = Nothing}]})), - BlStatement () - (20:8)-(20:19) - Nothing - (StDeclaration () - (20:8)-(20:19) - (TypeSpec - {typeSpecAnno = (), - typeSpecSpan = (20:8)-(20:14), - typeSpecBaseType = TypeInteger, - typeSpecSelector = Nothing}) - Nothing - (AList - {alistAnno = (), - alistSpan = (20:19)-(20:19), - alistList = [Declarator {declaratorAnno = (), - declaratorSpan = (20:19)-(20:19), - declaratorVariable = ExpValue () - (20:19)-(20:19) - (ValVariable "i"), - declaratorType = ScalarDecl, - declaratorLength = Nothing, - declaratorInitial = Nothing}]})), - BlStatement () - (21:8)-(21:16) - Nothing - (StExpressionAssign () - (21:8)-(21:16) - (ExpValue () - (21:8)-(21:8) - (ValVariable "i")) - (ExpBinary () - (21:12)-(21:16) - Multiplication - (ExpValue () - (21:12)-(21:12) - (ValVariable "x")) - (ExpValue () - (21:16)-(21:16) - (ValVariable "x")))), - BlComment () - (22:8)-(22:14) - (Comment " thest"), - BlStatement () - (24:8)-(24:35) - Nothing - (StPrint () - (24:8)-(24:35) - (ExpValue () - (24:14)-(24:14) - ValStar) - (Just AList {alistAnno = (), - alistSpan = (24:17)-(24:35), - alistList = [ExpValue () - (24:17)-(24:35) - (ValString "Hello from simple")]})), - BlStatement () - (25:8)-(25:16) - Nothing - (StExpressionAssign () - (25:8)-(25:16) - (ExpValue () - (25:8)-(25:8) - (ValVariable "i")) - (ExpBinary () - (25:12)-(25:16) - Addition - (ExpValue () - (25:12)-(25:12) - (ValVariable "i")) - (ExpValue () - (25:16)-(25:16) - (ValInteger "0" - Nothing)))), - BlComment () - (27:8)-(27:18) - (Comment " thingummy"), - BlStatement () - (28:8)-(28:35) - Nothing - (StPrint () - (28:8)-(28:35) - (ExpValue () - (28:14)-(28:14) - ValStar) - (Just AList {alistAnno = (), - alistSpan = (28:17)-(28:35), - alistList = [ExpValue () - (28:17)-(28:35) - (ValString "Hello from simple")]}))] - Nothing])]} diff --git a/test-data/small.f90 b/test-data/small.f90 deleted file mode 100644 --- a/test-data/small.f90 +++ /dev/null @@ -1,17 +0,0 @@ -module foo - implicit none - ! comment - integer :: i - #ifdef PRAGMALAND - use iso_c_binding -#endif -contains -subroutine main() - integer :: x - x = simple(k) + simple(1) - x = simple(j) -end subroutine -function simple(x) result(i) - integer :: x -end function -end module diff --git a/test-data/small.f90.expected b/test-data/small.f90.expected deleted file mode 100644 --- a/test-data/small.f90.expected +++ /dev/null @@ -1,175 +0,0 @@ -ProgramFile {programFileMeta = MetaInfo {miVersion = Fortran90, - miFilename = "test-data/small.f90"}, - programFileProgramUnits = [PUModule () - (1:0)-(17:9) - "foo" - [BlStatement () - (2:2)-(2:14) - Nothing - (StImplicit () - (2:2)-(2:14) - Nothing), - BlComment () - (3:2)-(3:10) - (Comment " comment"), - BlStatement () - (4:2)-(4:13) - Nothing - (StDeclaration () - (4:2)-(4:13) - (TypeSpec - {typeSpecAnno = (), - typeSpecSpan = (4:2)-(4:8), - typeSpecBaseType = TypeInteger, - typeSpecSelector = Nothing}) - Nothing - (AList - {alistAnno = (), - alistSpan = (4:13)-(4:13), - alistList = [Declarator {declaratorAnno = (), - declaratorSpan = (4:13)-(4:13), - declaratorVariable = ExpValue () - (4:13)-(4:13) - (ValVariable "i"), - declaratorType = ScalarDecl, - declaratorLength = Nothing, - declaratorInitial = Nothing}]})), - BlStatement () - (6:2)-(6:18) - Nothing - (StUse () - (6:2)-(6:18) - (ExpValue () - (6:6)-(6:18) - (ValVariable "iso_c_binding")) - Nothing - Permissive - Nothing)] - (Just [PUSubroutine () - (9:0)-(13:13) - (Nothing, - Nothing) - "main" - Nothing - [BlStatement () - (10:2)-(10:13) - Nothing - (StDeclaration () - (10:2)-(10:13) - (TypeSpec - {typeSpecAnno = (), - typeSpecSpan = (10:2)-(10:8), - typeSpecBaseType = TypeInteger, - typeSpecSelector = Nothing}) - Nothing - (AList - {alistAnno = (), - alistSpan = (10:13)-(10:13), - alistList = [Declarator {declaratorAnno = (), - declaratorSpan = (10:13)-(10:13), - declaratorVariable = ExpValue () - (10:13)-(10:13) - (ValVariable "x"), - declaratorType = ScalarDecl, - declaratorLength = Nothing, - declaratorInitial = Nothing}]})), - BlStatement () - (11:2)-(11:26) - Nothing - (StExpressionAssign () - (11:2)-(11:26) - (ExpValue () - (11:2)-(11:2) - (ValVariable "x")) - (ExpBinary () - (11:6)-(11:26) - Addition - (ExpFunctionCall () - (11:6)-(11:14) - (ExpValue () - (11:6)-(11:11) - (ValVariable "simple")) - (AList - {alistAnno = (), - alistSpan = (11:13)-(11:13), - alistList = [Argument {argumentAnno = (), - argumentSpan = (11:13)-(11:13), - argumentName = Nothing, - argumentExpr = ArgExpr (ExpValue () - (11:13)-(11:13) - (ValVariable "k"))}]})) - (ExpFunctionCall () - (11:18)-(11:26) - (ExpValue () - (11:18)-(11:23) - (ValVariable "simple")) - (AList - {alistAnno = (), - alistSpan = (11:25)-(11:25), - alistList = [Argument {argumentAnno = (), - argumentSpan = (11:25)-(11:25), - argumentName = Nothing, - argumentExpr = ArgExpr (ExpValue () - (11:25)-(11:25) - (ValInteger "1" - Nothing))}]})))), - BlStatement () - (12:2)-(12:14) - Nothing - (StExpressionAssign () - (12:2)-(12:14) - (ExpValue () - (12:2)-(12:2) - (ValVariable "x")) - (ExpFunctionCall () - (12:6)-(12:14) - (ExpValue () - (12:6)-(12:11) - (ValVariable "simple")) - (AList - {alistAnno = (), - alistSpan = (12:13)-(12:13), - alistList = [Argument {argumentAnno = (), - argumentSpan = (12:13)-(12:13), - argumentName = Nothing, - argumentExpr = ArgExpr (ExpValue () - (12:13)-(12:13) - (ValVariable "j"))}]})))] - Nothing, - PUFunction () - (14:0)-(16:11) - Nothing - (Nothing, - Nothing) - "simple" - (Just AList {alistAnno = (), - alistSpan = (14:16)-(14:16), - alistList = [ExpValue () - (14:16)-(14:16) - (ValVariable "x")]}) - (Just ExpValue () - (14:26)-(14:26) - (ValVariable "i")) - [BlStatement () - (15:2)-(15:13) - Nothing - (StDeclaration () - (15:2)-(15:13) - (TypeSpec - {typeSpecAnno = (), - typeSpecSpan = (15:2)-(15:8), - typeSpecBaseType = TypeInteger, - typeSpecSelector = Nothing}) - Nothing - (AList - {alistAnno = (), - alistSpan = (15:13)-(15:13), - alistList = [Declarator {declaratorAnno = (), - declaratorSpan = (15:13)-(15:13), - declaratorVariable = ExpValue () - (15:13)-(15:13) - (ValVariable "x"), - declaratorType = ScalarDecl, - declaratorLength = Nothing, - declaratorInitial = Nothing}]}))] - Nothing])]} diff --git a/test-data/st.expected b/test-data/st.expected deleted file mode 100644 --- a/test-data/st.expected +++ /dev/null @@ -1,10 +0,0 @@ -(StPrint () - (24:8)-(24:35) - (ExpValue () - (24:14)-(24:14) - ValStar) - (Just AList {alistAnno = (), - alistSpan = (24:17)-(24:35), - alistList = [ExpValue () - (24:17)-(24:35) - (ValString "Hello from simple")]})) diff --git a/test-data/st2.expected b/test-data/st2.expected deleted file mode 100644 --- a/test-data/st2.expected +++ /dev/null @@ -1,5 +0,0 @@ -TypeSpec - {typeSpecAnno = (), - typeSpecSpan = (4:2)-(4:8), - typeSpecBaseType = TypeInteger, - typeSpecSelector = Nothing} diff --git a/test/Language/Fortran/Parser/Free/Fortran90Spec.hs b/test/Language/Fortran/Parser/Free/Fortran90Spec.hs --- a/test/Language/Fortran/Parser/Free/Fortran90Spec.hs +++ b/test/Language/Fortran/Parser/Free/Fortran90Spec.hs @@ -17,21 +17,24 @@ --import qualified Data.List as List import qualified Data.ByteString.Char8 as B -parseWith :: Parse Free.AlexInput Free.Token a -> String -> a -parseWith p = parseUnsafe (makeParserFree p Fortran90) . B.pack +parseWith :: FortranVersion -> Parse Free.AlexInput Free.Token a -> String -> a +parseWith v p = parseUnsafe (makeParserFree p v) . B.pack eParser :: String -> Expression () eParser = parseUnsafe p . B.pack where p = makeParser initParseStateFreeExpr F90.expressionParser Fortran90 sParser :: String -> Statement () -sParser = parseWith F90.statementParser +sParser = parseWith Fortran90 F90.statementParser +slParser :: String -> Statement () +slParser = parseWith Fortran90Legacy F90.statementParser + bParser :: String -> Block () -bParser = parseWith F90.blockParser +bParser = parseWith Fortran90 F90.blockParser fParser :: String -> ProgramUnit () -fParser = parseWith F90.functionParser +fParser = parseWith Fortran90 F90.functionParser {- Useful for parser debugging; Lexes the given source code. fTok :: String -> [Token] @@ -484,3 +487,83 @@ sParser "use stats_lib, only: a, b => c, operator(+), assignment(=)" `shouldBe'` st specFreeCommon bParser sParser eParser + + describe "Legacy Extensions" $ do + it "parses automatic and static statements" $ do + let decl = declVariable () u (varGen "x") Nothing Nothing + autoStmt = StAutomatic () u (AList () u [decl]) + staticStmt = StStatic () u (AList () u [decl]) + autoSrc = "automatic x" + staticSrc = "static x" + resetSrcSpan (slParser autoSrc) `shouldBe` autoStmt + resetSrcSpan (slParser staticSrc) `shouldBe` staticStmt + + it "parses structure/union/map blocks" $ do + let src = init + $ unlines [ "structure /foo/" + , " union" + , " map" + , " integer i" + , " end map" + , " map" + , " real r" + , " end map" + , " end union" + , "end structure"] + ds = [ UnionMap () u $ AList () u + [StructFields () u (TypeSpec () u TypeInteger Nothing) Nothing $ + AList () u [declVariable () u (varGen "i") Nothing Nothing]] + , UnionMap () u $ AList () u + [StructFields () u (TypeSpec () u TypeReal Nothing) Nothing $ + AList () u [declVariable () u (varGen "r") Nothing Nothing]] + ] + st = StStructure () u (Just "foo") $ AList () u [StructUnion () u $ AList () u ds] + resetSrcSpan (slParser src) `shouldBe` st + + it "parses structure/union/map blocks with comments" $ do + let src = init + $ unlines [ "structure /foo/" + , "! comment before union" + , " union" + , "! comment inside union, before map" + , " map" + , "! comment inside map" + , " integer i" + , " end map" + , "! comment between maps" + , " map" + , " real r" + , " end map" + , "! comment after map" + , " end union" + , "! comment after union" + , "end structure"] + ds = [ UnionMap () u $ AList () u + [StructFields () u (TypeSpec () u TypeInteger Nothing) Nothing $ + AList () u [declVariable () u (varGen "i") Nothing Nothing]] + , UnionMap () u $ AList () u + [StructFields () u (TypeSpec () u TypeReal Nothing) Nothing $ + AList () u [declVariable () u (varGen "r") Nothing Nothing]] + ] + st = StStructure () u (Just "foo") $ AList () u [StructUnion () u $ AList () u ds] + resetSrcSpan (slParser src) `shouldBe` st + + it "parses nested structure blocks" $ do + let src = init + $ unlines [ "structure /foo/" + , " structure /bar/ baz" + , " integer qux" + , " end structure" + , "end structure"] + var = declVariable () u (varGen "qux") Nothing Nothing + innerst = StructStructure () u (Just "bar") "baz" + $ AList () u [StructFields () u (TypeSpec () u TypeInteger Nothing) Nothing + $ AList () u [var]] + st = StStructure () u (Just "foo") $ AList () u [innerst] + resetSrcSpan (slParser src) `shouldBe` st + + it "parses structure data references" $ do + let st = StPrint () u expStar $ Just $ AList () u [foobar] + foobar = ExpDataRef () u (varGen "foo") (varGen "bar") + expStar = ExpValue () u ValStar + sParser "print *, foo % bar" `shouldBe'` st