diff --git a/src/Language/Fortran/Parser.hs b/src/Language/Fortran/Parser.hs index 1980ed37..0df6bff4 100644 --- a/src/Language/Fortran/Parser.hs +++ b/src/Language/Fortran/Parser.hs @@ -17,6 +17,7 @@ module Language.Fortran.Parser , f66, f77, f77e, f77l, f90, f95, f2003 -- * Main parsers without post-parse transformation + , byVerNoTransform , f66NoTransform, f77NoTransform, f77eNoTransform, f77lNoTransform , f90NoTransform, f95NoTransform, f2003NoTransform @@ -30,6 +31,10 @@ module Language.Fortran.Parser , f66StmtNoTransform, f77StmtNoTransform, f77eStmtNoTransform , f77lStmtNoTransform, f90StmtNoTransform, f95StmtNoTransform , f2003StmtNoTransform + , byVerInclude + , f66IncludesNoTransform, f77IncludesNoTransform, f77eIncludesNoTransform + , f77lIncludesNoTransform, f90IncludesNoTransform, f95IncludesNoTransform + , f2003IncludesNoTransform -- * Various combinators , transformAs, defaultTransformation @@ -43,7 +48,10 @@ module Language.Fortran.Parser -- * F77 with inlined includes -- $f77includes - , f77lInlineIncludes + , byVerInlineIncludes + , f66InlineIncludes, f77InlineIncludes, f77eInlineIncludes + , f77lInlineIncludes, f90InlineIncludes , f95InlineIncludes + , f2003InlineIncludes ) where import Language.Fortran.AST @@ -175,6 +183,18 @@ byVerStmt = \case v -> error $ "Language.Fortran.Parser.byVerStmt: " <> "no parser available for requested version: " <> show v +byVerNoTransform :: FortranVersion -> Parser (ProgramFile A0) +byVerNoTransform = \case + Fortran66 -> f66NoTransform + Fortran77 -> f77NoTransform + Fortran77Legacy -> f77lNoTransform + Fortran77Extended -> f77eNoTransform + Fortran90 -> f90NoTransform + Fortran95 -> f90NoTransform + Fortran2003 -> f2003NoTransform + v -> error $ "Language.Fortran.Parser.byVerNoTransform: " + <> "no parser available for requested version: " + <> show v f90Expr :: Parser (Expression A0) f90Expr = makeParser initParseStateFreeExpr F90.expressionParser Fortran90 @@ -291,35 +311,47 @@ are thrown as IO exceptions. Can be cleaned up and generalized to use for other parsers. -} -f77lInlineIncludes - :: [FilePath] -> ModFiles -> String -> B.ByteString +f66InlineIncludes, f77InlineIncludes, f77eInlineIncludes, f77lInlineIncludes, + f90InlineIncludes, f95InlineIncludes, f2003InlineIncludes + :: [FilePath] -> ModFiles -> String -> B.ByteString -> IO (ProgramFile A0) +f66InlineIncludes = byVerInlineIncludes Fortran66 +f77lInlineIncludes = byVerInlineIncludes Fortran77Legacy +f77eInlineIncludes = byVerInlineIncludes Fortran77Extended +f77InlineIncludes = byVerInlineIncludes Fortran77 +f90InlineIncludes = byVerInlineIncludes Fortran90 +f95InlineIncludes = byVerInlineIncludes Fortran95 +f2003InlineIncludes = byVerInlineIncludes Fortran2003 + +byVerInlineIncludes + :: FortranVersion -> [FilePath] -> ModFiles -> String -> B.ByteString -> IO (ProgramFile A0) -f77lInlineIncludes incs mods fn bs = do - case f77lNoTransform fn bs of - Left e -> liftIO $ throwIO e - Right pf -> do - let pf' = pfSetFilename fn pf - pf'' <- evalStateT (descendBiM (f77lInlineIncludes' incs []) pf') Map.empty - let pf''' = runTransform (combinedTypeEnv mods) - (combinedModuleMap mods) - (defaultTransformation Fortran77Legacy) - pf'' - return pf''' - -f77lInlineIncludes' - :: [FilePath] -> [FilePath] -> Statement A0 +byVerInlineIncludes version incs mods fn bs = do + case byVerNoTransform version fn bs of + Left e -> liftIO $ throwIO e + Right pf -> do + let pf' = pfSetFilename fn pf + pf'' <- evalStateT (descendBiM (parserInlineIncludes version incs []) pf') Map.empty + let pf''' = runTransform (combinedTypeEnv mods) + (combinedModuleMap mods) + (defaultTransformation version) + pf'' + return pf''' + +-- Internal function to go through the includes and inline them +parserInlineIncludes + :: FortranVersion -> [FilePath] -> [FilePath] -> Statement A0 -> StateT (Map String [Block A0]) IO (Statement A0) -f77lInlineIncludes' dirs = go +parserInlineIncludes version dirs = go where go seen st = case st of StInclude a s e@(ExpValue _ _ (ValString path)) Nothing -> do - if notElem path seen then do + if path `notElem` seen then do incMap <- get case Map.lookup path incMap of Just blocks' -> pure $ StInclude a s e (Just blocks') Nothing -> do (fullPath, incBs) <- liftIO $ readInDirs dirs path - case f77lIncludesNoTransform fullPath incBs of + case byVerInclude version fullPath incBs of Right blocks -> do blocks' <- descendBiM (go (path:seen)) blocks modify (Map.insert path blocks') @@ -328,8 +360,30 @@ f77lInlineIncludes' dirs = go else pure st _ -> pure st -f77lIncludesNoTransform :: Parser [Block A0] +f66IncludesNoTransform, f77IncludesNoTransform, f77eIncludesNoTransform, + f77lIncludesNoTransform, f90IncludesNoTransform, f95IncludesNoTransform, + f2003IncludesNoTransform + :: Parser [Block A0] +f66IncludesNoTransform = makeParserFixed F66.includesParser Fortran66 +f77IncludesNoTransform = makeParserFixed F77.includesParser Fortran77 +f77eIncludesNoTransform = makeParserFixed F77.includesParser Fortran77Extended f77lIncludesNoTransform = makeParserFixed F77.includesParser Fortran77Legacy +f90IncludesNoTransform = makeParserFree F90.includesParser Fortran90 +f95IncludesNoTransform = makeParserFree F95.includesParser Fortran95 +f2003IncludesNoTransform = makeParserFree F2003.includesParser Fortran2003 + +byVerInclude :: FortranVersion -> Parser [Block A0] +byVerInclude = \case + Fortran66 -> f66IncludesNoTransform + Fortran77 -> f77IncludesNoTransform + Fortran77Extended -> f77eIncludesNoTransform + Fortran77Legacy -> f77lIncludesNoTransform + Fortran90 -> f90IncludesNoTransform + Fortran95 -> f95IncludesNoTransform + Fortran2003 -> f2003IncludesNoTransform + v -> error $ "Language.Fortran.Parser.byVerInclude: " + <> "no parser available for requested version: " + <> show v readInDirs :: [String] -> String -> IO (String, B.ByteString) readInDirs [] f = fail $ "cannot find file: " ++ f diff --git a/src/Language/Fortran/Parser/Fixed/Fortran66.y b/src/Language/Fortran/Parser/Fixed/Fortran66.y index 1225603a..1353442d 100644 --- a/src/Language/Fortran/Parser/Fixed/Fortran66.y +++ b/src/Language/Fortran/Parser/Fixed/Fortran66.y @@ -6,6 +6,7 @@ module Language.Fortran.Parser.Fixed.Fortran66 , blockParser , statementParser , expressionParser + , includesParser ) where import Language.Fortran.Version @@ -25,6 +26,7 @@ import Prelude hiding ( EQ, LT, GT ) -- Same constructors exist in the AST %name blockParser BLOCK %name statementParser STATEMENT %name expressionParser EXPRESSION +%name includesParser INCLUDES %monad { LexAction } %lexer { lexer } { TEOF _ } %tokentype { Token } @@ -139,6 +141,9 @@ MAYBE_ARGUMENTS :: { Maybe (AList Expression A0) } NAME :: { Name } : id { let (TId _ name) = $1 in name } +INCLUDES :: { [ Block A0 ] } +: BLOCKS NEWLINE { reverse $1 } + BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] } diff --git a/src/Language/Fortran/Parser/Free/Fortran2003.y b/src/Language/Fortran/Parser/Free/Fortran2003.y index d3a72088..4cb82757 100644 --- a/src/Language/Fortran/Parser/Free/Fortran2003.y +++ b/src/Language/Fortran/Parser/Free/Fortran2003.y @@ -7,6 +7,7 @@ module Language.Fortran.Parser.Free.Fortran2003 , blockParser , statementParser , expressionParser + , includesParser ) where import Language.Fortran.Version @@ -28,6 +29,7 @@ import qualified Data.List as List %name blockParser BLOCK %name statementParser STATEMENT %name expressionParser EXPRESSION +%name includesParser INCLUDES %monad { LexAction } %lexer { lexer } { TEOF _ } %tokentype { Token } @@ -349,6 +351,9 @@ IMPORT_NAME_LIST :: { [Expression A0] } : IMPORT_NAME_LIST ',' VARIABLE { $3 : $1 } | VARIABLE { [ $1 ] } +INCLUDES :: { [ Block A0 ] } +: BLOCKS NEWLINE { reverse $1 } + BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] } BLOCK :: { Block A0 } diff --git a/src/Language/Fortran/Parser/Free/Fortran90.y b/src/Language/Fortran/Parser/Free/Fortran90.y index cad6515f..3a52e94a 100644 --- a/src/Language/Fortran/Parser/Free/Fortran90.y +++ b/src/Language/Fortran/Parser/Free/Fortran90.y @@ -7,6 +7,7 @@ module Language.Fortran.Parser.Free.Fortran90 , blockParser , statementParser , expressionParser + , includesParser ) where import Language.Fortran.Version @@ -27,6 +28,7 @@ import qualified Data.List as List %name functionParser SUBPROGRAM_UNIT %name blockParser BLOCK %name statementParser STATEMENT +%name includesParser INCLUDES %name expressionParser EXPRESSION %monad { LexAction } %lexer { lexer } { TEOF _ } @@ -296,6 +298,9 @@ INTERFACE_END :: { Token } NAME :: { Name } : id { let (TId _ name) = $1 in name } +INCLUDES :: { [ Block A0 ] } +: BLOCKS NEWLINE { reverse $1 } + BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] } BLOCK :: { Block A0 } diff --git a/src/Language/Fortran/Parser/Free/Fortran95.y b/src/Language/Fortran/Parser/Free/Fortran95.y index 3147829a..f25e2210 100644 --- a/src/Language/Fortran/Parser/Free/Fortran95.y +++ b/src/Language/Fortran/Parser/Free/Fortran95.y @@ -7,6 +7,7 @@ module Language.Fortran.Parser.Free.Fortran95 , blockParser , statementParser , expressionParser + , includesParser ) where import Language.Fortran.Version @@ -28,6 +29,7 @@ import qualified Data.List as List %name blockParser BLOCK %name statementParser STATEMENT %name expressionParser EXPRESSION +%name includesParser INCLUDES %monad { LexAction } %lexer { lexer } { TEOF _ } %tokentype { Token } @@ -305,6 +307,9 @@ INTERFACE_END :: { Token } NAME :: { Name } : id { let (TId _ name) = $1 in name } +INCLUDES :: { [ Block A0 ] } +: BLOCKS NEWLINE { reverse $1 } + BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] } BLOCK :: { Block A0 } diff --git a/src/Language/Fortran/Parser/Free/Lexer.x b/src/Language/Fortran/Parser/Free/Lexer.x index 690f836f..51f6cbb5 100644 --- a/src/Language/Fortran/Parser/Free/Lexer.x +++ b/src/Language/Fortran/Parser/Free/Lexer.x @@ -51,9 +51,9 @@ $hash = [\#] @label = $digit{1,5} @name = $letter $alphanumeric* -@binary = b\'$bit+\' -@octal = o\'$octalDigit+\' -@hex = z\'$hexDigit+\' +@binary = b\'$bit+\' | \'$bit+\'b +@octal = o\'$octalDigit+\' | \'$octalDigit+\'o +@hex = [xz]\'$hexDigit+\' | \'$hexDigit+\'[xz] @digitString = $digit+ @kindParam = (@digitString|@name)