diff --git a/src/Language/Fortran/Parser/Free/Fortran90.y b/src/Language/Fortran/Parser/Free/Fortran90.y index 3a52e94a..08ae354d 100644 --- a/src/Language/Fortran/Parser/Free/Fortran90.y +++ b/src/Language/Fortran/Parser/Free/Fortran90.y @@ -21,6 +21,7 @@ import Language.Fortran.AST 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 @@ import qualified Data.List as List 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 @@ NONEXECUTABLE_STATEMENT :: { Statement A0 } -- 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 index 42bf11e6..92944ae6 100644 --- a/src/Language/Fortran/Parser/Free/Lexer.x +++ b/src/Language/Fortran/Parser/Free/Lexer.x @@ -146,6 +146,14 @@ tokens :- <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 @@ fillConstr = toConstr . ($ undefined) -- 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 @@ data Token = | 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 index e3a991b4..1e198857 100644 --- a/src/Language/Fortran/PrettyPrint.hs +++ b/src/Language/Fortran/PrettyPrint.hs @@ -480,7 +480,7 @@ instance Pretty (Statement a) where | 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 @@ instance Pretty (Statement a) where | 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 index 7cee0325..a45b727e 100644 --- a/src/Language/Fortran/Util/Files.hs +++ b/src/Language/Fortran/Util/Files.hs @@ -12,7 +12,7 @@ import qualified Data.Text.Encoding as T 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 index ea656014..a68a464d 100644 --- a/src/Language/Fortran/Version.hs +++ b/src/Language/Fortran/Version.hs @@ -24,6 +24,7 @@ data FortranVersion = Fortran66 | Fortran77Extended -- ^ F77 with some extensions | Fortran77Legacy -- ^ F77 with most extensions | Fortran90 + | Fortran90Legacy -- ^ F90 with legacy extensions | Fortran95 | Fortran2003 | Fortran2008 @@ -35,6 +36,7 @@ instance Show FortranVersion where 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 @@ fortranVersionAliases = [ ("66" , Fortran66) , ("77l", Fortran77Legacy) , ("77" , Fortran77) , ("90" , Fortran90) + , ("90l", Fortran90Legacy) , ("95" , Fortran95) , ("03" , Fortran2003) , ("08" , Fortran2008) ] diff --git a/test/Language/Fortran/Parser/Free/Fortran90Spec.hs b/test/Language/Fortran/Parser/Free/Fortran90Spec.hs index f6dddd5e..50b77ae8 100644 --- a/test/Language/Fortran/Parser/Free/Fortran90Spec.hs +++ b/test/Language/Fortran/Parser/Free/Fortran90Spec.hs @@ -17,21 +17,24 @@ import qualified Language.Fortran.Parser.Free.Lexer as Free --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 @@ spec = 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