2007-04-20
■ 予約語をなくす 
これまでのevalは"if"や"lambda"等の定数とのパターンマッチングをして処理を分岐させていたため、これらはある意味予約語のようになっていた。
今回はこれをやめて、ifやlambdaも単なる変数であって、その変数の中に条件分岐をする処理や関数を作る処理といった値が入っているだけ、という状態にする。
変数に値が入っているだけなので入れものである変数の名前は何でもよくて、予約語のような特別扱いのものはなくなる、と。
Syntax型を追加
前に組み込み関数を作ったときに関数を格納するSubr型を作ったことに倣って、関数を格納するSyntax型を追加する。
なんでSyntaxにしたかというと、gaucheでifを評価したら#<syntax if>と表示されたから。
Subrのときは、シンプルにS式からS式を求める関数だったが、evalはStateモナド化しているので、Syntax型に入れる関数もStateモナドを返す関数になる。
ついでにSyntax型の時用のshowも定義しておく。
data Sexp = Nil | Symbol String | Cons Sexp Sexp | Subr (Sexp->Sexp) | Closure Sexp Sexp
| Syntax (Sexp->Control.Monad.State.State Sexp Sexp)
show (Syntax _) = "#<syntax>"
環境に各syntaxを登録
これまでevalに入っていた各処理をそれぞれのシンボルに対応づけて環境envに登録する。書き方のスタイルは変わるけどやっていることはevalの時と同じ。
env = define "quote" (Syntax (\(Cons a _) -> return a)) $ define "lambda" (Syntax (\body -> gets $ Closure body)) $ define "if" (Syntax (\(Cons a (Cons b (Cons c _))) -> eval a >>= \p->if p/=false then eval b else eval c)) $ define "define" (Syntax (\(Cons (Symbol var) (Cons exp _)) -> eval exp >>= modify . define var >> return (Symbol var))) $ define "env" (Syntax (\_ -> get)) $ define "car" ...
evalを書き直し
個別処理が環境envの方に移ったので、evalの側では関数部funを評価してシンボルから実際に行うべき処理を取り出してそれを実行するという統一的な扱いが出来るようになる。
evalは3種類のデータ型に対応した3行だけになった。すっきりしてちょっと満足。
eval (Nil) = return Nil eval (Symbol str) = gets $ assoc str eval (Cons fun arg) = eval fun >>= flip preApply arg
preApply
例えば、ifの場合なら事前にthen部とelse部の両方を評価してしまったら意味がないし、defineの場合なら第２引数の変数部まで評価はしないといったように、関数系(Subr,Closure)と文法系(Syntax)の違いは、事前に引数を評価するかどうかということ。
これまでは引数を全て評価してからapplyを呼び出していたが、引数の評価の有無をコントロールするために、applyの呼び出しの前にpreApplyの呼び出しをかますことにする。
パターンマッチでSyntax型だったら評価前の引数をそのまま渡すようにして(1行目)、それ以外の型(=SubrとClosure)だったらevalsで各引数を評価してからapplyを呼び出す(2行目)ようにする。
Syntax型の方はどの引数を評価するかは各処理が自分で選ぶ、と。
preApply (Syntax fun) arg = fun arg preApply fun arg = evals arg >>= return . apply fun
テスト
まずdefineの機能を変数dに格納し、dを使ってdefineにはlambdaの機能を、lambdaにはdefineの機能をわりあてる。
それを使ってifという名前のnull?に相当する関数を定義する。
C:\haskell>runghc lisp.hs
>(define d define)
d
>(d define lambda)
define
>(d lambda d)
lambda
>(lambda if
(define (x)
(eq? () x)))
if
>(if ())
#t
>(if define)
#f
今日までの全コード
import Text.ParserCombinators.Parsec
import Control.Monad.State
data Sexp = Nil | Symbol String | Cons Sexp Sexp | Subr (Sexp->Sexp) | Closure Sexp Sexp
| Syntax (Sexp->Control.Monad.State.State Sexp Sexp)
instance Eq Sexp where
(==) Nil Nil = True
(==) (Symbol a) (Symbol b) = a==b
(==) (Cons a as) (Cons b bs) = a==b && as==bs
(==) _ _ = False
instance Show Sexp where
show (Nil) = "()"
show (Symbol a) = a
show (Cons a b) = "(" ++ show a ++ showCdr b ++ ")"
show (Subr _) = "#<subr>"
show (Syntax _) = "#<syntax>"
show (Closure a _) = "#<closure " ++ show a ++ ">"
showCdr (Nil) = ""
showCdr (Cons a b) = " " ++ show a ++ showCdr b
showCdr a = " . " ++ show a
instance Read Sexp where
readsPrec _ s = case parse sexpParser "" s of Right a -> [(a,"")]
partParser = spaces >>
( do { eof; return (Nil,"") }
<|> do { exp <- sexpParser; rest <- getInput; return (exp,rest) })
sexpParser = spaces >>
( do { string "("; listParser }
<|> do { string "'"; a<-sexpParser; return (Cons (Symbol "quote") (Cons a Nil)) }
<|> do { a<-many1 $ noneOf "'() \t\r\n"; return (Symbol a) } )
listParser = spaces >>
( do { string ")"; return Nil }
<|> do { string "."; a<-sexpParser; listParser; return a }
<|> do { a<-sexpParser; b<-listParser; return (Cons a b) } )
true = Symbol "#t"
false = Symbol "#f"
eval (Nil) = return Nil
eval (Symbol str) = gets $ assoc str
eval (Cons fun arg) = eval fun >>= flip preApply arg
evals (Cons a as) = do { b<-eval a; bs<-evals as; return $ Cons b bs }
evals a = eval a
preApply (Syntax fun) arg = fun arg
preApply fun arg = evals arg >>= return . apply fun
apply (Subr fun) arg = fun arg
apply (Closure (Cons var (Cons body _)) env) arg = evalState (eval body) (zipl var arg env)
apply f a = error $ "error in apply: " ++ show (Cons f a)
assoc s (Cons (Cons (Symbol k) v) e) = if s==k then v else assoc s e
assoc s _ = error $ "unbound variable: " ++ show s
zipl Nil _ e = e
zipl (Cons k ks) (Cons v vs) e = zipl ks vs $ zipl k v e
zipl k v e = Cons (Cons k v) e
define var (Closure body env) _ = let newenv = Cons (Cons (Symbol var) (Closure body newenv)) env in newenv
define var val env = Cons (Cons (Symbol var) val) env
env =
define "quote" (Syntax (\(Cons a _) -> return a)) $
define "lambda" (Syntax (\body -> gets $ Closure body)) $
define "if" (Syntax (\(Cons a (Cons b (Cons c _))) -> eval a >>= \p->if p/=false then eval b else eval c)) $
define "define" (Syntax (\(Cons (Symbol var) (Cons exp _)) -> eval exp >>= modify . define var >> return (Symbol var))) $
define "env" (Syntax (\_ -> get)) $
define "car" (Subr (\(Cons (Cons a _) _) -> a)) $
define "cdr" (Subr (\(Cons (Cons _ a) _) -> a)) $
define "cons" (Subr (\(Cons a (Cons b _)) -> Cons a b)) $
define "eq?" (Subr (\(Cons a (Cons b _)) -> if a==b then true else false)) $
define "pair?" (Subr (\(Cons a _) -> case a of Cons _ _ -> true; _ -> false )) $
define "apply" (Subr (\(Cons a (Cons b _)) -> apply a b)) $
define "eval" (Subr (\(Cons a (Cons b _)) -> evalState (eval a) b)) $
read "((#t . #t) (#f . #f))"
evalLoop str env = putStr ">" >> case parse partParser "" str of
Left err -> print err
Right (_,"") -> return ()
Right (exp,rest) -> case runState (eval exp) env of (a,s) -> print a >> evalLoop rest s
main = do
stdin<-getContents
evalLoop stdin env
次回予定
マクロ機能を作る