今回は Common Lisp で小さな Lisp インタプリタ "micro Lisp" を作ってみましょう。
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 つの基本関数とラムダ式だけでプログラムを作るのは大変です。そこで、特殊形式として quote, cond, define を追加することにします。LISP - Wikipedia によると、これを『最小の Lisp』 というそうです。
今回は最小の Lisp にならって、次に示す関数を持つ小さな Lisp 処理系を作ることにします。
| 基本関数 | 特殊形式 |
|---|---|
|
|
データは Common Lisp のデータをそのまま使います。このようにすると、プログラムの読み込みは関数 read で、データの出力も print などで行うことができます。真偽値も Common Lisp と同じく T と NIL で表すことにします。具体的には、偽を NIL で表して、それ以外のデータを真と判断します。
大域変数の値と関数定義はシンボルの属性リストに格納することにします。変数値は属性名 VALUE に、関数値は属性名 FUNC にセットします。micro Lisp では、lambda と defun を特殊形式として定義します。ラムダ式 (lambda (args ...) body ...) はクロージャを生成します。(defun name (args ...) body ...) はクロージャを生成して、それをシンボル name の属性リストに登録します。
特殊形式 setq は変数の値を書き換えます。それから、高階関数を扱うために、特殊形式 function と基本関数 apply, funcall を用意します。簡単な計算ができると面白いので、四則演算と比較演算子も用意しておきます。あとは読み込んだ S 式を評価する処理を作ればいいわけです。
micro Lisp インタプリタの主役は関数 m-eval と m-apply です。この 2 つの関数は Lisp / Scheme の関数 eval と apply に相当します。m- は micro- を省略したものです。m-eval は評価する S 式と環境 (environment) を受け取り、渡された環境の下で S 式を評価します。環境はアクセス可能な局所変数の集合のことで、今回は連想リストで表すことにします。
m-eval は S 式のデータ型によって処理を振り分けます。S 式がシンボルであれば環境から変数値を求めて返します。リストであれば関数を呼び出します。先頭の要素がシンボルならば、属性リストから FUNC (関数値) を取り出して評価します。ラムダ式であればクロージャを生成して評価します。それ以外のデータ型は自己評価フォームとして扱うことにします。
今回の micro Lisp では関数値を構造体で表します。次のリストを見てください。
リスト : 関数値の定義 (defstruct primitive func) (defstruct syntax func) (defstruct closure args body env)
SYNTAX は特殊形式を表します。スロット FUNC にその処理を担当する関数を格納しておきます。m-eval は引数を評価しないで、処理を担当する関数にそのまま渡します。このとき、環境も必要になるのでいっしょに渡します。
PRIMITIVE は Common Lisp の関数を呼び出します。スロット FUNC に呼び出す関数値をセットします。CLOSURE はクロージャを表します。スロット ARGS にラムダリスト、BODY に関数の本体、ENV にはクロージャを生成したときの環境をセットします。PRIMITIVE と CLOUSRE の評価は m-apply で行います。
プログラムは次のようになります。
リスト : S 式の評価
(defun m-eval (expr env)
(cond
((symbolp expr)
(lookup-variable expr env))
((consp expr)
(let ((proc (lookup-function (car expr) env)))
(if (syntax-p proc)
(apply (syntax-func proc) env (cdr expr))
(m-apply proc (mapcar (lambda (e) (m-eval e env)) (cdr expr))))))
(t expr)))
m-eval の引数 EXPR が評価する S 式、ENV が環境です。EXPR がシンボルの場合は環境 ENV から変数を探します。この処理を関数 lookup-variable で行います。EXPR がリストの場合、先頭要素から関数値を求めて変数 PROC にセットします。この処理を関数 lookup-function で行います。
PROC が SYNTAX であれば、スロット FUNC の関数を呼び出します。このとき、引数として ENV と (cdr expr) をそのまま渡します。そうでなければ、PROC を m-apply に渡して評価します。このとき、PROC に渡す引数 (cdr expr) を m-eval で評価し、その結果をリストに格納して渡します。この処理は mapcar を使うと簡単です。
EXPR がシンボルでもリストでもない場合、自己評価フォームなので EXPR をそのまま返します。
変数値の取得は関数 lookup-variable で行います。次のリストを見てください。
リスト : 変数値の取得
(defun lookup-variable (var env)
(let ((xs (assoc var env)))
(if xs
(cdr xs)
;; 属性リストをチェック
(let ((ys (get var 'value 'undef)))
(if (not (eq ys 'undef))
ys
(error "The variable ~a is unbound." var))))))
引数 ENV (環境) は連想リストなので、assoc で ENV から引数 VAR (シンボル) を探索するだけです。見つからない場合は VAR の属性リストから VALUE を求めます。シンボル NIL の値も lookup-variable で求めるので、見つからない場合は UNDEF を返すようにしています。UNDEF の場合はエラーを通知します。
次は関数値を求める lookup-function です。
リスト : 関数値を求める
(defun lookup-function (expr env)
(cond
((symbolp expr)
(let ((fn (get expr 'func)))
(if fn
fn
(error "The function ~a is undefined." expr))))
((and (consp expr)
(eq (car expr) 'lambda))
(make-closure :args (second expr) :body (cddr expr) :env env))
(t
(error "Illegal function call ~a" expr))))
引数 EXPR がシンボルの場合、属性リストから FUNC を求めて変数 FN にセットします。FN が NIL でなければ、FN をそのまま返します。NIL の場合、関数は未定義なのでエラーを通知します。EXPR がリストで先頭要素が LAMBDA の場合、EXPR はラムダ式です。関数 make-closure で構造体 CLOSURE を生成して返します。クロージャを生成するときは、スロット ENV に環境 (引数 ENV) をセットすることをお忘れなく。それ以外の場合はエラーを通知します。
次は関数 m-apply を作りましょう。
リスト : 関数適用
;;; 関数本体の評価
(defun eval-body (xs env)
(cond
((null (cdr xs))
;; 最後の S 式の評価値を返す
(m-eval (car xs) env))
(t
(m-eval (car xs) env)
(eval-body (cdr xs) env))))
;;; 関数適用
(defun m-apply (proc args)
(cond
((primitive-p proc)
(handler-case
(apply (primitive-func proc) args)
(error (c) (error (format nil "~a" c)))))
((closure-p proc)
;; 本体の評価
(eval-body (closure-body proc)
(add-binding (closure-args proc) args (closure-env proc))))
(t
(error "Illegal function call ~a" proc))))
m-apply の引数 PROC は micro Lisp の関数値、ARGS は引数を格納したリストです。引数は評価済みであることに注意してください。PROC が PRIMITIVE の場合、スロット FUNC の関数を apply で呼び出します。関数の実行でエラー (error 型) を捕捉した場合、関数 error でエラー (simple-error 型) を再通知します。このとき、error には捕捉したエラーのメッセージを渡します。simple-error は REPL (Read - Eval - Print - Loop) で捕捉します。
PROC が CLOSURE の場合、スロット ARGS にラムダリスト、BODY に関数本体、ENV に環境が格納されています。関数本体を評価する前に、関数 add-binding で変数束縛を行います。このとき、ラムダ式を生成したときの環境が使われることに注意してください。
micro Lisp のラムダ式はクロージャになるので、ラムダ式を定義したときの環境が必ず保存されています。ラムダ式の本体はこの新しい環境で評価されます。この処理を関数 eval-body で行います。引数 XS は S 式を格納したリスト、ENV が環境です。eval-body は複数の S 式を順番に m-eval で評価して、最後に評価した S 式の結果を返します。
次は変数束縛を行う関数 add-binding を作ります。
リスト : 変数束縛
(defun add-binding (vars args env)
(cond
((and (null vars) (null args)) env)
((or (null vars) (null args))
(error "Invalid number of arguments"))
((not (symbolp (car vars)))
(error "Required argument is not a symbol ~a" (car vars)))
(t
(cons (cons (car vars) (car args))
(add-binding (cdr vars) (cdr args) env)))))
add-binding は仮引数のシンボルと実引数の値を組にして環境 env に追加します。仮引数のリスト vars と実引数のリスト args が空リストの場合は env を返します。どちらかが空リストであれば、仮引数と実引数の個数が合わないのでエラーを通知します。また、vars の要素がシンボルでなければ、仮引数の条件を満たしていないのでエラーを通知します。それ以外の場合は vars の先頭要素と vals の先頭要素を組にします。
次は特殊形式を処理する関数を作りましょう。次のリストを見てください。
リスト : 特殊形式の処理
;;; (quote xs)
(defun m-quote (env args)
(declare (ignore env))
args)
;;; (if test then else)
(defun m-if (env test then &rest else)
(if (m-eval test env)
(m-eval then env)
(when else
(m-eval (car else) env))))
;;; (lambda args body ...)
(defun m-lambda (env args &rest body)
(make-closure :args args :body body :env env))
;;; (defun name args body ...)
(defun m-defun (env name args &rest body)
(setf (get name 'func)
(apply #'m-lambda env args body))
;; シンボルを返す
name)
;;; (function expr)
(defun m-function (env expr)
(lookup-function expr env))
特殊形式を処理する関数は第 1 引数が環境 ENV で、それ以降の仮引数に実引数が渡されます。quote の処理は関数 m-quote で行います。引数 ARGS には (quote x) の X が渡されるので、args をそのまま返すだけです。if の処理は関数 m-if で行います。最初に引数 TEST を m-eval で評価し、それが NIL でなければ引数 THEN を m-eval で評価して、その結果を返します。偽の場合は引数 ELSE に S 式があるかチェックし、あればそれを m-eval で評価します。
ラムダ式の処理は関数 m-lambda で行います。構造体 CLOSURE を生成するとき、スロット ENV に引数 ENV をセットします。defun の処理は関数 m-defun で行います。m-lambda でクロージャを生成し、それを name の属性リスト FUNC にセットします。function の処理は関数 m-function で行います。これは関数 lookup-function を呼び出すだけです。
setq の処理は関数 m-setq で行います。次のリストを見てください。
リスト : setq の処理
;;; 変数値の更新
(defun update-variable (var val env)
(let ((xs (assoc var env)))
(if xs
(rplacd xs val)
;; 大域変数を書き換える
(setf (get var 'value) val))))
;;; (setq name expr)
(defun m-setq (env name expr)
(cond
((not (symbolp name))
(error "Required argument is not a symbol ~a" name))
((or (eq name t) (eq name nil))
(error "~a is a constant." name)))
(let ((value (m-eval expr env)))
(update-variable name value env)
value))
最初に、引数 NAME がシンボルで、それが T と NIL でないことを確認します。次に、引数 EXPR を m-eval で評価して、結果を変数 VALUE にセットします。実際の更新処理は関数 update-variable で行います。最後に VALUE を返します。
update-variable は簡単です。引数 ENV から引数 VAR を assoc で検索します。見つけた場合、その CDR 部を replacd で引数 VAL に破壊的に修正します。見つからない場合は、VAR の属性リスト VALUE に VAL をセットします。
次は、属性リストを初期化する関数 init-lisp を作ります。
リスト : micro Lisp の初期化
;;; プリミティブ用 apply
(defun p-apply (proc args)
(m-apply
;; シンボルでも受け付ける
(if (symbolp proc)
(lookup-function proc nil)
proc)
args))
;;; 初期化
(defun init-lisp ()
(setf (get 'nil 'value) nil)
(setf (get 't 'value) t)
(dolist (sym '(car cdr cons eq atom + - * / mod = /= < > <= >=))
(setf (get sym 'func)
(make-primitive :func (symbol-function sym))))
(setf (get 'apply 'func)
(make-primitive
:func
#'(lambda (proc args) (p-apply proc args))))
(setf (get 'funcall 'func)
(make-primitive
:func
#'(lambda (proc &rest args) (p-apply proc args))))
(setf (get 'quote 'func)
(make-syntax :func #'m-quote))
(setf (get 'if 'func)
(make-syntax :func #'m-if))
(setf (get 'lambda 'func)
(make-syntax :func #'m-lambda))
(setf (get 'function 'func)
(make-syntax :func #'m-function))
(setf (get 'setq 'func)
(make-syntax :func #'m-setq))
(setf (get 'defun 'func)
(make-syntax :func #'m-defun)))
NIL と T は属性リスト VALUE に自分自身をセットするだけです。基本関数は関数 make-primitive で構造体 PRIMITIVE を生成し、それを属性リスト FUNC にセットします。Common Lisp の場合、シンボルに格納されている関数値は関数 symbol-function で取り出すことができます。
symbol-function symbol
引数 symbol は評価されることに注意してください。簡単な使用例を示しましょう。
* (symbol-function 'car) #<FUNCTION CAR> * (symbol-function 'cdr) #<FUNCTION CDR> * (symbol-function 'cons) #<FUNCTION CONS>
apply と funcall は PRIMITIVE にラムダ式をセットします。その中で関数 p-apply を呼び出すだけです。関数 p-apply は引数 PROC がシンボルならば、その関数値を取り出して m-apply に渡します。これで、クォートされたシンボルを funcall や apply に渡すことができます。
なお、Common Lisp と違って、apply の引数は PROC (関数値) と ARGS (引数を格納したリスト) の 2 つだけです。funcall は実引数を可変個引数で受け取ります。特殊形式は関数 make-syntax で構造体 SYNTAX を生成し、それを属性リスト FUNC にセットするだけです。
最後に REPL を作ります。
リスト : REPL (read - eval - print - loop)
;;; プロンプトの表示
(defun prompt ()
(format t ">>> ")
(force-output))
;;; REPL
(defun repl (&rest file-list)
(init-lisp)
(dolist (file file-list)
(with-open-file
(in file :direction :input)
(loop with output
while (setq output (m-eval (read in nil) nil))
do (print output)
finally (terpri))))
(loop
(handler-case
(progn
(prompt)
(format t "~a~%" (m-eval (read) nil)))
(simple-error (c)
(format t "ERROR: ~a~%" c)))))
REPL を実行する前に、プログラムをロードできると便利です。関数 repl の引数 FILE-LIST でファイル名を指定して、そのファイルを読み込みます。read で S 式を読み込み、それを m-eval で評価します。このとき、環境は空リストを渡します。それから REPL を実行します。REPL を終了するには CTRL-C または CTRL-D を入力してください。
それでは実行してみましょう。
>>> (quote a) A >>> 'a A >>> (if t 'a 'b) A >>> (if nil 'a 'b) B >>> (car '(a b c)) A >>> (cdr '(a b c)) (B C) |
>>> (cons 'a 'b) (A . B) >>> (eq 'a 'a) T >>> (eq 'a 'b) NIL >>> (atom '(a b c)) NIL >>> (atom 'a) T |
quote, if, car, cdr, cons, eq, atom は正常に動作していますね。次は setq, lambda, defun を試してみます。
>>> (setq a 'b) A >>> a B >>> (lambda (x) x) #S(CLOSURE :ARGS (X) :BODY (X) :ENV NIL) >>> ((lambda (x) x) 'a) A >>> (defun square (x) (* x x)) SQUARE >>> (square 1234) 1522756
setq で変数 A に値を代入して、その値を求めることができます。ラムダ式はクロージャを生成します。ラムダ式で関数呼び出しも可能です。そして、defun を使って関数を定義することができます。
次は、レキシカルスコープとクロージャが正常に動作するか試してみましょう。
>>> (setq x 'a) A >>> x A >>> (defun foo () x) FOO >>> (foo) A >>> (defun bar (x) (foo)) BAR >>> (bar 'b) A
まず最初に、大域変数 X を A に初期化します。次に、関数 foo を定義します。foo の引数はないので、X は大域変数を参照します。したがって、foo を評価すると返り値は A になります。次に、関数 bar から foo を呼び出します。bar は引数 X を受け取ります。(bar 'b) を評価すると A が返ってきます。確かにレキシカルスコープになっています。
foo と bar の関数値を表示すると次のようになります。
>>> #'foo #S(CLOSURE :ARGS NIL :BODY (X) :ENV NIL) >>> #'bar #S(CLOSURE :ARGS (X) :BODY ((FOO)) :ENV NIL)
どちらの関数も環境 ENV が空リストになっています。(bar 'b) を評価するとき、この環境に (X . B) が追加されます。そして、(foo) を呼び出しますが、foo に引数はないので、環境は空リストのままです。したがって、(foo) の返り値は大域変数の値 A になるのです。
今度はクロージャの動作を確かめます。
>>> (defun baz (x) (lambda (y) (cons x y))) BAZ >>> (setq baz-a (baz 'a)) #S(CLOSURE :ARGS (Y) :BODY ((CONS X Y)) :ENV ((X . A))) >>> (funcall baz-a 'b) (A . B) >>> (funcall 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 #S(CLOSURE :ARGS (X) :BODY ((LAMBDA (Y) (CONS X Y))) :ENV NIL) >>> baz-a #S(CLOSURE :ARGS (Y) :BODY ((CONS X Y)) :ENV ((X . A)))
baz の環境は空リストですが、baz-a の環境は ((X . A)) となります。(baz-a 'b) を評価するとき、クロージャの環境に (Y . B) が追加され、その下で (cons x y) が評価されます。したがって、X の値は A で Y の値が B になるのです。
defun で定義する関数は再帰呼び出しが可能です。micro Lisp には dotimes などの繰り返しがありません。単純な繰り返しでも再帰定義でプログラムする必要があります。簡単なプログラムと実行結果を示します。
リスト : 再帰定義の例題
;;; 空リストか
(defun null (x) (eq x nil))
;;; 否定
(defun not (x) (if (eq x nil) t nil))
;;; リストの結合
(defun append (xs ys)
(if (null xs)
ys
(cons (car xs) (append (cdr xs) ys))))
;;; リストの反転
(defun reverse (xs)
(if (null xs)
nil
(append (reverse (cdr xs)) (cons (car xs) nil))))
;;; リストの探索
(defun member (x xs)
(if (null xs)
nil
(if (eql x (car xs))
xs
(member x (cdr xs)))))
;;; 連想リストの探索
(defun assoc (x xs)
(if (null xs)
nil
(if (eql x (car (car xs)))
(car xs)
(assoc x (cdr xs)))))
;;; マッピング
(defun mapcar (fn xs)
(if (null xs)
nil
(cons (funcall fn (car xs)) (mapcar fn (cdr xs)))))
;;; フィルター
(defun filter (fn xs)
(if (null xs)
nil
(if (funcall fn (car xs))
(cons (car xs) (filter fn (cdr xs)))
(filter fn (cdr xs)))))
;;; 畳み込み
(defun fold-right (fn a xs)
(if (null xs)
a
(funcall fn (car xs) (fold-right fn a (cdr xs)))))
(defun fold-left (fn a xs)
(if (null xs)
a
(fold-left fn (funcall fn a (car xs)) (cdr xs))))
;;; 階乗
(defun fact (n)
(if (= n 0)
1
(* n (fact (- n 1)))))
;;; フィボナッチ数
(defun fibo (n)
(if (< n 2)
n
(+ (fibo (- n 1)) (fibo (- n 2)))))
>>> (append '(a b c) '(d e f)) (A B C D E F) >>> (append '(a b c) nil) (A B C) >>> (append nil '(d e f)) (D E F) >>> (reverse '(a b c d e)) (E D C B A) >>> (reverse '(a)) (A) >>> (reverse nil) NIL >>> (member 'a '(a b c d e)) (A B C D E) >>> (member 'e '(a b c d e)) (E) >>> (member 'f '(a b c d e)) NIL >>> (assoc 'a '((a . 1) (b . 2) (c . 3))) (A . 1) >>> (assoc 'c '((a . 1) (b . 2) (c . 3))) (C . 3) >>> (assoc 'd '((a . 1) (b . 2) (c . 3))) NIL >>> (mapcar #'car '((a b c) (d e f) (g h i))) (A D G) >>> (mapcar #'cdr '((a b c) (d e f) (g h i))) ((B C) (E F) (H I)) >>> (mapcar (lambda (x) (* x x)) '(1 2 3 4 5)) (1 4 9 16 25) >>> (filter (lambda (x) (not (eq x 'a))) '(a b c a b c d)) (B C B C D) >>> (filter (lambda (x) (= (mod x 2) 0)) '(1 2 3 4 5 6 7)) (2 4 6) >>> (filter (lambda (x) (/= (mod x 2) 0)) '(1 2 3 4 5 6 7)) (1 3 5 7) >>> (fold-left #'+ 0 '(1 2 3 4 5 6 7 8)) 36 >>> (fold-right #'+ 0 '(1 2 3 4 5 6 7 8)) 36 >>> (fold-left (lambda (x y) (cons y x)) nil '(1 2 3 4 5 6 7 8)) (8 7 6 5 4 3 2 1) >>> (fold-right #'cons nil '(1 2 3 4 5 6 7 8)) (1 2 3 4 5 6 7 8) >>> (fact 9) 362880 >>> (fact 10) 3628800 >>> (fact 20) 2432902008176640000 >>> (fibo 10) 55 >>> (fibo 20) 6765 >>> (fibo 30) 832040
関数 fibo は二重再帰なので、実行時間がかかることに注意してください。興味のある方は実際にプログラムを動かして、いろいろ試してみてください。
;;;
;;; micro.lisp : micor Lisp インタプリタ
;;;
;;; Copyright (C) 2020 Makoto Hiroi
;;;
;;; 真偽値 t nil
;;; 基本関数 car cdr cons eq eql atom apply funcall
;;; 特殊形式 quote if lambda defun function setq
;;; 数値演算 + - * / mod = /= < > <= >=
;;; 関数宣言
(declaim (ftype (function (t list) t) m-eval))
;;; 関数型
(defstruct primitive func)
(defstruct syntax func)
(defstruct closure args body env)
;;; 変数値を求める
(defun lookup-variable (var env)
(let ((xs (assoc var env)))
(if xs
(cdr xs)
;; 属性リストをチェック
(let ((ys (get var 'value 'undef)))
(if (not (eq ys 'undef))
ys
(error "The variable ~a is unbound." var))))))
;;; 変数値の更新
(defun update-variable (var val env)
(let ((xs (assoc var env)))
(if xs
(rplacd xs val)
;; 大域変数を書き換える
(setf (get var 'value) val))))
;;; 関数値を求める
(defun lookup-function (expr env)
(cond
((symbolp expr)
(let ((fn (get expr 'func)))
(if fn
fn
(error "The function ~a is undefined." expr))))
((and (consp expr)
(eq (car expr) 'lambda))
(make-closure :args (second expr) :body (cddr expr) :env env))
(t
(error "Illegal function call ~a" expr))))
;;:
;;; 特殊形式
;;;
;;; (quote xs) => xs
(defun m-quote (env args)
(declare (ignore env))
args)
;;; (if test then else)
(defun m-if (env test then &rest else)
(if (m-eval test env)
(m-eval then env)
(when else
(m-eval (car else) env))))
;;; (lambda (args ...) body ...)
(defun m-lambda (env args &rest body)
(make-closure :args args :body body :env env))
;;; (defun name (args ...) body ...)
(defun m-defun (env name args &rest body)
(setf (get name 'func)
(apply #'m-lambda env args body))
;; シンボルを返す
name)
;;; (function expr) => func
(defun m-function (env expr)
(lookup-function expr env))
;;; (setq name expr)
(defun m-setq (env name expr)
(cond
((not (symbolp name))
(error "Required argument is not a symbol ~a" name))
((or (eq name t) (eq name nil))
(error "~a is a constant." name)))
(let ((value (m-eval expr env)))
(update-variable name value env)
value))
;;; 変数束縛
(defun add-binding (vars args env)
(cond
((and (null vars) (null args)) env)
((or (null vars) (null args))
(error "Invalid number of arguments"))
((not (symbolp (car vars)))
(error "Required argument is not a symbol ~a" (car vars)))
(t
(cons (cons (car vars) (car args))
(add-binding (cdr vars) (cdr args) env)))))
;;; 関数本体の評価
(defun eval-body (xs env)
(cond
((null (cdr xs))
;; 最後の S 式の評価値を返す
(m-eval (car xs) env))
(t
(m-eval (car xs) env)
(eval-body (cdr xs) env))))
;;; 関数適用
(defun m-apply (proc args)
(cond
((primitive-p proc)
(handler-case
(apply (primitive-func proc) args)
(error (c) (error (format nil "~a" c)))))
((closure-p proc)
;; body の評価
(eval-body (closure-body proc)
(add-binding (closure-args proc) args (closure-env proc))))
(t
(error "Illegal function call ~a" proc))))
;;; 評価
(defun m-eval (expr env)
(cond
((symbolp expr)
(lookup-variable expr env))
((consp expr)
(let ((proc (lookup-function (car expr) env)))
(if (syntax-p proc)
(apply (syntax-func proc) env (cdr expr))
(m-apply proc (mapcar (lambda (e) (m-eval e env)) (cdr expr))))))
(t expr)))
;;; プリミティブ用 apply
(defun p-apply (proc args)
(m-apply
;; シンボルでも受け付ける
(if (symbolp proc)
(lookup-function proc nil)
proc)
args))
;;; 初期化
(defun init-lisp ()
(setf (get 'nil 'value) nil)
(setf (get 't 'value) t)
(dolist (sym '(car cdr cons eq eql atom + - * / mod = /= < > <= >=))
(setf (get sym 'func)
(make-primitive :func (symbol-function sym))))
(setf (get 'apply 'func)
(make-primitive
:func
#'(lambda (proc args) (p-apply proc args))))
(setf (get 'funcall 'func)
(make-primitive
:func
#'(lambda (proc &rest args) (p-apply proc args))))
(setf (get 'quote 'func)
(make-syntax :func #'m-quote))
(setf (get 'if 'func)
(make-syntax :func #'m-if))
(setf (get 'lambda 'func)
(make-syntax :func #'m-lambda))
(setf (get 'function 'func)
(make-syntax :func #'m-function))
(setf (get 'setq 'func)
(make-syntax :func #'m-setq))
(setf (get 'defun 'func)
(make-syntax :func #'m-defun)))
;;; プロンプトの表示
(defun prompt ()
(format t ">>> ")
(force-output))
;;;
(defun repl (&rest file-list)
(init-lisp)
(dolist (file file-list)
(with-open-file
(in file :direction :input)
(loop with output
while (setq output (m-eval (read in nil) nil))
do (print output)
finally (terpri))))
(loop
(handler-case
(progn
(prompt)
(format t "~a~%" (m-eval (read) nil)))
(simple-error (c)
(format t "ERROR: ~a~%" c)))))