From c25979b76c1dd22b6dc33acb994e9044c56a68f9 Mon Sep 17 00:00:00 2001 From: tomsmeding Date: Sun, 17 Dec 2017 22:31:01 +0100 Subject: #include --- data.lisp | 9 +++++++++ main.hs | 2 +- parser.hs | 38 +++++++++++++++++++++++++++----------- stdlib.lisp | 3 +++ vm.hs | 15 +++++++++++++-- 5 files changed, 53 insertions(+), 14 deletions(-) create mode 100644 data.lisp create mode 100644 stdlib.lisp diff --git a/data.lisp b/data.lisp new file mode 100644 index 0000000..1e77aae --- /dev/null +++ b/data.lisp @@ -0,0 +1,9 @@ +#include "stdlib.lisp" + +(define li (list 1 2 3)) + +(print (car li)) +(print (cadr li)) +(print (caddr li)) +(print (list 1 2 3 4 5 6)) +(print '(1 2 3 4 5 6)) diff --git a/main.hs b/main.hs index b7d351a..b56edfe 100644 --- a/main.hs +++ b/main.hs @@ -22,7 +22,7 @@ main = do [fname] -> readFile fname _ -> usage >> exitFailure - prog <- either (die . show) return (parseProgram source) + prog <- parseProgram source >>= either (die . show) return irprog <- either die return (compileProgram prog) let opt = optimise irprog -- print opt diff --git a/parser.hs b/parser.hs index 4f9e965..93d457c 100644 --- a/parser.hs +++ b/parser.hs @@ -1,31 +1,33 @@ module Parser(parseProgram, parseExpression) where import Control.Monad +import Control.Monad.Trans import Data.Char import Text.Parsec +import Text.Parsec.Pos import AST -type Parser = Parsec String () +type Parser = ParsecT String () IO -parseProgram :: String -> Either ParseError Program -parseProgram = parse pProgram "" +parseProgram :: String -> IO (Either ParseError Program) +parseProgram = runParserT pProgram () "" pProgram :: Parser Program pProgram = between pWhiteComment eof (liftM Program (many pValue)) -parseExpression :: String -> Either ParseError Value -parseExpression = parse pExpression "" +parseExpression :: String -> IO (Either ParseError Value) +parseExpression = runParserT pExpression () "" pExpression :: Parser Value pExpression = between pWhiteComment eof pValue pValue :: Parser Value -pValue = pVEllipsis <|> pVList <|> pVNum <|> pVString <|> pVName <|> pVQuoted "value" +pValue = pPPC <|> pVEllipsis <|> pVList <|> pVNum <|> pVString <|> pVName <|> pVQuoted "value" pVList :: Parser Value pVList = flip label "list" $ do @@ -38,10 +40,7 @@ pVNum :: Parser Value pVNum = liftM (VNum . read) (many1 digit) <* pWhiteComment "number" pVString :: Parser Value -pVString = flip label "string" $ do - void $ char '"' - s <- manyTill anyChar (symbol "\"") - return $ VString s +pVString = fmap VString pString pVName :: Parser Value pVName = flip label "name" $ do @@ -50,7 +49,7 @@ pVName = flip label "name" $ do pWhiteComment return $ VName $ first : rest where - isNameChar c = ((c >= '*' && c <= 'z') || c `elem` "!#$%&|~") && c /= ';' + isNameChar c = ((c >= '*' && c <= 'z') || c `elem` "!$%&|~") && c /= ';' isFirstNameChar c = isNameChar c && not (isDigit c) pVQuoted :: Parser Value @@ -59,10 +58,27 @@ pVQuoted = char '\'' >> liftM VQuoted pValue "quoted value" pVEllipsis :: Parser Value pVEllipsis = symbol "..." >> return VEllipsis "ellipsis" +pPPC :: Parser Value +pPPC = flip label "preprocessor command" $ do + symbol "#include" + fname <- pString + src <- liftIO $ readFile fname + stateBackup <- getParserState + void $ setParserState (State ("(do " ++ src ++ ")") (initialPos fname) ()) + result <- pValue <* eof + void $ setParserState stateBackup + return result + symbol :: String -> Parser () symbol s = try (string s) >> pWhiteComment +pString :: Parser String +pString = flip label "string" $ do + void $ char '"' + s <- manyTill anyChar (symbol "\"") + return s + pWhiteComment :: Parser () pWhiteComment = do pWhitespace diff --git a/stdlib.lisp b/stdlib.lisp new file mode 100644 index 0000000..b691a0a --- /dev/null +++ b/stdlib.lisp @@ -0,0 +1,3 @@ +(define cadr (x) (car (cdr x))) +(define caddr (x) (car (cdr (cdr x)))) +(define cadddr (x) (car (cdr (cdr (cdr x))))) diff --git a/vm.hs b/vm.hs index 04de0c5..b3b19e4 100644 --- a/vm.hs +++ b/vm.hs @@ -5,6 +5,7 @@ import Data.List import Data.Maybe import qualified Data.Map.Strict as Map import Data.Map.Strict ((!)) +import System.IO import qualified System.IO.Error as IO import Debug.Trace @@ -28,6 +29,7 @@ data RunValue | RVNum Int | RVString String | RVQuoted RunValue + | RVName Name deriving Show kErrorExit :: String @@ -101,8 +103,12 @@ vmRunBuiltin "print" as = putStrLn (intercalate ", " (map printshow as)) >> retu vmRunBuiltin "<=" [RVNum a, RVNum b] = return (RVNum (fromEnum (a <= b))) vmRunBuiltin "+" [RVNum a, RVNum b] = return (RVNum (a + b)) vmRunBuiltin "-" [RVNum a, RVNum b] = return (RVNum (a - b)) -vmRunBuiltin "car" [RVList (a:_)] = return a -vmRunBuiltin "cdr" [RVList (_:a)] = return (RVList a) +vmRunBuiltin "car" [RVList l] = case l of + a : _ -> return a + _ -> throw "Empty list in 'car'" +vmRunBuiltin "cdr" [RVList l] = case l of + _ : a -> return (RVList a) + _ -> throw "Empty list in 'cdr'" vmRunBuiltin "list" values = return (RVList values) vmRunBuiltin name args = error (name ++ " " ++ show args) @@ -112,6 +118,7 @@ printshow (RVList values) = show values printshow (RVNum i) = show i printshow (RVQuoted value) = '\'' : show value printshow (RVClosure _ _) = "[closure]" +printshow (RVName name) = name truthy :: RunValue -> Bool truthy (RVNum n) = n /= 0 @@ -122,4 +129,8 @@ toRunValue (VList values) = RVList (map toRunValue values) toRunValue (VNum i) = RVNum i toRunValue (VString s) = RVString s toRunValue (VQuoted value) = RVQuoted (toRunValue value) +toRunValue (VName name) = RVName name toRunValue _ = undefined + +throw :: String -> IO a +throw s = hPutStrLn stderr s >> IO.ioError (IO.userError kErrorExit) -- cgit v1.2.3