Skip to content

Instantly share code, notes, and snippets.

@pasberth
Created August 13, 2012 13:14
Show Gist options
  • Save pasberth/3340598 to your computer and use it in GitHub Desktop.
Save pasberth/3340598 to your computer and use it in GitHub Desktop.
Haskell で lisp とか実装してみる(まだ動かない)
module LISP where
import Text.ParserCombinators.Parsec
import Control.Monad.State
data Value = Sym Identifier
| Int Int
| Str String
| List [Value]
| Closure [Identifier] Expr Env
deriving (Show, Eq)
data Acc = Acc Value
deriving (Show, Eq)
data Expr = HaltExpr
| ConstExpr Value Expr
| PrintExpr Expr
| ReferExpr Identifier Expr
| AssignExpr Identifier Expr
| CloseExpr [Identifier] Expr Expr
| FrameExpr Expr Expr
| ArgExpr Expr
| ApplyExpr
| ReturnExpr
deriving (Show, Eq)
type Env = [Var]
type Rib = [Value]
data Stack = EmptyStack
| Stack (Expr, Env, Rib, Stack)
deriving (Show)
type Var = (Identifier, Value)
type Identifier = String
data VM = VM Acc Expr Env Rib Stack deriving (Show)
nil :: Value
nil = List []
parseProgram :: Parser Value
parseProgram = many list >>= return . List
where list = do
l <- parseList
skipSpaces
return l
skipSpaces = skipMany (oneOf " \t\n")
parseList :: Parser Value
parseList = do
l <- between (char '(') (char ')') (many elem)
return $ List l
where elem = do
elem <- parseElem
skipSpaces
return elem
skipSpaces = skipMany (oneOf " \t\n")
parseElem :: Parser Value
parseElem = try parseSym <|> try parseInt <|> try parseStr <|> parseList <?> "a value"
parseSym = do
id <- symbol
return $ Sym id
where symbol = do
a <- beginLetter
b <- many containLetter
return (a:b)
beginLetter = letter
containLetter = letter <|> oneOf "0123456789" <|> oneOf "-"
parseStr = do
str <- string_
return $ Str str
where string_ = between (char '"')
(char '"')
(many (do{ string "\\\""; return '"' } <|> noneOf ['"']))
parseInt = do
int <- integer
return $ Int int
where integer = do { s <- many1 $ oneOf "0123456789"; return $ read s }
compile :: Value -> Expr -> Expr
compile (Sym a) end = ReferExpr a end
compile (List []) end = end
compile (List ((Sym "print"):args)) end = (compileList args) $ PrintExpr end
compile (List ((Sym "setq"):(Sym v):x:[])) end = (compile x) $ AssignExpr v end
compile (List ((Sym "lambda"):(List vars):body:[])) end =
CloseExpr (toIds vars) (compile body ReturnExpr) end
where toIds :: [Value] -> [Identifier]
toIds vars =
case vars of
(Sym v):[] -> [v]
(Sym v):vs -> v:toIds vs
compile (List (x:xs)) ret =
recur xs (compile x ApplyExpr)
where recur [] c = FrameExpr ret c
recur (arg:args) c = recur args (compile arg (ArgExpr c))
-- compile (List list) end = ConstExpr (List list) end
compile val end = ConstExpr val end
compileProgn (List (x:xs)) end = (compile x) $ ((compileProgn $ List xs) end)
compileProgn (List []) end = end
compileList [] end = end
compileList (x:xs) end = compile x $ compileList xs end
vm :: StateT VM IO ()
vm = do
state <- get
case state of
(VM a HaltExpr e r s) -> return ()
(VM a (ConstExpr x nxt) e r s) -> do
put (VM (Acc x) nxt e r s)
vm
(VM (Acc a) (PrintExpr nxt) e r s) -> do
liftIO $ putStrLn $ toString a
put (VM (Acc a) nxt e r s)
vm
(VM a (ReferExpr id nxt) e r s) -> do
put (VM ((Acc . snd) $ LISP.lookup id e) nxt e r s)
vm
(VM (Acc a) (AssignExpr id nxt) e r s) -> do
put (VM ((Acc . snd) $ (LISP.lookup id e)) nxt (assign id a e) r s)
vm
(VM a (FrameExpr ret nxt) e r s) -> do
put (VM a nxt e [] (callFrame (ret, e, r, s)))
vm
(VM (Acc a) (ArgExpr nxt) e r s) -> do
put (VM (Acc a) nxt e (a:r) s)
vm
(VM (Acc (Closure vars body ce)) ApplyExpr e r s) -> do
put (VM (Acc (Closure vars body ce)) body (extend ce vars r) [] s)
vm
(VM a ReturnExpr _ _ (Stack (x, e, r, s))) -> do
put (VM a x e r s)
vm
(VM a ReturnExpr _ _ EmptyStack) -> do
liftIO $ putStrLn "warning: stack is empty."
vm
(VM a (CloseExpr vars body nxt) e r s) -> do
put (VM (Acc $ Closure vars body e) nxt e r s)
vm
callFrame :: (Expr, Env, Rib, Stack) -> Stack
callFrame (x, e, r, s) = Stack (x, e, r, s)
extend :: Env -> [Identifier] -> Rib -> Env
extend e [] [] = e
extend e (var:vars) [] = (var, nil) : extend e vars []
extend e (var:vars) (val:vals) = (var, val) : extend e vars vals
assign :: Identifier -> Value -> Env -> Env
assign id v [] = [(id, v)]
assign id v ((vid, val) : e) | id == vid = (id, v) : e
| otherwise = (vid, val) : assign id v e
lookup :: Identifier -> Env -> Var
lookup id [] = error "lookup failed"
lookup id ((vid, val):e) | id == vid = (vid, val)
| otherwise = LISP.lookup id e
toString :: Value -> String
toString (Sym a) = "'" ++ a
toString (Int x) = show x
toString (Str s) = s
toString (List []) = "(nil)"
toString (List (x:[])) = toString x
toString (List (x:xs)) = toString x ++ (toString $ List xs)
toString (Closure vars body e) =
concat [ "lambda", "(", unwords vars, ")"
, " -> ", "{ ", show body, " }"
, " in ", show e, ";"]
main = do
evalStateT vm (VM (Acc (Str "hello")) (PrintExpr HaltExpr) [("a", (Int 1))] [] EmptyStack)
evalStateT vm (VM (Acc (Str "hello")) (ReferExpr "a" $ PrintExpr HaltExpr) [("a", (Int 1))] [] EmptyStack)
evalStateT vm (VM (Acc (Str "hello")) (AssignExpr "a" $ ReferExpr "a" $ PrintExpr HaltExpr) [("a", (Int 1))] [] EmptyStack)
-- "(print \"hello world\") (print 1) (setq a (lambda (x y) (a))) (print a) (print (a))"
case parse parseProgram "(fname.lisp)" "(print \"hello world\") (print 1) (setq a (lambda (x y) x)) (print a) (print (a 5)) (setq b (lambda (x) (lambda (y) (print x)))) ((b 1) 2)" of
Right val -> do
print $ compileProgn val $ HaltExpr
evalStateT vm (VM (Acc (List [])) (compileProgn val HaltExpr) [] [] EmptyStack)
Left err -> do
putStr "parse error at"
print err
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment