今回は Common Lisp で小さな Scheme インタプリタ "micro Scheme" を作ってみましょう。
最初に Scheme について簡単に説明します。Scheme は 1975 年に Gerald J.Sussman と Guy L. Steele Jr. によって作成された Lisp の方言です。伝統的な Lisp はダイナミックスコープですが、Scheme はレキシカルスコープを採用しています。その後、Common Lisp でもレキシカルスコープが採用されました。
関数型言語の場合、関数は他のデータと同等に扱うことができます。つまり、関数を変数に代入したり、関数を引数として渡すことができます。また、関数を値として返すこともできます。ところが、Common Lisp の関数はちょっと変わっています。次の例を見てください。
* (defvar func (lambda (x y) (+ x y))) FUNC * (funcall func 1 2) 3
上の例は SBCL で実行した場合です。ラムダ式は無名の関数を返します。それを変数 func に格納して呼び出すことができます。Common Lisp の場合、変数に格納された関数は (func 1 2) のように呼び出すことはできません。funcall や apply を使って呼び出します。これに対し、Scheme は (func 1 2) と呼び出すことができます。次の例を見てください。
> (define func (lambda (x y) (+ x y))) func > (func 1 2) 3
このように、Common Lisp よりも簡単に関数を取り扱うことができます。また、「継続 (continuation)」を取り扱うことができるのも Scheme の特徴です。継続はプログラムの実行状態を保存しておいて、あとから実行を再開することができます。これは Common Lisp にはない強力な機能です。
Scheme に興味のある方は、拙作のページ「お気楽 Scheme プログラミング入門」を読んでみてください。
Lisp で小さな Lisp 処理系を作ることは簡単です。では、Lisp に必要な最低限の機能には何があるでしょうか。参考文献 1 『LISP 入門』によると、次に示す機能だけを含む Lisp を「純 LISP (pure LISP)」と呼ぶそうです。196 頁より引用します。
純 LISP の機能としては, 次のようなものだけが含まれます。
- CAR, CDR, CONS という基本的リスト処理機能。
- ATOM, NULL, EQUAL という基本的述語。
- プログラムの実行は, 再帰呼び出しを含めた関数呼び出しだけで, PROG などの順次処理を含まない。
- 変数値はラムダ式による束縛によってのみ与えられる。SETQ は存在しない。
このほかに, さらに次のような制限を設ける人もいます。- 数値を含まない。自然数は (A A ... A) というように n 個の要素を持つリストで表す。
- 関数定義関数の存在を許さない。関数に相当するものはラムダ式で与える。
このほかにも、純LISP - Wikipedia には 『純LISPには二種のデータ(リスト、アトム)、及びそれらを操作する五つの基本関数だけが存在する』 と書かれています。基本関数は car, cdr, cons, eq, atom の 5 つです。
5 つの基本関数とラムダ式だけでプログラムを作るのは大変です。そこで、条件分岐 cond と関数定義 defun を追加することにします。LISP - Wikipedia によると、これを『最小の Lisp』 というそうです。
今回は最小の Lisp にならって、次に示す関数を持つ小さな Scheme 処理系を作ることにします。
Scheme の関数 car, cdr, cons, quote, if は Common Lisp とほぼ同じです。Scheme の場合、car と cdr で空リストを評価するとエラーになります。eq? は eq のことで、pair? は consp と同じす。define は変数束縛を行う特殊形式 (シンタックス形式) です。Scheme のラムダ式は「レキシカルクロージャ」になります。define で変数にラムダ式をセットすれば、それで関数を定義することができます。
データは Common Lisp のデータをそのまま使います。このようにすると、プログラムの読み込みは関数 read で、データの出力も print や princ で行うことができます。Scheme には真偽値 (boolean) を表すデータ型 #t と #f がありますが、今回の micro Scheme ではシンボル true と false で真偽値を表すことにします。具体的には、偽を false で表して、それ以外のデータを真と判断します。Common Lisp のように、nil で真偽を判断することはできません。ご注意くださいませ。
あとは読み込んだ S 式を評価する処理を作ればいいわけです。ただし、末尾再帰最適化など実装が難しい機能は省略します。また、エラーチェックも可能な限り省くことにします。厳密な意味で Scheme とはいえませんが、その分だけ簡単にプログラムを作ることができます。
micro Scheme インタプリタの主役は関数 m-eval と m-apply です。この 2 つの関数は Lisp / Scheme の関数 eval と apply に相当します。m- は micro- を省略したものです。m-eval は評価する S 式と環境 (environment) を受け取り、渡された環境の下で S 式を評価します。環境はアクセス可能な局所変数の集合のことで、今回は連想リストで表すことにします。
関数値 : (tag ... ) tag の種類 syntax : シンタックス形式 (if, quote, define, lambda) primitive : Common Lisp の関数を呼び出す (car, cdr, cons, eq, consp) closure : クロージャ (ラムダ式) macro : マクロ (予約)
m-eval の仕事は簡単です。S 式が自己評価フォームであれば、それをそのまま返します。シンボル (変数) であれば環境からその値を求めて返します。リストの場合はちょっと複雑です。先頭の要素を評価して、それが関数値であればそれを呼び出します。今回は関数値をリストで表すことにします。関数値の種類を下記に示します。
syntax はシンタックス形式を表します。tag の後ろにその処理を担当する関数を格納しておきます。m-eval は引数を評価しないで、処理を担当する関数にそのまま渡します。このとき、環境も必要になるのでいっしょに渡します。
primitive は Common Lisp の関数を呼び出します。tag の後ろに呼び出す関数値をセットします。closure はクロージャを表します。tag の後ろにはラムダ式とクロージャを生成したときの環境をセットします。primitive と clousre の評価は m-apply で行います。m-eval は引数を評価して m-apply に渡します。
プログラムは次のようになります。
リスト : S 式の評価
;;; 自己評価フォームか
(defun self-evaluationp (expr)
(and (not (consp expr)) (not (symbolp expr))))
;;; eval
(defun m-eval (expr env)
(cond ((self-evaluationp expr) expr)
((symbolp expr)
(let ((cell (lookup expr env)))
(if cell
(cdr cell)
(error "unbound variable ~S" expr))))
((consp expr)
(let ((procedure (m-eval (car expr) env)))
(case (car procedure)
((syntax) (funcall (cadr procedure) expr env))
(t
(m-apply procedure
(mapcar (lambda (x) (m-eval x env)) (cdr expr)))))))
(t
(error "unknown expression type -- m-eval ~S" expr))))
m-eval の引数 expr が評価する S 式、env が環境です。self-evaluationp は自己評価フォームかチェックします。今回はリストとシンボル以外は自己評価フォームとしましたが、micro Scheme が扱うデータ型だけを自己評価フォームとしてもかまいません。
expr がシンボルの場合は環境 env から変数を探します。この処理を関数 lookup で行います。変数が見つからない場合は大域変数から探します。大域変数は *global-environment* に格納します。大域変数も連想リストで管理します。lookup はコンスセル (変数 . 値) を返すので、cdr で値を取り出して返します。見つからない場合はエラー unbound variable を送出します。
expr がリストの場合は、その先頭要素を m-eval で評価して procedure にセットします。procedure がリストでその先頭要素が syntax の場合は、procedure の第 2 要素を呼び出します。このとき、引数として expr と env をそのまま渡します。そうでなければ、procedure を m-apply に渡して評価します。このとき、procedure に渡す引数 (cdr expr) を m-eval で評価し、その結果をリストに格納して渡します。この処理は mapcar を使うと簡単です。
次は m-apply を作りましょう。
リスト : 関数適用
(defun m-apply (procedure actuals)
(case (car procedure)
((primitive)
(apply (cadr procedure) actuals))
((closure)
(let ((expr (cadr procedure)))
(eval-body (cddr expr)
(add-binding (cadr expr) actuals (caddr procedure)))))
(t
(error "unknown procedure type -- m-apply ~S" procedure))))
;;; body の評価
(defun eval-body (body env)
(cond ((null (cdr body))
(m-eval (car body) env))
(t
(m-eval (car body) env)
(eval-body (cdr body) env))))
m-apply の引数 procedure は micro Scheme の関数値、actuals は引数を格納したリストです。引数は評価済みであることに注意してください。procedure が primitive の場合、2 番目の要素に関数が格納されています。apply でその関数を呼び出します。
procedure が closure の場合、2 番目の要素にラムダ式、3 番目の要素に環境が格納されています。まず最初にラムダ式を取り出して、変数 expr にセットします。expr の 2 番目の要素が仮引数です。関数 add-binding は変数束縛を行います。そして、それを環境に追加して返します。このとき、ラムダ式を生成したときの環境が使われることに注意してください。
Scheme のラムダ式はクロージャになるので、ラムダ式を定義したときの環境が必ず保存されています。ラムダ式の本体はこの新しい環境で評価されます。この処理を関数 eval-body で行います。引数 body は S 式を格納したリスト、env が環境です。eva-body は複数の S 式を順番に m-eval で評価して、最後に評価した S 式の結果を返します。
次は変数束縛を行う関数 add-binding を作ります。
リスト : 変数束縛
(defun add-binding (vars vals env)
(cond ((null vars) env)
((symbolp vars)
(cons (cons vars vals) env))
(t
(cons (cons (car vars) (car vals))
(add-binding (cdr vars) (cdr vals) env)))))
add-binding は仮引数のシンボルと実引数の値を組にして環境 env に追加します。仮引数のリスト vars が空リストの場合は env を返します。vars がシンボルの場合は可変個引数なので、vars と vals を組にして env に追加します。それ以外の場合は vars の先頭要素と vals の先頭要素を組にします。なお、引数の個数についてエラーチェックは行っていません。興味のある方はプログラムを改造してみてください。
変数値の取得は関数 lookup で行います。次のリストを見てください。
リスト : 変数値の取得
;;; 大域変数
(defvar *global-environment*)
;;; 変数の値を取得
(defun lookup (var env)
(let ((value (assoc var env)))
(if value
value
(assoc var *global-environment*))))
環境 env は連想リストなので、assoc で env から var を探索するだけです。見つからない場合は大域変数 *gloal-environment* から探します。
次はシンタックス形式を処理する関数を作りましょう。次のリストを見てください。
リスト : シンタックス形式の処理
;;; (quote x)
(defun m-quote (expr env)
(declare (ignore env))
(cadr expr))
(defun true-p (x) (not (eq x 'false)))
;;; (if test then eles)
(defun m-if (expr env)
(if (true-p (m-eval (cadr expr) env))
(m-eval (caddr expr) env)
(if (null (cdddr expr))
'*undef*
(m-eval (cadddr expr) env))))
;;; (lambda (args ...) body ...)
(defun m-lambda (expr env)
(list 'closure expr env))
;;; (define name s-expr)
(defun m-define (expr env)
(setf *global-environment*
(cons (cons (cadr expr)
(m-eval (caddr expr) env))
*global-environment*))
(cadr expr))
quote の処理は m-quote で行います。引数 expr には (quote x) が渡されるので、expr の第 2 要素を返します。if の処理は m-if で行います。expr の第 2 要素を m-eval で評価し、それが false でなければ expr の第 3 要素を m-eval で評価して、その結果を返します。偽の場合は expr に第 4 要素があるかチェックし、あればそれを m-eval で評価します。そうでなければシンボル *undef* を返します。*undef* は未定義を表すシンボルとして使います。
lambda の処理は m-lambda で行います。これはクロージャを生成する処理です。m-lambda はシンタックス形式なので引数 env に環境が渡されます。これとラムダ式 expr をリストに格納し、それにタグ closure を付けて返します。define の処理は m-define で行います。define は変数と値を組にして大域変数 *global-environment* に追加します。このとき、値 (caddr expr) を m-eval で評価します。これでラムダ式を使って関数を定義することができます。
最後に read - eval - print - loop (REPL) を作ります。
リスト : read - eval - print - loop
;;; 初期化
(setf *global-environment*
(list
(cons 'true 'true)
(cons 'false 'false)
(cons 'nil 'nil)
(cons 'quit 'quit)
(list 'car 'primitive (lambda (x)
(if (null x)
(error "type error -- car NIL")
(car x))))
(list 'cdr 'primitive (lambda (x)
(if (null x)
(error "type error -- cdr NIL")
(cdr x))))
(list 'cons 'primitive #'cons)
(list 'eq? 'primitive (lambda (x y) (if (eq x y) 'true 'false)))
(list 'pair? 'primitive (lambda (x) (if (consp x) 'true 'false)))
(list 'if 'syntax #'m-if)
(list 'quote 'syntax #'m-quote)
(list 'lambda 'syntax #'m-lambda)
(list 'define 'syntax #'m-define)
))
;;; read-eval-print-loop
(defun repl (&rest file-list)
(dolist (file file-list)
(with-open-file (in file :direction :input)
(do ((output t))
((eq output nil) (terpri))
(setf output (m-eval (read in nil) '()))
(print output))))
;;
(do ((output nil))
((eq output 'quit))
(princ ">>> ")
(force-output)
(handler-case
(progn
(setf output (m-eval (read) '()))
(princ output)
(terpri))
(simple-error (c) (format t "ERROR: ~a~%" c)))))
最初に大域変数 *global-environment* を初期化します。true, false, nil, quit は自分自身に初期化します。car と cdr は引数 x が空リストかチェックしています。また、eq? と pair? は eq と consp を呼び出すだけではなく、true と false を返すようにします。
REPL を実行する前に、プログラムをロードできると便利です。関数 repl の引数 file-list でファイル名を指定して、そのファイルを読み込みます。read で S 式を読み込み、それを m-eval で評価します。このとき、環境は空リストを渡します。それから、REPL を実行します。quit が入力されたら REPL を終了します。
それでは実行してみましょう。
>>> (quote a) A >>> 'a A >>> (if true 'a 'b) A >>> (if false 'a 'b) B >>> (car '(a b c)) A >>> (cdr '(a b c)) (B C) >>> (cons 'a 'b) (A . B) >>> (eq? 'a 'a) TRUE >>> (eq? 'a 'b) FALSE >>> (pair? '(a b c)) TRUE >>> (pair? 'a) FALSE
quote, if, car, cdr, cons, eq?, pair? は正常に動作していますね。次は lambda と define を試してみます。
>>> (define a 'b) A >>> a B >>> (lambda (x) x) (CLOSURE (LAMBDA (X) X) NIL) >>> ((lambda (x) x) 'a) A >>> (define list (lambda x x)) LIST >>> (list 'a 'b 'c 'd 'e) (A B C D E)
define で変数 a を定義して、その値を求めることができます。lambda はクロージャを生成し、ラムダ式で関数呼び出しも可能です。そして、define と lambda を使って関数を定義することができます。
次は、レキシカルスコープとクロージャが正常に動作するか試してみましょう。
>>> (define x 'a) X >>> x A >>> (define foo (lambda () x)) FOO >>> (foo) A >>> (define bar (lambda (x) (foo))) BAR >>> (bar 'b) A
まず最初に大域変数 x を a に初期化します。次に、関数 foo を定義します。foo の引数はないので、x は大域変数を参照します。したがって、foo を評価すると返り値は a になります。次に、関数 bar から foo を呼び出します。bar は引数 x を受け取ります。(bar 'b) を評価すると a が返ってきます。確かにレキシカルスコープになっています。
foo と bar の値を表示すると次のようになります。
>>> foo (CLOSURE (LAMBDA NIL X) NIL) >>> bar (CLOSURE (LAMBDA (X) (FOO)) NIL)
どちらの関数も環境が空リストになっています。(bar 'b) を評価するとき、この環境に (x . b) が追加されます。そして、(foo) を呼び出しますが、foo に引数はないので、環境は空リストのままです。したがって、(foo) の返り値は大域変数の値 a になるのです。
今度はクロージャの動作を確かめます。
>>> (define baz (lambda (x) (lambda (y) (cons x y)))) BAZ >>> (define baz-a (baz 'a)) BAZ-A >>> (baz-a 'b) (A . B) >>> (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) を返します。クロージャも正常に動作していますね。
baz と baz-a の値を表示すると、次のようになります。
>>> baz (CLOSURE (LAMBDA (X) (LAMBDA (Y) (CONS X Y))) NIL) >>> baz-a (CLOSURE (LAMBDA (Y) (CONS X Y)) ((X . A)))
baz の環境は空リストですが、baz-a の環境は ((x . a)) となります。(baz-a 'b) を評価するとき、クロージャの環境に (y . b) が追加され、その下で (cons x y) が評価されます。したがって、x の値は a で y の値が b になるのです。
define で定義する関数は再帰呼び出しが可能です。簡単なリスト操作関数を再帰定義で作ってみました。プログラムリストと実行結果を示します。
リスト : append と reverse
;;; 空リストか
(define null? (lambda (x) (eq? x '())))
;;; 否定
(define not (lambda (x) (if (eq? x false) true false)))
;;; リストの結合
(define append
(lambda (xs ys)
(if (null? xs)
ys
(cons (car xs) (append (cdr xs) ys)))))
;;; リストの反転
(define reverse
(lambda (ls)
(if (null? ls)
'()
(append (reverse (cdr ls)) (list (car ls))))))
>>> (append '(a b c) '(d e f)) (A B C D E F) >>> (append '((a b) (c d)) '(e f g)) ((A B) (C D) E F G) >>> (reverse '(a b c d e)) (E D C B A) >>> (reverse '((a b) c (d e))) ((D E) C (A B))
リスト : 探索
;;; リストの探索
(define memq
(lambda (x ls)
(if (null? ls)
false
(if (eq? x (car ls))
ls
(memq x (cdr ls))))))
;;; 連想リストの探索
(define assq
(lambda (x ls)
(if (null? ls)
false
(if (eq? x (car (car ls)))
(car ls)
(assq x (cdr ls))))))
>>> (memq 'a '(a b c d e)) (A B C D E) >>> (memq 'c '(a b c d e)) (C D E) >>> (memq 'f '(a b c d e)) FALSE >>> (assq 'a '((a 1) (b 2) (c 3) (d 4) (e 5))) (A 1) >>> (assq 'e '((a 1) (b 2) (c 3) (d 4) (e 5))) (E 5) >>> (assq 'f '((a 1) (b 2) (c 3) (d 4) (e 5))) FALSE
リスト : 高階関数
;;; マッピング
(define map
(lambda (fn ls)
(if (null? ls)
'()
(cons (fn (car ls)) (map fn (cdr ls))))))
;;; フィルター
(define filter
(lambda (fn ls)
(if (null? ls)
'()
(if (fn (car ls))
(cons (car ls) (filter fn (cdr ls)))
(filter fn (cdr ls))))))
;;; 畳み込み
(define fold-right
(lambda (fn a ls)
(if (null? ls)
a
(fn (car ls) (fold-right fn a (cdr ls))))))
(define fold-left
(lambda (fn a ls)
(if (null? ls)
a
(fold-left fn (fn a (car ls)) (cdr ls)))))
>>> (map car '((a 1) (b 2) (c 3) (d 4) (e 5))) (A B C D E) >>> (map cdr '((a 1) (b 2) (c 3) (d 4) (e 5))) ((1) (2) (3) (4) (5)) >>> (map (lambda (x) (cons x x)) '(a b c d e)) ((A . A) (B . B) (C . C) (D . D) (E . E)) >>> (filter (lambda (x) (not (eq? x 'a))) '(a b c a b c a b c)) (B C B C B C) >>> (fold-left cons '() '(a b c d e)) (((((NIL . A) . B) . C) . D) . E) >>> (fold-right cons '() '(a b c d e)) (A B C D E)
ところで、スコープを「ダイナミックスコープ」に変更することも簡単です。次のリストを見てください。
リスト : apply (ダイナミックスコープ版)
(defun m-apply (procedure actuals)
(case (car procedure)
((primitive)
(apply (cadr procedure) actuals))
((closure)
(let ((expr (cadr procedure)))
(eval-body (cddr expr)
(add-binding (cadr expr)
actuals
env)))) ; (1)
; (2) (append (caddr procedure) env)))))
(t
(error "unknown procedure type -- m-apply ~S" procedure))))
m-apply を呼び出すとき環境 env を渡します。そして、add-binding で変数束縛するとき、(1) のように env を渡します。これで昔の Lisp と同じダイナミックスコープになります。
簡単な実行例を示しましょう。
>>> (define x 0) X >>> (define foo (lambda () x)) FOO >>> (foo) 0 >>> (define bar (lambda (x) (foo))) BAR >>> (bar 10) 10
このように、関数 foo から関数 bar の局所変数にアクセスすることができます。ただし、このままではクロージャが機能しません。また、ラムダ式を定義するときの環境とラムダ式を実行するときの環境が異なることで問題が発生する場合があります。このような問題を "funarg 問題" といいます。
簡単な例を示しましょう。
リスト : funarg 問題
;;; フィルター
(define filter
(lambda (x y)
(if (null? y)
'()
(if (x (car y))
(cons (car y) (filter x (cdr y)))
(filter x (cdr y))))))
;;; 削除
(define remove
(lambda (y z)
(filter (lambda (x) (not (eq? x y))) z)))
filter と remove を定義します。ここで変数 y に注目してください。remove で filter に渡すラムダ式で変数 y を参照しています。この y は remove の引数 y を参照するべきです。ダイナミックスコープでは、クロージャがなくても引数 y にアクセスすることは可能です。
ところが、filter でも変数 y を使っていますね。この変数 y の値は remove の引数 z になり、引数 x の値が (lambda (x) (not (eq? x y))) になります。そして、x を評価するとき y の値を参照しますが、ダイナミックスコープでは filter の引数 y の値になります。つまり、remove の引数 y は隠蔽されてアクセスできなくなるのです。
実際に試してみると、remove は正常に動作しません。
>>> (remove 'a '(a b c a b c)) (A B C A B C) >>> (remove 'b '(a b c a b c)) (A B C A B C)
この問題はラムダ式を生成するとき、その時点での環境を保存することで解決することができます。つまり、クロージャがあればよいのです。実際、apply のリストで (1) から (2) のようにクロージャに保存しておいた環境を加えると、ダイナミックスコープでも remove は正常に動作します。
Common Lisp 以前の Lisp では funarg 問題を解決するため、クロージャを生成するときはラムダ式の前に #' 付けることにしました。これが function 特殊形式です。そして、生成されたクロージャのことを「レキシカルクロージャ」といいます。この結果、ラムダ式は単なるリストで表されたものとレキシカルクロージャを生成するものとが混在するようになりました。
これを統一したのが Scheme です。Scheme は関数 (ラムダ式) をクロージャとして扱い、レキシカルスコープを採用した最初の Lisp 処理系です。この後、レキシカルスコープは Common Lisp にも採用されました。Common Lisp は変数を defvar で宣言するとダイナミックスコープになりますが、レキシカルクロージャを使うかぎり funarg 問題は発生しません。当然ですが、Scheme に funarg 問題はありません。
今回はここまでです。次回は micro Scheme に伝統的なマクロを追加してみましょう。
;;;
;;; micro.lsp : micro Scheme with Common Lisp
;;;
;;; (1) 基本機能の実装
;;;
;;; Copyright (C) 2009-2021 Makoto Hiroi
;;;
;;; 関数宣言
(declaim (ftype (function (t list) t) m-eval))
;;; 大域変数
(defvar *global-environment*)
;;; 変数束縛
(defun add-binding (vars vals env)
(cond ((null vars) env)
((symbolp vars)
(cons (cons vars vals) env))
(t
(cons (cons (car vars) (car vals))
(add-binding (cdr vars) (cdr vals) env)))))
;;; 変数の値を取得
(defun lookup (var env)
(let ((value (assoc var env)))
(if value
value
(assoc var *global-environment*))))
;;;
;;; syntax
;;;
;;; (quote x)
(defun m-quote (expr env)
(declare (ignore env))
(cadr expr))
(defun true-p (x) (not (eq x 'false)))
;;; (if test then eles)
(defun m-if (expr env)
(if (true-p (m-eval (cadr expr) env))
(m-eval (caddr expr) env)
(if (null (cdddr expr))
'*undef*
(m-eval (cadddr expr) env))))
;;; (lambda (args ...) body ...)
(defun m-lambda (expr env)
(list 'closure expr env))
;;; (define name s-expr)
(defun m-define (expr env)
(setf *global-environment*
(cons (cons (cadr expr)
(m-eval (caddr expr) env))
*global-environment*))
(cadr expr))
;;;
;;; 関数適用
;;;
;;; 関数値 : (tag ...)
;;; tag
;;; syntax : シンタックス形式 (syntax m-xxx)
;;; primitive : プリミティブ (primitive #<subr ...>)
;;; closure : クロージャ (closure (lambda (args ...) body ...) env)
;;; body の評価
(defun eval-body (body env)
(cond ((null (cdr body))
(m-eval (car body) env))
(t
(m-eval (car body) env)
(eval-body (cdr body) env))))
;;; apply
(defun m-apply (procedure actuals)
(case (car procedure)
((primitive)
(apply (cadr procedure) actuals))
((closure)
(let ((expr (cadr procedure)))
(eval-body (cddr expr)
(add-binding (cadr expr) actuals (caddr procedure)))))
(t
(error "unknown procedure type -- m-apply ~S" procedure))))
;;;
;;; S 式の評価
;;;
;;; 自己評価フォームか
(defun self-evaluationp (expr)
(and (not (consp expr)) (not (symbolp expr))))
;;; eval
(defun m-eval (expr env)
(cond ((self-evaluationp expr) expr)
((symbolp expr)
(let ((cell (lookup expr env)))
(if cell
(cdr cell)
(error "unbound variable ~S" expr))))
((consp expr)
(let ((procedure (m-eval (car expr) env)))
(case (car procedure)
((syntax) (funcall (cadr procedure) expr env))
(t
(m-apply procedure
(mapcar (lambda (x) (m-eval x env)) (cdr expr)))))))
(t
(error "unknown expression type -- m-eval ~S" expr))))
;;; 初期化
(setf *global-environment*
(list
(cons 'true 'true)
(cons 'false 'false)
(cons 'nil 'nil)
(cons 'quit 'quit)
(list 'car 'primitive (lambda (x)
(if (null x)
(error "type error -- car NIL")
(car x))))
(list 'cdr 'primitive (lambda (x)
(if (null x)
(error "type error -- cdr NIL")
(cdr x))))
(list 'cons 'primitive #'cons)
(list 'eq? 'primitive (lambda (x y) (if (eq x y) 'true 'false)))
(list 'pair? 'primitive (lambda (x) (if (consp x) 'true 'false)))
(list 'if 'syntax #'m-if)
(list 'quote 'syntax #'m-quote)
(list 'lambda 'syntax #'m-lambda)
(list 'define 'syntax #'m-define)
))
;;; read-eval-print-loop
(defun repl (&rest file-list)
(dolist (file file-list)
(with-open-file (in file :direction :input)
(do ((output t))
((eq output nil) (terpri))
(setf output (m-eval (read in nil) '()))
(print output))))
;;
(do ((output nil))
((eq output 'quit))
(princ ">>> ")
(force-output)
(handler-case
(progn
(setf output (m-eval (read) '()))
(princ output)
(terpri))
(simple-error (c) (format t "ERROR: ~a~%" c)))))