micro Scheme の続きです。今回は S 式を評価する処理を作りましょう。
最初に、関数の定義をデータ型 SExpr に追加します。次のリストを見てください。
リスト : S 式の定義
import qualified Data.Map as M
data SExpr = INT Integer
| REAL Double
| SYM String
| STR String
| CELL SExpr SExpr
| NIL
| PRIM (SExpr -> Scm SExpr)
| SYNT (GEnv -> LEnv -> SExpr -> Scm (SExpr, GEnv))
| CLOS SExpr LEnv
-- 評価器の定義
type Scm a = Either String a
-- エラーの送出
scmError :: String -> Scm a
scmError s = Left s
-- 局所変数の環境
type LEnv = [(String, SExpr)]
-- 大域変数の環境
type GEnv = M.Map String SExpr
PRIM はプリミティブ (primitive) の略で、eq?, car, cdr, cons など基本的な関数を表します。引数は評価して、その結果をコンスセル (CELL) に格納して渡します。SYNT はシンタックス形式 (syntax) の略で、quote, if, define など基本的なシンタックス形式を表します。引数は評価せずにそのままシンタックス形式に渡します。このとき、いっしょに環境 (environment) も渡します。CLOS はクロージャ (closure) を表します。Scheme の場合、ラムダ式を評価するとクロージャが生成され、その時点で定義されている局所変数の環境 LEnv がクロージャに保存されます。
LEnv は連想リスト [(String, SExpr)] で表します。今回の micro Scheme は変数の値を書き換えるシンタックス形式 set! を実装しないので、単純な連想リストでも大丈夫です。グローバルな環境 (大域変数) はモジュール Data.Map の Map を使って表します。Scm は S 式を評価する関数の返り値のデータ型を表します。エラーを表すため Either モナドを使います。scmError はエラーを送出する関数で、引数 s を Left に包んで返すだけです。
micro Scheme インタプリタの主役は関数 eval と apply です。eval は S 式と環境を受け取り、渡された環境の下で S 式を評価します。eval の仕事は簡単です。S 式が自己評価フォームであれば、それをそのまま返します。シンボル (変数) であれば環境からその値を求めて返します。リストの場合はちょっと複雑です。先頭の要素を評価して、それが関数値であればそれを呼び出します。プリミティブとクロージャの処理は apply で行います。
プログラムは次のようになります。
リスト : S 式の評価
eval :: GEnv -> LEnv -> SExpr -> Scm (SExpr, GEnv)
eval genv lenv NIL = return (NIL, genv)
eval genv lenv v@(INT _) = return (v, genv)
eval genv lenv v@(REAL _) = return (v, genv)
eval genv lenv v@(STR _) = return (v, genv)
eval genv lenv (SYM name) =
case lookup name lenv of
Nothing -> case M.lookup name genv of
Nothing -> scmError $ "unbound variable: " ++ name
Just v -> return (v, genv)
Just v -> return (v, genv)
eval genv lenv (CELL func args) = do
(v, genv1) <- eval genv lenv func
case v of
SYNT f -> f genv1 lenv args
_ -> do (vs, genv2) <- evalArguments genv1 lenv args
apply genv2 lenv v vs
eval の引数 genv, lenv が環境で、第 2 引数が評価する S 式です。返り値は評価結果と大域変数の環境です。S 式が NIL, INT, REAL, STR の場合は自己評価フォームなので、S 式をそのまま返します。S 式がシンボルの場合は環境 lenv から局所変数を探します。局所変数が見つからない場合は環境 genv から大域変数を探します。それでも変数が見つからない場合はエラーを返します。
S 式がリストの場合は、その先頭要素 func を eval で評価して値を v にセットします。v が SYNT f の場合は、シンタックス形式 f を呼び出します。このとき、引数として args と genv1, lenv をそのまま渡します。そうでなければ、引数 args を関数 evalArguments で評価して、その結果を apply に渡して関数 v を呼び出します。
引数を評価する関数 evalArguments は簡単です。次のリストを見てください。
リスト : 引数の評価 evalArguments :: GEnv -> LEnv -> SExpr -> Scm (SExpr, GEnv) evalArguments genv lenv NIL = return (NIL, genv) evalArguments genv lenv (CELL expr rest) = do (v, genv1) <- eval genv lenv expr (vs, genv2) <- evalArguments genv1 lenv rest return (CELL v vs, genv2) evalArguments _ _ _ = scmError "invalid function form"
S 式が NIL の場合は NIL を返します。これが再帰呼び出しの停止条件になります。S 式が CELL の場合、CAR の要素 expr を eval で評価します。次に、残りの S 式を evalArguments で評価します。そして、2 つの返り値を CELL に格納して返します。これで引数を評価して、その結果をリストに格納して返すことができます。S 式が NIL, CELL 以外の値はエラーを返します。
次は関数 apply を作りましょう。
リスト : 関数適用
apply :: GEnv -> LEnv -> SExpr -> SExpr -> Scm (SExpr, GEnv)
apply genv lenv func actuals =
case func of
PRIM f -> do v <- f actuals
return (v, genv)
CLOS (CELL parms body) lenv0 -> do
lenv1 <- makeBindings lenv0 parms actuals
evalBody genv lenv1 body
_ -> scmError $ "Not Function: " ++ show func
引数 func が PRIM の場合、実引数リスト actuals にプリミティブ f を適用して値 v を求め、モナドに包んで返します。func が CLOS の場合はちょっと複雑です。actuals と仮引数リスト parms と環境 lenv0 を makeBindings に渡して新しい環境 lenv1 を生成します。クロージャが保持している環境 lenv0 も新しい環境 lenv1 に追加されることに注意してください。
ラムダ式の本体は複数の S 式を格納することができます。これらの S 式の評価は関数 evalBody で行います。evalBody は複数の S 式を順番に eval で評価し、最後に評価した S 式の結果を返します。グローバルの環境は genv と同じですが、ローカルな環境を新しく生成された lenv1 に切り替えます。この環境でラムダ式の本体が評価されます。
次は変数束縛を生成する関数 makeBindings を作ります。
リスト : 変数束縛 makeBindings :: LEnv -> SExpr -> SExpr -> Scm LEnv makeBindings lenv NIL _ = return lenv makeBindings lenv (SYM name) rest = return ((name, rest):lenv) makeBindings lenv (CELL (SYM name) parms) (CELL v args) = do lenv' <- makeBindings lenv parms args return ((name, v):lenv') makeBindings lenv _ NIL = scmError errNEA makeBindings lenv _ _ = scmError "invalid arguments form"
仮引数リストが NIL の場合はクロージャの環境 lenv をそのまま返します。残っている実引数は捨て去ることに注意してください。仮引数リストが SYM name の場合、仮引数リストはドットリストまたはシンボルだけの場合です。残っている実引数リスト rest と name をタプルに格納し、それを lenv に追加します。どちらも CELL の場合は、name と v をタプルに格納し、それを makeBindings の返り値に追加します。それ以外の場合はエラーを返します。
次はラムダ式の本体を評価する関数 evalBody を作ります。
リスト : 本体の評価 evalBody :: GEnv -> LEnv -> SExpr -> Scm (SExpr, GEnv) evalBody genv lenv (CELL expr NIL) = eval genv lenv expr evalBody genv lenv (CELL expr rest) = do (_, genv1) <- eval genv lenv expr evalBody genv1 lenv rest evalBody _ _ _ = scmError "invalid body form"
evalBody は簡単で、先頭から順番にコンスセルの要素 expr を取り出し、それを eval で評価するだけです。途中の返り値は捨てて、最後の S 式の値だけを返します。
次は等値を判定する述語 eq? と equal? を作ります。
リスト : 等値の判定
-- 真偽値
true = SYM "true"
false = SYM "false"
-- 等値の定義
instance Eq SExpr where
INT x == INT y = x == y
REAL x == REAL y = x == y
SYM x == SYM y = x == y
STR x == STR y = x == y
NIL == NIL = True
_ == _ = False
eq' :: SExpr -> Scm SExpr
eq' (CELL x (CELL y _)) =
if x == y then return true else return false
eq' _ = scmError $ "eq : " ++ errNEA
equal' :: SExpr -> Scm SExpr
equal' (CELL x (CELL y _)) =
if iter x y then return true else return false
where iter (CELL a b) (CELL c d) = iter a c && iter b d
iter x y = x == y
equal' _ = scmError $ "equal : " ++ errNEA
真偽値はシンボル true と false で表します。true と false の値は自分自身になるよう初期化します。つまり、自己評価フォームと同じ働きになります。次に、SExpr を型クラス Eq のインスタンスに設定します。INT, REAL, SYM の場合は、演算子 == で比較します。NIL と NIL は True を返します。それ以外の場合は False を返します。
Scheme の述語 eq? (Lisp の eq) はデータの同一性を判定します。つまり、データが配置されたメモリのアドレスが等しい場合に真を返します。この仕様を Haskell で実現するのはちょっと難しいので、データの値を使ってチェックすることにします。これは Scheme の述語 eqv? (Lisp の eql) と同じ動作になります。
関数 eq' は実引数リストから二つの要素 x, y を取り出して演算子 == でチェックするだけです。関数 equal' はリストの要素が eq' を満たせば真を返します。実際の判定は局所関数 iter で行います。どちらの引数も CELL の場合は、CAR 部と CDR 部を iter で比較します。そうでなければ、引数を演算子 == で比較します。
次はシンタックス形式を処理する関数を作りましょう。
リスト : シンタックス形式
-- quote
evalQuote :: GEnv -> LEnv -> SExpr -> Scm (SExpr, GEnv)
evalQuote genv lenv (CELL expr _) = return (expr, genv)
evalQuote _ _ _ = scmError "invalid quote form"
-- define
evalDef :: GEnv -> LEnv -> SExpr -> Scm (SExpr, GEnv)
evalDef genv lenv (CELL sym@(SYM name) (CELL expr NIL)) = do
(v, genv1) <- eval genv lenv expr
return (sym, M.insert name v genv1)
evalDef _ _ _ = scmError "invalid define form"
-- if
evalIf :: GEnv -> LEnv -> SExpr -> Scm (SExpr, GEnv)
evalIf genv lenv (CELL pred (CELL thenForm rest)) = do
(v, genv1) <- eval genv lenv pred
if v /= false
then eval genv1 lenv thenForm
else case rest of
CELL elseForm _ -> eval genv1 lenv elseForm
_ -> return (false, genv1)
evalIf _ _ _ = scmError $ "if : " ++ errNEA
-- lambda
evalLambda :: GEnv -> LEnv -> SExpr -> Scm (SExpr, GEnv)
evalLambda genv lenv expr = return (CLOS expr lenv, genv)
quote の処理は関数 evalQuote で行います。引数にはリスト (expr) が渡されるので、リストの先頭要素 expr を返すだけです。define の処理は関数 evalDefine で行います。define は変数 name と値 expr を大域変数に追加します。値 expr を eval で評価して、M.insert で Map に追加します。このとき新しい Map が生成されるので、その Map を返すことに注意してください。
if の処理は関数 evalIf で行います。最初に述語 pred を eval で評価し、それが false でなければ then 節を評価して返します。そうでなければ、else 節を有無をチェックして、else 節があればそれを評価します。else 節が無い場合は false を返します。ラムダ式の処理は関数 evalLambda で行います。これはクロージャを生成する処理です。ローカルな環境 lenv と引数の S 式 expr を CLOS に格納して返します。
次はリストを操作する関数 (primitive) を作りましょう。
リスト : リスト操作の基本関数 car :: SExpr -> Scm SExpr car NIL = scmError $ "car : " ++ errNEA car (CELL (CELL a _) _) = return a car _ = scmError $ "car : " ++ errCELL cdr :: SExpr -> Scm SExpr cdr NIL = scmError $ "cdr : " ++ errNEA cdr (CELL (CELL _ d) _) = return d cdr _ = scmError $ "cdr : " ++ errCELL cons :: SExpr -> Scm SExpr cons (CELL a (CELL b _)) = return (CELL a b) cons _ = scmError $ "cons : " ++ errNEA pair :: SExpr -> Scm SExpr pair NIL = scmError $ "pair? : " ++ errNEA pair (CELL (CELL _ _) _) = return true pair (CELL _ _) = return false
PRIM の場合、引数はコンスセルに格納されています。car は先頭要素がコンスセルであれば CAR 部に格納されているデータを返します。cdr は CDR 部に格納されているデータを返します。引数がコンスセルでない場合はエラーを返します。cons は第 1 引数 a と第 2 引数 b を取り出して、CELL に格納して返します。pair は第 1 引数が CELL ならば true を返します。そうでなければ false を返します。どの関数も引数の個数が足りない場合はエラーを返します。引数の数が多い場合は無視することとします。
最後に REPL (read - eval - print - loop) を作ります。
リスト : REPL (read - eval - print - loop)
initGEnv :: GEnv
initGEnv = M.fromList [("true", true),
("false", false),
("quote", SYNT evalQuote),
("define", SYNT evalDef),
("lambda", SYNT evalLambda),
("if", SYNT evalIf),
("eq?", PRIM eq'),
("equal?", PRIM equal'),
("pair?", PRIM pair),
("car", PRIM car),
("cdr", PRIM cdr),
("cons", PRIM cons)]
-- read-eval-print-loop
repl :: GEnv -> LEnv -> String -> IO ()
repl genv lenv xs = do
putStr "Scm> "
hFlush stdout
case readSExpr xs of
Left (ParseErr xs' mes) -> do putStrLn mes
repl genv lenv $ dropWhile (/= '\n') xs'
Right (expr, xs') -> do case eval genv lenv expr of
Left mes -> do putStrLn mes
repl genv lenv xs'
Right (v, genv1) -> do print v
repl genv1 lenv xs'
main :: IO ()
main = do
xs <- hGetContents stdin
repl initGEnv [] xs
repl はプロンプト Scm> を出力してから readSExpr を呼び出して S 式を読み込みます。エラーが返ってきた場合はエラーメッセージを出力し、改行までの入力を読み捨ててから repl を再帰呼び出しします。S 式 expr を読み込んだら、eval を呼び出して expr を評価します。エラーの場合はエラーメッセージを出力して repl を再帰呼び出しします。正常に評価できた場合は、その値 v を表示して repl を再帰呼び出しします。このとき、大域変数の環境は eval が返した genv1 を渡すことに注意してください。
main は hGetContents で標準入力から文字列を読み込み、それを repl に渡します。大域変数の環境は initGEnv で局所関数の環境は空リストになります。
それでは実行してみましょう。
Scm> () () Scm> 1 1 Scm> 1.2345 1.2345 Scm> "hello, world" "hello, world" Scm> 'a a Scm> (quote a) a Scm> '(1 2 3 4 5) (1 2 3 4 5) Scm> (cons 1 ()) (1) Scm> (cons 1 2) (1 . 2) Scm> (car '(a b c d)) a Scm> (cdr '(a b c d)) (b c d) Scm> (cons 'a '(b c d)) (a b c d) Scm> (eq? 1 1) true Scm> (eq? 1 2) false Scm> (eq? 1.234 1.234) true Scm> (eq? 1.234 1.2) false Scm> (eq? 'a 'a) true Scm> (eq? 'a 'b) false Scm> (eq? "abc" "abc") true Scm> (eq? "abc" "ABC") false Scm> (equal? '(1 2 3 4) '(1 2 3 4)) true Scm> (equal? '(1 2 3 4) '(1 2 3 4.0)) false Scm> (equal? '((1 2) (3 4)) '((1 2) (3 4))) true Scm> (equal? '((1 2) (3 4)) '((1 2) (3 . 4))) false Scm> (pair? '(a b c)) true Scm> (pair? 'a) false
quote, if, car, cdr, cons, eq?, equal?, pair? は正常に動作していますね。次は lambda と define を試してみます。
Scm> (define a 'b) a Scm> a b Scm> (lambda (x) x) <closure> Scm> ((lambda (x) x) 1) 1 Scm> ((lambda (x) x) 'a) a Scm> (define list (lambda x x)) list Scm> (list 1 2 3 4 5) (1 2 3 4 5) Scm> (list 'a 'b 'c 'd 'e) (a b c d e)
define で変数 a を定義します。シンボル a を入力すると、その値を求めることができます。lambda はクロージャを生成します。リストの先頭要素にラムダ式を指定すると、それを呼び出すことができます。そして、define と lambda を使って関数を定義することができます。
次は、レキシカルスコープとクロージャが正常に動作するか試してみましょう。
Scm> (define x 'a) x Scm> x a Scm> (define foo (lambda () x)) foo Scm> (foo) a Scm> (define bar (lambda (x) (foo))) bar Scm> (bar 'b) a
まず大域変数 x を a に初期化します。次に、関数 foo を定義します。foo の引数はないので、x は大域変数を参照します。したがって、foo を評価すると返り値は a になります。次に、関数 bar から foo を呼び出します。bar の仮引数は x ですが、(bar 'b) を評価すると a が返ってきます。確かにレキシカルスコープになっています。
今度はクロージャの動作を確かめます。
Scm> (define baz (lambda (x) (lambda (y) (cons x y)))) baz Scm> (define baz-a (baz 'a)) baz-a Scm> (baz-a 'b) (a . b) Scm> (baz-a 'c) (a . c)
関数 baz はクロージャを生成して返します。このとき、baz の引数 x の値がクロージャに保存されます。(baz 'a) の返り値を baz-a にセットすると、baz-a は a と baz-a の引数を組にしたものを返す関数となります。したがって、(baz-a 'b) は (a . b) を、(baz-a 'c) は (a . c) を返します。クロージャも正常に動作していますね。
define で定義する関数は再帰呼び出しが可能です。簡単なリスト操作関数を再帰定義で作ってみました。プログラムリストと実行結果を示します。
リスト : リストの結合
(define append
(lambda (xs ys)
(if (pair? xs)
(cons (car xs) (append (cdr xs) ys))
ys)))
Scm> (define append (lambda (xs ys) (if (pair? xs) (cons (car xs) (append (cdr xs) ys)) ys))) append Scm> (append '(a b c d) '(e f g h)) (a b c d e f g h) Scm> (append '((a b) (c d)) '((e f) (g h))) ((a b) (c d) (e f) (g h))
リスト : リストの反転
(define reverse
(lambda (xs)
(if (pair? xs)
(append (reverse (cdr xs)) (list (car xs)))
())))
Scm> (define reverse (lambda (xs) (if (pair? xs) (append (reverse (cdr xs)) (list (car xs))) ()))) reverse Scm> (reverse '(a b c d e f)) (f e d c b a) Scm> (reverse '((a b) (c d) (e f))) ((e f) (c d) (a b))
もちろん、高階関数も定義することができます。
リスト : マッピング
(define map
(lambda (f xs)
(if (pair? xs)
(cons (f (car xs)) (map f (cdr xs)))
())))
Scm> (define map (lambda (f xs) (if (pair? xs) (cons (f (car xs)) (map f (cdr xs))) ()))) map Scm> (map (lambda (x) (cons x x)) '(1 2 3 4 5)) ((1 . 1) (2 . 2) (3 . 3) (4 . 4) (5 . 5)) Scm> (map car '((a 1) (b 2) (c 3) (d 4) (e 5))) (a b c d e) Scm> (map cdr '((a 1) (b 2) (c 3) (d 4) (e 5))) ((1) (2) (3) (4) (5))
リスト : フィルター
(define filter
(lambda (f xs)
(if (pair? xs)
(if (f (car xs))
(cons (car xs) (filter f (cdr xs)))
(filter f (cdr xs)))
())))
Scm> (define filter (lambda (f xs) (if (pair? xs) (if (f (car xs)) (cons (car xs) (filter f (cdr xs))) (filter f (cdr xs))) ()))) filter Scm> (filter (lambda (x) (eq? x 'a)) '(a b c a b c a b c)) (a a a)
リスト : 畳み込み
(define fold-left
(lambda (f a xs)
(if (pair? xs)
(fold-left f (f a (car xs)) (cdr xs))
a)))
(define fold-right
(lambda (f a xs)
(if (pair? xs)
(f (car xs) (fold-rightf a (cdr xs)))
a)))
Scm> (define fold-left (lambda (f a xs) (if (pair? xs) (fold-left f (f a (car xs)) (cdr xs)) a))) fold-left Scm> (fold-left (lambda (a x) (cons x a)) () '(1 2 3 4 5)) (5 4 3 2 1) Scm> (define fold-right (lambda (f a xs) (if (pair? xs) (f (car xs) (fold-right f a (cdr xs))) a))) fold-right Scm> (fold-right cons () '(1 2 3 4 5)) (1 2 3 4 5)
今回はここまでです。次回は変数の値を書き換えるシンタックス形式 set! と数の算術演算、比較演算を追加します。
--
-- mscheme1.hs : microScheme インタプリタ
--
-- Copyright (C) 2013-2021 Makoto Hiroi
--
import Data.Char
import qualified Data.Map as M
import System.IO
-- S 式の定義
data SExpr = INT Integer
| REAL Double
| SYM String
| STR String
| CELL SExpr SExpr
| NIL
| PRIM (SExpr -> Scm SExpr)
| SYNT (GEnv -> LEnv -> SExpr -> Scm (SExpr, GEnv))
| CLOS SExpr LEnv
-- 等値の定義
instance Eq SExpr where
INT x == INT y = x == y
REAL x == REAL y = x == y
SYM x == SYM y = x == y
STR x == STR y = x == y
NIL == NIL = True
_ == _ = False
-- パーサエラーの定義
data ParseErr = ParseErr String String deriving Show
-- パーサの定義
type Parser a = Either ParseErr a
-- エラーの送出
parseError :: String -> String -> Parser a
parseError x s = Left (ParseErr x s)
-- 評価器の定義
type Scm a = Either String a
-- エラーの送出
scmError :: String -> Scm a
scmError s = Left s
-- ローカル環境の定義
type LEnv = [(String, SExpr)]
-- グローバルな環境
type GEnv = M.Map String SExpr
-- 真偽値
true = SYM "true"
false = SYM "false"
-- Primitive の定義
errNEA = "Not enough arguments"
errCELL = "Illegal argument, List required"
errINT = "Illegal argument, Integer required"
errNUM = "Illegal argument, Number required"
-- リスト操作
car :: SExpr -> Scm SExpr
car NIL = scmError $ "car : " ++ errNEA
car (CELL (CELL a _) _) = return a
car _ = scmError $ "car : " ++ errCELL
cdr :: SExpr -> Scm SExpr
cdr NIL = scmError $ "cdr : " ++ errNEA
cdr (CELL (CELL _ d) _) = return d
cdr _ = scmError $ "cdr : " ++ errCELL
cons :: SExpr -> Scm SExpr
cons (CELL a (CELL b _)) = return (CELL a b)
cons _ = scmError $ "cons : " ++ errNEA
-- 述語
eq' :: SExpr -> Scm SExpr
eq' (CELL x (CELL y _)) =
if x == y then return true else return false
eq' _ = scmError $ "eq : " ++ errNEA
equal' :: SExpr -> Scm SExpr
equal' (CELL x (CELL y _)) =
if iter x y then return true else return false
where iter (CELL a b) (CELL c d) = iter a c && iter b d
iter x y = x == y
equal' _ = scmError $ "equal : " ++ errNEA
pair :: SExpr -> Scm SExpr
pair NIL = scmError $ "pair? : " ++ errNEA
pair (CELL (CELL _ _) _) = return true
pair (CELL _ _) = return false
--
-- S 式の表示
--
showCell :: SExpr -> String
showCell (CELL a d) =
show a ++ case d of
NIL -> ""
PRIM _ -> "<primitive>"
CLOS _ _ -> "<closure>"
SYNT _ -> "<syntax>"
INT x -> " . " ++ show x
REAL x -> " . " ++ show x
SYM x -> " . " ++ x
STR x -> " . " ++ show x
_ -> " " ++ showCell d
showCell xs = show xs
instance Show SExpr where
show (INT x) = show x
show (REAL x) = show x
show (SYM x) = x
show (STR x) = show x
show NIL = "()"
show (SYNT _) = "<syntax>"
show (PRIM _) = "<primitive>"
show (CLOS _ _) = "<closure>"
show xs = "(" ++ showCell xs ++ ")"
--
-- S 式の読み込み
--
isAlpha' :: Char -> Bool
isAlpha' x = elem x "!$%&*+-/:<=>?@^_~"
isIdent0 :: Char -> Bool
isIdent0 x = isAlpha x || isAlpha' x
isIdent1 :: Char -> Bool
isIdent1 x = isAlphaNum x || isAlpha' x
isREAL :: Char -> Bool
isREAL x = elem x ".eE"
quote = SYM "quote"
isNUM :: String -> Bool
isNUM (x:_) = isDigit x
isNUM _ = False
getNumber :: String -> Parser (SExpr, String)
getNumber xs =
let (s, ys) = span isDigit xs
in if not (null ys) && isREAL (head ys)
then case reads xs of
[] -> parseError "" "" -- ありえないエラー
[(y', ys')] -> return (REAL y', ys')
else return (INT (read s), ys)
readSExpr :: String -> Parser (SExpr, String)
readSExpr [] = parseError "" "EOF"
readSExpr (x:xs)
| isSpace x = readSExpr xs
| isDigit x = getNumber (x:xs)
| isIdent0 x = if x == '+' && isNUM xs
then getNumber xs
else if x == '-' && isNUM xs
then do (y, ys) <- getNumber xs
case y of
INT x -> return (INT (- x), ys)
REAL x -> return (REAL (- x), ys)
else let (name, ys) = span isIdent1 (x:xs)
in return (SYM name, ys)
| otherwise =
case x of
'(' -> readCell 0 xs
';' -> readSExpr $ dropWhile (/= '\n') xs
'"' -> case reads (x:xs) of
[] -> parseError "" ""
[(y, ys)] -> y `seq` ys `seq` return (STR y, ys)
'\'' -> readSExpr xs >>= \(e, ys) -> e `seq` ys `seq` return (CELL quote (CELL e NIL), ys)
_ -> parseError xs ("unexpected token: " ++ show x)
readCell :: Int -> String -> Parser (SExpr, String)
readCell _ [] = parseError "" "EOF"
readCell n (x:xs)
| isSpace x = readCell n xs
| otherwise =
case x of
')' -> xs `seq` return (NIL, xs)
'.' -> if n == 0
then parseError xs "invalid dotted list"
else do (e, ys) <- readSExpr xs
case dropWhile isSpace ys of
')':zs -> return (e, zs)
_ -> parseError xs "invalid dotted list"
'(' -> do (a, ys) <- readCell 0 xs
(d, zs) <- readCell 1 ys
return (CELL a d, zs)
_ -> do (a, ys) <- readSExpr (x:xs)
(d, zs) <- readCell 1 ys
return (CELL a d, zs)
--
-- S 式の評価
--
eval :: GEnv -> LEnv -> SExpr -> Scm (SExpr, GEnv)
eval genv lenv NIL = return (NIL, genv)
eval genv lenv v@(INT _) = return (v, genv)
eval genv lenv v@(REAL _) = return (v, genv)
eval genv lenv v@(STR _) = return (v, genv)
eval genv lenv (SYM name) =
case lookup name lenv of
Nothing -> case M.lookup name genv of
Nothing -> scmError $ "unbound variable: " ++ name
Just v -> return (v, genv)
Just v -> return (v, genv)
eval genv lenv (CELL func args) = do
(v, genv1) <- eval genv lenv func
case v of
SYNT f -> f genv1 lenv args
_ -> do (vs, genv2) <- evalArguments genv1 lenv args
apply genv2 lenv v vs
-- 引数の評価
evalArguments :: GEnv -> LEnv -> SExpr -> Scm (SExpr, GEnv)
evalArguments genv lenv NIL = return (NIL, genv)
evalArguments genv lenv (CELL expr rest) = do
(v, genv1) <- eval genv lenv expr
(vs, genv2) <- evalArguments genv1 lenv rest
return (CELL v vs, genv2)
evalArguments _ _ _ = scmError "invalid function form"
-- 変数束縛
makeBindings :: LEnv -> SExpr -> SExpr -> Scm LEnv
makeBindings lenv NIL _ = return lenv
makeBindings lenv (SYM name) rest = return ((name, rest):lenv)
makeBindings lenv (CELL (SYM name) parms) (CELL v args) = do
lenv' <- makeBindings lenv parms args
return ((name, v):lenv')
makeBindings lenv _ NIL = scmError errNEA
makeBindings lenv _ _ = scmError "invalid arguments form"
-- 関数適用
apply :: GEnv -> LEnv -> SExpr -> SExpr -> Scm (SExpr, GEnv)
apply genv lenv func actuals =
case func of
PRIM f -> do v <- f actuals
return (v, genv)
CLOS (CELL parms body) lenv0 -> do
lenv1 <- makeBindings lenv0 parms actuals
evalBody genv lenv1 body
_ -> scmError $ "Not Function: " ++ show func
-- 本体の評価
evalBody :: GEnv -> LEnv -> SExpr -> Scm (SExpr, GEnv)
evalBody genv lenv (CELL expr NIL) = eval genv lenv expr
evalBody genv lenv (CELL expr rest) = do
(_, genv1) <- eval genv lenv expr
evalBody genv1 lenv rest
evalBody _ _ _ = scmError "invalid body form"
--
-- シンタックス形式
--
-- quote
evalQuote :: GEnv -> LEnv -> SExpr -> Scm (SExpr, GEnv)
evalQuote genv lenv (CELL expr _) = return (expr, genv)
evalQuote _ _ _ = scmError "invalid quote form"
-- define
evalDef :: GEnv -> LEnv -> SExpr -> Scm (SExpr, GEnv)
evalDef genv lenv (CELL sym@(SYM name) (CELL expr NIL)) = do
(v, genv1) <- eval genv lenv expr
return (sym, M.insert name v genv1)
evalDef _ _ _ = scmError "invalid define form"
-- if
evalIf :: GEnv -> LEnv -> SExpr -> Scm (SExpr, GEnv)
evalIf genv lenv (CELL pred (CELL thenForm rest)) = do
(v, genv1) <- eval genv lenv pred
if v /= false
then eval genv1 lenv thenForm
else case rest of
CELL elseForm _ -> eval genv1 lenv elseForm
_ -> return (false, genv1)
evalIf _ _ _ = scmError $ "if : " ++ errNEA
-- lambda
evalLambda :: GEnv -> LEnv -> SExpr -> Scm (SExpr, GEnv)
evalLambda genv lenv expr = return (CLOS expr lenv, genv)
--
-- 大域変数の初期化
--
initGEnv :: GEnv
initGEnv = M.fromList [("true", true),
("false", false),
("quote", SYNT evalQuote),
("define", SYNT evalDef),
("lambda", SYNT evalLambda),
("if", SYNT evalIf),
("eq?", PRIM eq'),
("equal?", PRIM equal'),
("pair?", PRIM pair),
("car", PRIM car),
("cdr", PRIM cdr),
("cons", PRIM cons)]
--
-- read-eval-print-loop
--
repl :: GEnv -> LEnv -> String -> IO ()
repl genv lenv xs = do
putStr "Scm> "
hFlush stdout
case readSExpr xs of
Left (ParseErr xs' mes) -> do putStrLn mes
repl genv lenv $ dropWhile (/= '\n') xs'
Right (expr, xs') -> do case eval genv lenv expr of
Left mes -> do putStrLn mes
repl genv lenv xs'
Right (v, genv1) -> do print v
repl genv1 lenv xs'
main :: IO ()
main = do
xs <- hGetContents stdin
repl initGEnv [] xs