summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authortomsmeding <tom.smeding@gmail.com>2017-12-17 22:31:01 +0100
committertomsmeding <tom.smeding@gmail.com>2017-12-17 22:32:05 +0100
commitc25979b76c1dd22b6dc33acb994e9044c56a68f9 (patch)
treec9cb1d35e2d2747af91a7cf963f9af4df19f4abf
parent594ecf396cad8a38aac168062249ab3361c5b558 (diff)
#include
-rw-r--r--data.lisp9
-rw-r--r--main.hs2
-rw-r--r--parser.hs38
-rw-r--r--stdlib.lisp3
-rw-r--r--vm.hs15
5 files changed, 53 insertions, 14 deletions
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)