今回は micro Lisp インタプリタ のコンパイラバージョンを Common Lisp で作ってみましょう。一般に、コンパイラの作成はとても難しいと思われていますが、小さな Lisp 処理系のコンパイラであれば、それほど難しいことではありません。特に、仮想マシン上で動作する小さな Lisp 処理系の場合、思っているよりも簡単にコンパイラを作成することができます。今回は SECD マシンという仮想マシン上で動作するコードを生成し、そのコードを Common Lisp で実行することにします。
SECD マシンは 1963年 に Peter J. Landin 氏が設計した仮想マシンで、もともとは「ラムダ計算 (lambda calculus)」で用いられるラムダ式を評価するためのものです。ラムダ計算は文字λを使って関数を表す「λ記法」という表記法を用いた抽象的な計算モデルで、1930 年代に A. Church 氏によって考案されました。ラムダ計算は Lisp, Scheme, ML, Haskell など多くの関数型言語の基礎理論として、大きな役割を果たしています。
実際に SECD マシンをベースにした処理系には、1980 年に Peter Henderson 氏が作成した Lispkit Lisp があります。SECD マシンの実装については、Skelet 氏の SECD Mania が参考になります。実用的な処理系では、PalmOS で動作する LispMe (Scheme) があります。日本では、森脇淳氏と林祥一氏による SECDR-Scheme がとても参考になります。
SECD マシンは S, E, C, D という 4 つのレジスタ (変数) を持った仮想マシンです。
これらのレジスタはリストを保持します。スタックは値を一時的に保存するために使われます。たとえば、1 + 2 を計算する場合、数値 1 と 2 をスタックに追加します。次に、加算処理を行いますが、スタックから数値 1 と 2 を取り出して 1 + 2 を計算し、その値 3 をスタックに追加します。
このように、スタックを使って計算を行う機械を「スタックマシン (stack machine)」といいます。SECD 仮想マシンはスタックマシンの一種になります。スタックマシンをベースにしたプログラミング言語では Forth が有名です。また、Java の仮想マシンもスタックマシンをベースにしています。
実行する仮想マシンの命令は C レジスタのリストに格納されていて、それを先頭から順番に取り出して、その命令を実行します。局所変数の値は E レジスタのリストから求めます。D レジスタは条件分岐と関数呼び出しを行うとき、その後の処理を継続するため S, E. C レジスタの値を保存するために使用します。
今回作成する SECD 仮想マシンの命令と機能概要を下表に示します。
| 命令 | 機能概要 |
|---|---|
| ld (i . j) | E レジスタの i 番目のフレームの j 番目の要素をスタックに積む |
| ldc const | 定数 const をスタックに積む |
| ldg sym | 大域変数 sym の値をスタックに積む |
| ldgf sym | 大域変数 sym の関数値をスタックに積む |
| ldf code | code からクロージャを生成してスタックに積む |
| args n | スタックから n 個の値を取り出してリストに格納し、そのリストをスタックに積む |
| args-ap n | 関数 apply 専用の args 命令 |
| app | スタックに積まれているクロージャと引数リストを取り出して関数呼び出しを行う |
| rtn | 関数呼び出しから戻る |
| sel ct cf | スタックトップの値が真ならば ct を実行する。偽ならば cf を実行する |
| join | 条件分岐から合流する |
| lset (i . j) | E レジスタの i 番目のフレームの j 番目の要素をスタックトップの値に書き換える |
| gset sym | 大域変数 sym の値をスタックトップの値に書き換える |
| pop | スタックトップの値を取り除く |
| def sym | スタックトップの値を大域変数 sym の関数値にセットする |
| stop | 仮想マシンの実行を停止する |
これらの命令は Henderson の SECD マシンを参考にしていますが、まったく同じではありません。micro Lisp の仕様にあわせて、新しい命令を追加したり不要な命令を削除しています。命令の動作は 4 つのレジスタ (S, E, C, D) の状態遷移で表すことができます。ここで、各命令の動作について詳しく説明することにしましょう。各レジスタの値はドットリストで表すことにします。
ld はレジスタ E から局所変数の値 v を求めてスタックに積む命令です。
s e (ld (i . j) . c) d => (v . s) e c d v = (nth j (nth i e))
ld の次の命令はドットペア (i . j) で、局所変数の位置を i と j で表しています。micro Lisp の場合、局所変数はラムダ式で定義されます。局所変数はラムダ式ごとにリストにまとめて環境にセットします。これをフレームといいます。i がフレームの位置、j がフレームの中の変数の位置を表します。
簡単な例を示しましょう。次の図を見てください。
(1) ((lambda (a b) ...) 1 2)
E: ((1 2))
(2) ((lambda (a b c) ((lambda (d e) ...) 4 5)) 1 2 3)
E: ((4 5) (1 2 3))
(1) の場合、フレームは一つしかありません。変数 a の位置は (0 . 0) で値は 1 になり、b の位置は (0 . 1) で値は 2 になります。(2) の場合、フレームは 2 つあります。この場合、各変数の位置と値は次のようになります。
a : (1 . 0), 値 = 1 b : (1 . 1), 値 = 2 c : (1 . 2), 値 = 3 d : (0 . 0), 値 = 4 e : (0 . 1), 値 = 5
局所変数の位置はコンパイルの時に求めます。
ldc は定数 const をスタックに、ldg はシンボル sym の値をスタックに、ldgf はシンボル sym の関数値をスタックに積む命令です。
s e (ldc const . c) d => (const . s) e c d
s e (ldg sym . c) d => (v . s) e c d v = (get-gvar sym)
s e (ldgf sym . c) d => (v . s) e c d v = (get-func sym)
micro Lisp の場合、自己評価フォームまたはクオート (quote) の引数を定数として扱います。シンボル sym の値は関数 get-gvar で、関数値は get-func で求めます。
ldf はクロージャを生成して、それをスタックに積む命令です。
s e (ldf code . c) d => (#S(CLOSURE :CODE code :ENV e) . s) e c d
具体的に説明すると、ldf はラムダ式 (lambda (a ...) body ...) を処理する命令です。ldf の次の命令 code は、ラムダ式の本体 (body ...) をコンパイルしたものです。それと環境 e を構造体 CLOSURE に格納してスタックに積みます。
args はスタックから n 個の値を取り出してリストに格納して、それをスタックに積む命令です。
(v1 ... vn . s) e (args n . c) d => (vs . s) e c d vs = (list v1 ... vn)
関数を呼び出すとき引数を評価しますが、その返り値はスタックに格納されます。たとえば、n 個の引数がある場合、スタックには v1 から vn までの値が格納されています。それをスタックから取り出してリスト vs に格納し、それをスタックに積むのが args の役目です。このあと、関数 (CLOSURE または PRIMITIVE) をスタックに積み、app という命令で関数を呼び出します。
args-ap は関数 apply 専用の命令です。これはあとで説明します。
app はスタックに積まれた関数と引数のリストを取り出して、その関数を呼び出す命令です。
(#S(CLOSURE :CODE code :ENV env) vs . s) e (app . c) d => () (vs . env) code ((s e c) . d)
(#S(PRIMITIVE :FUNC #<func>) vs . s) e (app . c) d => (v . s) e c d v = (apply #<func> vs)
関数がクロージャ (CLOSURE) の場合、クロージャ内のコード code を環境 (vs . env) の元で実行します。env はクロージャに保存されている環境で、vs が関数の引数を格納したリストです。そして、呼び出し元の実行環境、つまり関数呼び出しから戻ってきた後に実行する処理をダンプに保存します。これは s, e, c を保存すれば OK です。
関数が PRIMITIVE の場合、#<func> は Common Lisp の関数なので、apply で関数を呼び出して、その返り値 v をスタックに追加するだけです。
rtn はクロージャの呼び出しから戻るための命令です。
(v . s) e (rtn . c) ((s' e' c') . d) => (v . s') e' c' d
クロージャの返り値 v はスタックに保存されています。それを取り出して、ダンプに保存されているスタック s' に追加します。そして、ダンプに保存されている環境 e' とコード c' を元に戻します。
sel と join は特殊形式 if を実現するための命令です。
(v . s) e (sel ct cf . c) d = v (真) => s e ct (c . d)
= v (偽) => s e cf (c . d)
s e (join . ()) (c . d) => s e c d
sel の次に then 節のコード ct があり、その次に else 節のコード cf があります。スタックトップの値 v が真 (not NIL) の場合は ct を実行します。偽 (NIL) の場合は cf を実行します。このとき、if のあとに実行する命令 c をダンプに保存します。app と違って s と e を保存する必要はありません。ct と cf の最後は必ず join 命令で終了します。join 命令はダンプに保存されている命令 c を取り出し、if のあとの命令を実行します。
lset と gset は特殊形式 setq を実現するための命令です。lset と gset の状態遷移を示します。
(v . s) e (lset (i . j) . c) d => (v . s) e c d 更新処理 : (setf (nth j (nth i e)) v)
(v . s) e (gset sym . c) d => (v . s) e c d 更新処理 : (setf (get sym 'value) v)
setq は変数に代入した値をそのまま返します。
pop はスタックトップの値を取り除く命令です。
(v . s) e (pop . c) d => s e c d
def は特殊形式 defun を実現するための命令です。
(v . s) e (def sym . c) d => (sym . s) e c d
def はスタックトップの値 v (クロージャ) をシンボル sym の関数値にセットします。
stop は仮想マシンの実行を停止する命令です。
(v . s) e (stop . c) d => 仮想マシン vm を停止して v を返す
仮想マシンを関数 vm とすると、vm は stop を実行するとスタックトップの値 v を返します。
それでは micro Lisp のコンパイラを作りましょう。コンパイラの構成はインタプリタとほとんど同じです。インタプリタは与えられた S 式をその場で評価しますが、コンパイラは S 式を仮想マシンの命令 (プログラム) に翻訳するだけです。そして、翻訳されたプログラムを仮想マシンで実行するわけです。
プログラムは次のようになります。
リスト : micro Lisp コンパイラ
;;; 自己評価フォームか
(defun self-evaluation-p (expr)
(and (atom expr) (not (symbolp expr))))
;;; ラムダ式か
(defun lambda-p (expr)
(and (consp expr) (eq (car expr) 'lambda)))
;;; コンパイル本体
(defun comp (expr env code)
(cond
((self-evaluation-p expr)
(list* 'ldc expr code))
((symbolp expr)
(let ((pos (location expr env)))
(if pos
(list* 'ld pos code) ; 局所変数
(list* 'ldg expr code)))) ; 大域変数
((symbolp (car expr))
(comp-func-sym expr env code))
((lambda-p (car expr))
(complis (cdr expr)
env
(list* 'args (length (cdr expr)) (comp (car expr) env (cons 'app code)))))
(t
(error "Illegal function call ~a" expr))))
;;; S 式をコンパイルする
(defun compile-expr (expr)
(comp expr '() '(stop)))
関数 compile-expr は S 式 EXPR をコンパイルして、その結果を返します。実際の処理は関数 comp で行います。引数 EXPR がコンパイルする S 式、ENV が局所変数の環境、CODE がコンパイルされたコードです。S 式の末尾からコンパイルしていくことに注意してください。
EXPR が自己評価フォームの場合、EXPR をそのままスタックに積みます。命令は (ldc expr) になります。それを code の先頭に追加します。関数 list* は list とよく似ていますが、複数の要素が与えられた場合はドットリストになります。簡単な実行例を示しましょう。
* (list* 1) 1 * (list* 1 2) (1 . 2) * (list* 1 2 '(3)) (1 2 3)
EXPR がシンボルの場合、関数 location で環境 ENV に EXPR があるか探索します。見つかった場合、location はフレームの位置と変数の位置を格納したドットペアを返します。EXPR は局所変数なので、生成するコードは (list* 'ld pos code) となります。見つからない場合は大域変数なので、コードは (list* 'ldg expr code) となります。
EXPR がリストで先頭要素がシンボルの場合、特殊形式または関数の呼び出しです。この処理を関数 comp-func-sym で行います。EXPR の先頭要素がラムダ式の場合、関数呼び出しのコードを生成します。関数 complis は引数を評価するコードを生成します。評価結果はスタックに積まれるので、args でスタックの値をリストに格納するコードが必要になります。そして、先頭要素 (car expr) を評価するコードを comp で生成し、それを app で関数呼び出しします。
関数 comp-func は次のようになります。
リスト : 特殊形式と関数呼び出しのコンパイル
(defun comp-func-sym (expr env code)
(case (car expr)
((quote)
(list* 'ldc (cadr expr) code))
((if)
(let ((t-clause (comp (caddr expr) env '(join)))
(f-clause
(if (null (cdddr expr))
(list 'ldc nil 'join)
(comp (cadddr expr) env '(join)))))
(comp (cadr expr) env (list* 'sel t-clause f-clause code))))
((lambda)
(let ((body (comp-body (cddr expr) (cons (cadr expr) env) '(rtn))))
(list* 'ldf body code)))
・・・略・・・
(t
;; シンボルの関数値を取得
(complis (cdr expr)
env
(list* 'args (length (cdr expr)) 'ldgf (car expr) 'app code)))))
引数 EXPR の先頭要素が QUOTE の場合、2 番目の要素を定数として扱います。コードは (list* 'ldc (cadr expr) code) になります。EXPR の先頭要素が IF の場合、最初に then 節と else 節をコンパイルします。このとき、最後の命令は必ず join に設定します。else 節がない場合は NIL を返すので、コードは (list* 'ldc nil 'join) になります。あとは、コード (list* 'sel t-clause f-clause code) を生成し、そこに test 節を評価するコードを追加します。これは (cadr expr) を comp でコンパイルするだけです。
先頭要素が LAMBDA の場合はクロージャを生成します。最初にラムダ式の本体を comp-body でコンパイルして、生成されたコードを BODY にセットします。このとき、ラムダ式の仮引数を環境 ENV に追加します。クロージャは関数呼び出しされるので、最後の命令は rtn になることに注意してください。あとは、コード (list* 'ldf body code) を生成するだけです。
最後の T 節は先頭要素のシンボルを関数として呼び出します。ラムダ式の呼び出しとは違って、先頭要素 (car expr) の関数値を取り出す命令 ldgf にコンパイルします。
次は function, apply, funcall のコンパイルです。micro Lisp コンパイラでは、apply と funcall も特殊形式として扱います。
リスト : function, apply, funcall のコンパイル
((function)
(cond
((symbolp (cadr expr))
(list* 'ldgf (cadr expr) code))
((lambda-p (cadr expr))
(comp (cadr expr) env code))
(t
(error "~a is not function name." (cadr expr)))))
((apply)
(complis (cddr expr)
env
(list* 'args-ap
(length (cddr expr))
(comp (cadr expr) env (cons 'app code)))))
((funcall)
(complis (cddr expr)
env
(list* 'args
(length (cddr expr))
(comp (cadr expr) env (cons 'app code)))))
EXPR の先頭要素が FUNCTION の場合、第 2 要素から関数値を取り出します。第 2 要素がシンボルであれば ldgf 命令に、ラムダ式であれば comp を呼び出してクロージャを生成する命令にコンパイルします。それ以外の場合はエラーを通知します。
先頭要素が APPLY の場合、第 2 要素を関数呼び出しする命令にコンパイルします。このとき、apply 専用の命令 args-ap を使うことに注意してください。FUNCALL の場合は単純に第 2 要素を関数呼び出しする命令にコンパイルします。
次は defun と setq のコンパイルです。
リスト : defun, setq のコンパイル
((defun)
(cond
((not (symbolp (cadr expr)))
(error "Required argument is not a symbol ~a" (cadr expr)))
((not (listp (caddr expr)))
(error "Required argument is not a list ~a" (caddr expr)))
(t
(comp (cons 'lambda (cddr expr)) env (list* 'def (cadr expr) code)))))
((setq)
(let ((name (cadr 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))
(t
(let ((pos (location name env)))
(if pos
;; 局所変数
(comp (caddr expr) env (list* 'lset pos code))
;; 大域変数
(comp (caddr expr) env (list* 'gset name code))))))))
EXPR の先頭要素が DEFUN の場合、第 2 要素 (シンボル) の属性リスト FUNC に関数値 (クロージャ) をセットします。最初に、第 2 要素がシンボルで、第 3 要素 (仮引数リスト) がリストであることをチェックします。次に、DEFUN と関数名を取り除いたリストに LAMBDA を追加して、クロージャを生成するコートにコンパイルします。そして、それを属性リストの関数値をセットする命令 def にコンパイルします。
EXPR の先頭要素が SETQ の場合、第 2 要素 (シンボル) が局所変数であれば lset 命令に、そうでなければ gset 命令にコンパイルします。最初に、第 2 要素 NAME がシンボルで、T と NIL でないことを確認します。そして、location で ENV から NAME を探索します。見つかったならば局所変数、そうでなければ大域変数になります。
引数を評価するコードを生成する関数 complis は簡単です。次のリストを見てください。
リスト : 引数を評価するコードを生成
(defun complis (expr env code)
(if (null expr)
code
(comp (car expr) env (complis (cdr expr) env code))))
コンパイルは後ろから行いますが、生成されるコードは引数を先頭から順番に評価していきます。そして、その結果はスタックに積まれます。
ラムダ式本体のコンパイルも簡単です。プログラムは次のようになります。
リスト : ラムダ式本体のコンパイル
(defun comp-body (body env code)
(if (null (cdr body))
(comp (car body) env code)
(comp (car body)
env
(list* 'pop
(comp-body (cdr body) env code)))))
ラムダ式の本体は複数の S 式を定義することができます。それを順番に評価していき、最後に評価した S 式の結果がラムダ式の返り値になります。各々の S 式は comp でコンパイルするだけですが、スタックに積まれた返り値を取り除くため、その後ろに命令 pop を追加します。最後尾の S 式をコンパイルするとき、その後ろに pop を追加する必要はありません。
局所変数の位置を求める関数 location は次のようになります。
リスト : 局所変数の位置を求める
(defun location (sym ls)
(do ((ls ls (cdr ls))
(i 0 (1+ i)))
((null ls))
(let ((j (position sym (car ls))))
(when j
(return (cons i j))))))
関数 location は position を呼び出して i 番目のフレームに変数 sym があるか調べます。見つけた場合は (i . j) を返します。見つからない場合は次のフレームを探します。全てのフレームを探しても見つからない場合は NIL を返します。
それでは、実際にコンパイルしてみましょう。自己評価フォームと quote は ldc 命令にコンパイルされます。
* (compile-expr 1) (LDC 1 STOP) * (compile-expr '(quote a)) (LDC A STOP)
if は sel と join 命令にコンパイルされます。
* (compile-expr '(if t a b)) (LDG T SEL (LDG A JOIN) (LDG B JOIN) STOP) * (compile-expr '(if t a)) (LDG T SEL (LDG A JOIN) (LDC NIL JOIN) STOP) * (compile-expr '(if nil a)) (LDG NIL SEL (LDG A JOIN) (LDC NIL JOIN) STOP)
ラムダ式は ldf に、局所変数のアクセスは ld にコンパイルされます。
* (compile-expr '(lambda (x) x)) (LDF (LD (0 . 0) RTN) STOP) * (compile-expr '(lambda () 1 2 3 4 5)) (LDF (LDC 1 POP LDC 2 POP LDC 3 POP LDC 4 POP LDC 5 RTN) STOP)
ラムダ式本体も正しくコンパイルされています。
関数呼び出しは args と app 命令にコンパイルされます。
* (compile-expr '(car '(a b c))) (LDC (A B C) ARGS 1 LDGF CAR APP STOP) * (compile-expr '((lambda (x) x) 'a)) (LDC A ARGS 1 LDF (LD (0 . 0) RTN) APP STOP) * (compile-expr '((lambda (x y) (cons x y)) 'a 'b)) (LDC A LDC B ARGS 2 LDF (LD (0 . 0) LD (0 . 1) ARGS 2 LDGF CONS APP RTN) APP STOP)
関数 car はシンボル CAR の関数値を ldgf で取り出して実行します。ラムダ式を呼び出す場合は、ldf でクロージャを生成してから、それを呼び出します。関数を呼び出す前に引数が評価されて、その結果がスタックに積まれることに注意してください。それを args 命令でリストに格納します。
defun は def 命令にコンパイルされます。setq は lset または gset 命令にコンパイルされます。
* (compile-expr '(defun foo (x y) (+ x y))) (LDF (LD (0 . 0) LD (0 . 1) ARGS 2 LDGF + APP RTN) DEF FOO STOP) * (compile-expr '(setq foo 123)) (LDC 123 GSET FOO STOP) * (compile-expr '(lambda (x) (setq x 100) x)) (LDF (LDC 100 LSET (0 . 0) POP LD (0 . 0) RTN) STOP) * (compile-expr '(lambda (x) (setq x (+ x 100)) x)) (LDF (LD (0 . 0) LDC 100 ARGS 2 LDGF + APP LSET (0 . 0) POP LD (0 . 0) RTN) STOP)
function 特殊形式は ldf または ldgf 命令に、apply と funcall は関数呼び出しにコンパイルされます。
* (compile-expr '(function car)) (LDGF CAR STOP) * (compile-expr '(function (lambda (x) x))) (LDF (LD (0 . 0) RTN) STOP) * (compile-expr '(funcall #'+ 1 2 3)) (LDC 1 LDC 2 LDC 3 ARGS 3 LDGF + APP STOP) * (compile-expr '(apply #'+ '(1 2 3))) (LDC (1 2 3) ARGS-AP 1 LDGF + APP STOP)
次は仮想マシンを作ります。プログラムは次のようになります。
リスト : 仮想マシン
(defun vm (s e c d)
(loop
(case (pop c)
((ld)
(let ((pos (pop c)))
(push (nth (cdr pos) (nth (car pos) e)) s)))
((ldc)
(push (pop c) s))
((ldg)
(push (get-gvar (pop c)) s))
((ldgf)
(push (get-func (pop c)) s))
((ldf)
(push (make-closure :code (pop c) :env e) s))
((app)
(let ((fn (pop s)) (lvar (pop s)))
(if (primitive-p fn)
(handler-case
(push (apply (primitive-func fn) lvar) s)
(error (c) (error (format nil "~a" c))))
(progn
(push (list s e c) d)
(setq s nil
e (cons lvar (closure-env fn))
c (closure-code fn))))))
((rtn)
(let ((save (pop d)))
(setq s (cons (car s) (car save))
e (cadr save)
c (caddr save))))
((sel)
(let ((t-clause (pop c))
(e-clause (pop c)))
(push c d)
(setq c (if (pop s) t-clause e-clause))))
((join)
(setq c (pop d)))
((pop) (pop s))
((args)
(let ((a nil))
(dotimes (n (pop c) (push a s))
(push (pop s) a))))
((args-ap)
(let ((a (pop s)))
(unless (listp a)
(error "Required argument is not a list ~a" a))
(dotimes (n (1- (pop c)) (push a s))
(push (pop s) a))))
((def)
(let ((sym (pop c)))
(setf (get sym 'func) (pop s))
(push sym s)))
((lset)
(let ((pos (pop c)))
(setf (nth (cdr pos) (nth (car pos) e)) (car s))))
((gset)
(setf (get (pop c) 'value) (car s)))
((stop) (return (car s)))
(t (error "unknown opcode")))))
仮想マシン (関数 vm) は SECD 仮想マシンの命令で説明した動作をそのままプログラムしただけです。args-ap 命令はまだ説明していないので、ここで簡単に説明しておきましょう。apply に与えられる最後の引数はリストです。args-ap は最後の引数を取り出して変数 A にセットします。そして、残りの引数を A の先頭に追加していき、最後に A をスタックに積みます。
最後に read - eval - print - loop (REPL) を作りましょう。次のリストを見てください。
リスト : read-eval-print-loop
;;; 初期化
(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)))))
;;; read-eval-print-loop
(defun repl (&rest file-list)
(init-lisp)
(dolist (file file-list)
(with-open-file (in file :direction :input)
(do ((output t))
((eq output nil) (terpri))
(setf output (vm '() '() (compile-expr (read in nil)) '()))
(print output))))
;;
(loop
(handler-case
(progn
(princ ">>> ")
(force-output)
(let* ((output (vm '() '() (compile-expr (read)) '())))
(format t "~a~%" output)))
(simple-error (c) (format t "ERROR: ~a~%" c)))))
REPL は拙作のページ Common Lisp で作る micro Lisp インタプリタ で作成したインタプリタとほぼ同じです。ただし、read で S 式を読み込んだあと、compile-expr で S 式をコンパイルしてから vm で実行します。
あとのプログラムは簡単なので説明は割愛いたします。詳細は プログラムリスト をお読みくださいませ。
それでは実行してみましょう。
>>> (quote a) A >>> 'a A >>> (if t 'a 'b) A >>> (if nil 'a 'b) B >>> (if nil 'a) NIL >>> (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) T >>> (atom '(a b c)) NIL
quote, if, car, cdr, cons, eq, atom は正常に動作していますね。次は setq, lambda, defun を試してみます。
>>> (setq a 'b) B >>> a B >>> (lambda (x) x) #S(CLOSURE :CODE (LD (0 . 0) RTN) :ENV NIL) >>> ((lambda (x) x) 'a) A >>> (defun add (x y) (+ x y)) ADD >>> (add 1 2) 3
setq で変数 A に値をセットして、その値を求めることができます。lambda はクロージャを生成し、ラムダ式で関数呼び出しも可能です。そして、defun を使って関数を定義することができます。
次は function, apply, funcall を試してみます。
>>> (function car) #S(PRIMITIVE :FUNC #<FUNCTION CAR>) >>> #'car #S(PRIMITIVE :FUNC #<FUNCTION CAR>) >>> #'(lambda (x) x) #S(CLOSURE :CODE (LD (0 . 0) RTN) :ENV NIL) >>> (funcall #'+ 1 2 3 4 5) 15 >>> (apply #'+ '(1 2 3 4 5)) 15 >>> (apply #'+ 1 2 '(3 4 5)) 15 >>> (setq a (lambda (x y) (+ x y))) #S(CLOSURE :CODE (LD (0 . 0) LD (0 . 1) ARGS 2 LDGF + APP RTN) :ENV NIL) >>> (funcall a 1 2) 3 >>> (apply a '(1 2)) 3
正常に動作していますね。
次は、レキシカルスコープとクロージャが正常に動作するか試してみましょう。
>>> (setq x 'a) 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 :CODE (LDG X RTN) :ENV NIL) >>> #'bar #S(CLOSURE :CODE (ARGS 0 LDGF FOO APP RTN) :ENV NIL)
どちらの関数も環境が空リストになっています。(bar 'b) を評価するとき、この環境に (X . B) が追加されます。そして、(foo) を呼び出しますが、foo に引数はないので、環境は空リストのままです。したがって、(foo) の返り値は大域変数の値 A になるのです。
今度はクロージャの動作を確かめます。
>>> (setq baz (lambda (x) (lambda (y) (cons x y))))
#S(CLOSURE
:CODE (LDF (LD (1 . 0) LD (0 . 0) ARGS 2 LDGF CONS APP RTN) RTN)
:ENV NIL)
>>> (setq baz-a (funcall baz 'a))
#S(CLOSURE
:CODE (LD (1 . 0) LD (0 . 0) ARGS 2 LDGF CONS APP RTN)
:ENV ((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 の関数値 (CLOSURE) を見てください。baz の環境は空リストですが、baz-a の環境は ((A)) となります。(baz-a 'b) を評価するとき、クロージャの環境に (B) が追加され ((B) (A)) になります。その下で (cons x y) が評価されるので、x の値は a で y の値が b になるのです。
defun で定義する関数は再帰呼び出しが可能です。micro Lisp には dotimes などの繰り返しがありません。単純な繰り返しでも再帰定義でプログラムする必要があります。簡単なプログラムと実行結果を示します。
リスト : 再帰定義の例題
;;; 空リストか
(defun null (x) (eq x nil))
;;; 否定
(defun not (x) (if x nil t))
;;; リストの結合
(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 は二重再帰なので、実行時間がかかることに注意してください。興味のある方は実際にプログラムを動かして、いろいろ試してみてください。
;;;
;;; secd.lisp : SECD 仮想マシンによる micro Lisp コンパイラ
;;;
;;; Copyright (C) 2020 Makoto Hiroi
;;;
;;; 真偽値 t nil
;;; 基本関数 car cdr cons eq atom apply funcall
;;; 特殊形式 quote if lambda defun function setq
;;; 数値演算 + - * / mod = /= < > <= >=
;;; 関数宣言
(declaim (ftype (function (t list list) t) comp))
;;; 関数型
(defstruct primitive func)
(defstruct closure code env)
;;; フレームと変数の位置を求める
(defun location (sym ls)
(do ((ls ls (cdr ls))
(i 0 (1+ i)))
((null ls))
(let ((j (position sym (car ls))))
(when j
(return (cons i j))))))
;;; 自己評価フォームか
(defun self-evaluation-p (expr)
(and (atom expr) (not (symbolp expr))))
;;; ラムダ式か
(defun lambda-p (expr)
(and (consp expr) (eq (car expr) 'lambda)))
;;; body のコンパイル
(defun comp-body (body env code)
(if (null (cdr body))
(comp (car body) env code)
(comp (car body)
env
(list* 'pop
(comp-body (cdr body) env code)))))
;;; 引数を評価するコードを生成する
(defun complis (expr env code)
(if (null expr)
code
(comp (car expr) env (complis (cdr expr) env code))))
;;; 関数呼び出し (リストの先頭がシンボル) のコンパイル
(defun comp-func-sym (expr env code)
(case (car expr)
((quote)
(list* 'ldc (cadr expr) code))
((if)
(let ((t-clause (comp (caddr expr) env '(join)))
(f-clause
(if (null (cdddr expr))
(list 'ldc nil 'join)
(comp (cadddr expr) env '(join)))))
(comp (cadr expr) env (list* 'sel t-clause f-clause code))))
((lambda)
(let ((body (comp-body (cddr expr) (cons (cadr expr) env) '(rtn))))
(list* 'ldf body code)))
((function)
(cond
((symbolp (cadr expr))
(list* 'ldgf (cadr expr) code))
((lambda-p (cadr expr))
(comp (cadr expr) env code))
(t
(error "~a is not function name." (cadr expr)))))
((apply)
(complis (cddr expr)
env
(list* 'args-ap
(length (cddr expr))
(comp (cadr expr) env (cons 'app code)))))
((funcall)
(complis (cddr expr)
env
(list* 'args
(length (cddr expr))
(comp (cadr expr) env (cons 'app code)))))
((defun)
(cond
((not (symbolp (cadr expr)))
(error "Required argument is not a symbol ~a" (cadr expr)))
((not (listp (caddr expr)))
(error "Required argument is not a list ~a" (caddr expr)))
(t
(comp (cons 'lambda (cddr expr)) env (list* 'def (cadr expr) code)))))
((setq)
(let ((name (cadr 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))
(t
(let ((pos (location name env)))
(if pos
;; 局所変数
(comp (caddr expr) env (list* 'lset pos code))
;; 大域変数
(comp (caddr expr) env (list* 'gset name code))))))))
(t
;; シンボルの関数値を取得
(complis (cdr expr)
env
(list* 'args (length (cdr expr)) 'ldgf (car expr) 'app code)))))
;;; コンパイル本体
(defun comp (expr env code)
(cond
((self-evaluation-p expr)
(list* 'ldc expr code))
((symbolp expr)
(let ((pos (location expr env)))
(if pos
(list* 'ld pos code) ; 局所変数
(list* 'ldg expr code)))) ; 大域変数
((symbolp (car expr))
(comp-func-sym expr env code))
((lambda-p (car expr))
(complis (cdr expr)
env
(list* 'args (length (cdr expr)) (comp (car expr) env (cons 'app code)))))
(t
(error "Illegal function call ~a" expr))))
;;; S 式をコンパイルする
(defun compile-expr (expr)
(comp expr '() '(stop)))
;;;
;;; 仮想マシン
;;;
;;; 大域変数の値を求める
(defun get-gvar (sym)
(let ((ys (get sym 'value 'undef)))
(if (not (eq ys 'undef))
ys
(error "The variable ~a is unbound." sym))))
;;; シンボルの関数値を取得する
(defun get-func (sym)
(let ((fn (get sym 'func)))
(if fn
fn
(error "The function ~a is undefined." sym))))
;;; 仮想マシンでコードを実行する
(defun vm (s e c d)
(loop
(case (pop c)
((ld)
(let ((pos (pop c)))
(push (nth (cdr pos) (nth (car pos) e)) s)))
((ldc)
(push (pop c) s))
((ldg)
(push (get-gvar (pop c)) s))
((ldgf)
(push (get-func (pop c)) s))
((ldf)
(push (make-closure :code (pop c) :env e) s))
((app)
(let ((fn (pop s)) (lvar (pop s)))
(if (primitive-p fn)
(handler-case
(push (apply (primitive-func fn) lvar) s)
(error (c) (error (format nil "~a" c))))
(progn
(push (list s e c) d)
(setq s nil
e (cons lvar (closure-env fn))
c (closure-code fn))))))
((rtn)
(let ((save (pop d)))
(setq s (cons (car s) (car save))
e (cadr save)
c (caddr save))))
((sel)
(let ((t-clause (pop c))
(e-clause (pop c)))
(push c d)
(setq c (if (pop s) t-clause e-clause))))
((join)
(setq c (pop d)))
((pop) (pop s))
((args)
(let ((a nil))
(dotimes (n (pop c) (push a s))
(push (pop s) a))))
((args-ap)
(let ((a (pop s)))
(unless (listp a)
(error "Required argument is not a list ~a" a))
(dotimes (n (1- (pop c)) (push a s))
(push (pop s) a))))
((def)
(let ((sym (pop c)))
(setf (get sym 'func) (pop s))
(push sym s)))
((lset)
(let ((pos (pop c)))
(setf (nth (cdr pos) (nth (car pos) e)) (car s))))
((gset)
(setf (get (pop c) 'value) (car s)))
((stop) (return (car s)))
(t (error "unknown opcode")))))
;;; 初期化
(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)))))
;;; read-eval-print-loop
(defun repl (&rest file-list)
(init-lisp)
(dolist (file file-list)
(with-open-file (in file :direction :input)
(do ((output t))
((eq output nil) (terpri))
(setf output (vm '() '() (compile-expr (read in nil)) '()))
(print output))))
;;
(loop
(handler-case
(progn
(princ ">>> ")
(force-output)
(let ((output (vm '() '() (compile-expr (read)) '())))
(format t "~a~%" output)))
(simple-error (c) (format t "ERROR: ~a~%" c)))))