# HG changeset patch # User unc0rr # Date 1321979655 -10800 # Node ID 4b9a591165352a0b393c321418d31c7c141f58a7 # Parent 3cb15ca5319f5241c494ebfdd2f9e095676a3677 - Split PascalParser into modules - Start implementation of preprocessor diff -r 3cb15ca5319f -r 4b9a59116535 tools/PascalBasics.hs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tools/PascalBasics.hs Tue Nov 22 19:34:15 2011 +0300 @@ -0,0 +1,70 @@ +{-# LANGUAGE FlexibleContexts #-} +module PascalBasics where + +import Text.Parsec.Combinator +import Text.Parsec.Char +import Text.Parsec.Prim +import Text.Parsec.Token +import Text.Parsec.Language +import Data.Char + +builtin = ["succ", "pred", "low", "high"] + +pascalLanguageDef + = emptyDef + { commentStart = "(*" + , commentEnd = "*)" + , commentLine = "//" + , nestedComments = False + , identStart = letter <|> oneOf "_" + , identLetter = alphaNum <|> oneOf "_." + , reservedNames = [ + "begin", "end", "program", "unit", "interface" + , "implementation", "and", "or", "xor", "shl" + , "shr", "while", "do", "repeat", "until", "case", "of" + , "type", "var", "const", "out", "array", "packed" + , "procedure", "function", "with", "for", "to" + , "downto", "div", "mod", "record", "set", "nil" + , "string", "shortstring" + ] ++ builtin + , reservedOpNames= [] + , caseSensitive = False + } + +preprocessorSwitch :: Stream s m Char => ParsecT s u m String +preprocessorSwitch = do + try $ string "{$" + s <- manyTill (noneOf "\n") $ char '}' + return s + +caseInsensitiveString s = do + mapM_ (\a -> satisfy (\b -> toUpper a == toUpper b)) s s + return s + +pas = patch $ makeTokenParser pascalLanguageDef + where + patch tp = tp {stringLiteral = stringL} + +comment = choice [ + char '{' >> notFollowedBy (char '$') >> manyTill anyChar (try $ char '}') + , (try $ string "(*") >> manyTill anyChar (try $ string "*)") + , (try $ string "//") >> manyTill anyChar (try newline) + ] + +comments = do + spaces + skipMany $ do + preprocessorSwitch <|> comment + spaces + +stringL = do + (char '\'') + s <- (many $ noneOf "'") + (char '\'') + ss <- many $ do + (char '\'') + s' <- (many $ noneOf "'") + (char '\'') + return $ '\'' : s' + comments + return $ concat (s:ss) diff -r 3cb15ca5319f -r 4b9a59116535 tools/PascalParser.hs --- a/tools/PascalParser.hs Tue Nov 22 02:08:42 2011 +0100 +++ b/tools/PascalParser.hs Tue Nov 22 19:34:15 2011 +0300 @@ -1,16 +1,18 @@ module PascalParser where -import Text.Parsec.Expr +import Text.Parsec import Text.Parsec.Char import Text.Parsec.Token import Text.Parsec.Language +import Text.Parsec.Expr import Text.Parsec.Prim import Text.Parsec.Combinator import Text.Parsec.String import Control.Monad -import Data.Char import Data.Maybe +import PascalBasics + data PascalUnit = Program Identifier Implementation | Unit Identifier Interface Implementation (Maybe Initialize) (Maybe Finalize) @@ -90,66 +92,12 @@ | InitNull deriving Show -builtin = ["succ", "pred", "low", "high"] - -pascalLanguageDef - = emptyDef - { commentStart = "(*" - , commentEnd = "*)" - , commentLine = "//" - , nestedComments = False - , identStart = letter <|> oneOf "_" - , identLetter = alphaNum <|> oneOf "_." - , reservedNames = [ - "begin", "end", "program", "unit", "interface" - , "implementation", "and", "or", "xor", "shl" - , "shr", "while", "do", "repeat", "until", "case", "of" - , "type", "var", "const", "out", "array", "packed" - , "procedure", "function", "with", "for", "to" - , "downto", "div", "mod", "record", "set", "nil" - , "string", "shortstring" - ] ++ builtin - , reservedOpNames= [] - , caseSensitive = False - } - -caseInsensitiveString s = do - mapM_ (\a -> satisfy (\b -> toUpper a == toUpper b)) s s - return s - -pas = patch $ makeTokenParser pascalLanguageDef - where - patch tp = tp {stringLiteral = sl} - sl = do - (char '\'') - s <- (many $ noneOf "'") - (char '\'') - ss <- many $ do - (char '\'') - s' <- (many $ noneOf "'") - (char '\'') - return $ '\'' : s' - comments - return $ concat (s:ss) - -comments = do - spaces - skipMany $ do - comment - spaces - pascalUnit = do comments u <- choice [program, unit] comments return u -comment = choice [ - char '{' >> manyTill anyChar (try $ char '}') - , (try $ string "(*") >> manyTill anyChar (try $ string "*)") - , (try $ string "//") >> manyTill anyChar (try newline) - ] - iD = do i <- liftM Identifier (identifier pas) comments @@ -389,12 +337,13 @@ term = comments >> choice [ builtInFunction expression >>= \(n, e) -> return $ BuiltInFunCall e (SimpleReference (Identifier n)) , parens pas $ expression - , try $ integer pas >>= \i -> notFollowedBy (char '.') >> (return . NumberLiteral . show) i + , try $ natural pas >>= \i -> notFollowedBy (char '.') >> (return . NumberLiteral . show) i , try $ float pas >>= return . FloatLiteral . show - , try $ integer pas >>= return . NumberLiteral . show + , try $ natural pas >>= return . NumberLiteral . show , stringLiteral pas >>= return . StringLiteral , char '#' >> many digit >>= return . CharCode , char '$' >> many hexDigit >>= return . HexNumber + , char '-' >> expression >>= return . PrefixOp "-" , try $ string "nil" >> return Null , reference >>= return . Reference ] "simple expression" @@ -407,7 +356,6 @@ ] , [ Infix (char '+' >> return (BinOp "+")) AssocLeft , Infix (char '-' >> return (BinOp "-")) AssocLeft - , Prefix (char '-' >> return (PrefixOp "-")) ] , [ Infix (try (string "<>") >> return (BinOp "<>")) AssocNone , Infix (try (string "<=") >> return (BinOp "<=")) AssocNone @@ -626,3 +574,4 @@ exprs <- parens pas $ commaSep1 pas $ e spaces return (name, exprs) + \ No newline at end of file diff -r 3cb15ca5319f -r 4b9a59116535 tools/PascalPreprocessor.hs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tools/PascalPreprocessor.hs Tue Nov 22 19:34:15 2011 +0300 @@ -0,0 +1,55 @@ +module PascalPreprocessor where + +import Text.Parsec +import Control.Monad.IO.Class +import System.IO +import qualified Data.Map as Map + +preprocess :: String -> IO String +preprocess fn = do + r <- runParserT (preprocessFile fn) Map.empty "" "" + case r of + (Left a) -> do + hPutStrLn stderr (show a) + return "" + (Right a) -> return a + + where + preprocessFile :: String -> ParsecT String (Map.Map String String) IO String + preprocessFile fn = do + f <- liftIO (readFile fn) + setInput f + preprocessor + preprocessor, codeBlock, switch :: ParsecT String (Map.Map String String) IO String + preprocessor = chainl codeBlock (return (++)) "" + codeBlock = choice [ + switch + --, comment + , char '\'' >> many (noneOf "'") >>= \s -> char '\'' >> return ('\'' : s ++ "'") + , many1 $ noneOf "{'" + ] + switch = do + try $ string "{$" + s <- choice [ + include + , unknown + ] + return s + include = do + try $ string "INCLUDE" + spaces + (char '"') + fn <- many1 $ noneOf "\"\n" + char '"' + spaces + char '}' + f <- liftIO (readFile fn) + c <- getInput + setInput $ f ++ c + return "" + + unknown = do + fn <- many1 $ noneOf "}\n" + char '}' + return "" + \ No newline at end of file