HaskellでLispを書く日記 このページをアンテナに追加 RSSフィード

2007-04-20

予約語をなくす 予約語をなくす - HaskellでLispを書く日記 を含むブックマーク はてなブックマーク - 予約語をなくす - HaskellでLispを書く日記 予約語をなくす - HaskellでLispを書く日記 のブックマークコメント

これまでの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の場合なら第2引数変数部まで評価はしないといったように、関数系(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

次回予定

マクロ機能を作る

トラックバック - http://haskell.g.hatena.ne.jp/haskelisp/20070420