今回は micro Scheme に「伝統的なマクロ」を追加します。インタプリタの場合、効率を考慮しないでよければ、伝統的なマクロを実装するのはとても簡単です。S 式を評価してマクロ展開したあと、その結果を再度評価すればいいのです。ただし、この方法は実行速度が遅くなるので実用的ではありません。
コンパイラの場合、プログラムをコンパイルする時にマクロ展開が行われるため、翻訳されたコードにはマクロが存在しません。その分だけプログラムを高速に実行することが可能になります。つまり、マクロを使うのであれば、インタプリタよりもコンパイラの方が有利なのです。
マクロはシンタックス形式 define-macro で定義します。マクロの本体はラムダ式で表します。そして、リストに次の形式で格納します。
(macro closure code env)
ラムダ式を評価してクロージャを作り、それがマクロであることを表すため、その先頭にシンボル macro を付加します。この処理を仮想マシンの命令 defm で行います。
define-macro のコンパイルは関数 comp に次のプログラムを追加するだけです。
リスト : define-macro のコンパイル
(defun comp (expr env code)
...
((eq (car expr) 'define-macro)
(comp (caddr expr) env (list* 'defm (cadr expr) code)))
...
)
処理内容は define のコンパイルと同じです。仮想マシンの命令が defm になるだけです。
次は関数 comp にマクロをコンパイルする処理を追加します。プログラムは次のようになります。
リスト : マクロのコンパイル
;;; マクロか
(defun macro-p (expr)
(let ((val (assoc expr *global-environment*)))
(and val (consp (cdr val)) (eq 'macro (cadr val)))))
;;; マクロのコードを取り出す
(defun get-macro-code (expr)
(caddr (get-gvar expr)))
;;; コンパイラ本体
(defun comp (expr env code)
...
((macro-p (car expr))
;; マクロ展開してからコンパイルする
(let ((new-expr (vm '()
(list (cdr expr))
(get-macro-code (car expr))
(list (list '() '() '(stop))))))
(comp new-expr env code)))
...
)
expr の先頭要素がマクロであるか関数 macro-p でチェックします。micro Scheme の場合、マクロ定義は大域変数に格納されています。*global-environment* に expr があり、その値がリストでかつ先頭要素が macro であればマクロです。マクロ本体のコードを仮想マシン vm で実行して、新しい S 式 new-expr を求めます。このとき、マクロの引数 (cdr expr) は評価しないで、そのまま仮想マシンの環境レジスタ E にセットします。
マクロのコードは関数 get-macro-code で求めます。マクロのコードは命令 rtn で終了しているので、ダンプレジスタ D に仮想マシンを停止する命令 stop を入れておきます。あとはマクロ展開された S 式 new-expr を comp でコンパイルすればいいわけです。これでコンパイルするときに全てのマクロが展開されます。
次はバッククオートを処理するマクロ backquote を作ります。コンパイラの場合、バックオートの処理はマクロを使った方が簡単です。拙作のページ Common Lisp で作る micro Scheme (2) と同様に、Common Lisp のリードテーブルを変更して、記号 (` , ,@) を backquote unquote splice に変換します。
そして、バッククオートの中でシンボル unquote と splice があれば、引数 expr を評価するように S 式を生成します。それ以外の場合は quote を付けて、引数を評価しない S 式を生成します。backquote はマクロなので、生成した S 式が再度評価されます。このとき、unquote と splice の引数が評価されます。プログラムは次のようになります。
リスト : バッククオートの処理
(define transfer
(lambda (ls)
(if (pair? ls)
(if (pair? (car ls))
(if (eq? (caar ls) 'unquote)
(list 'cons (cadar ls) (transfer (cdr ls)))
(if (eq? (caar ls) 'splice)
(list 'append (cadar ls) (transfer (cdr ls)))
(list 'cons (transfer (car ls)) (transfer (cdr ls)))))
(list 'cons (list 'quote (car ls)) (transfer (cdr ls))))
(list 'quote ls))))
(define-macro backquote (lambda (x) (transfer x)))
実際の処理は関数 transfer で行います。ls がリストでその先頭要素がリストの場合、先頭の要素が unquote もしくは splice であれば、その引数にクオートをつけません。そして、残りのリスト (cdr ls) を transfer で変換し、unquote であれば cons で結合する S 式を、splice であれば append で結合する S 式を生成します。これで、unquote と splice の引数を評価することができます。それ以外の場合は quote を付けて引数を評価しない S 式を生成します。
なお、今回のバッククォートの動作は Scheme の仕様書 (R5RS など) とは異なります。このあと定義するマクロが動作するだけの簡略版にすぎません。詳しい説明は Common Lisp で作る micro Scheme コンパイラ (4) : バッククォートの修正 をお読みください。
それでは、簡単な実行例を示します。プログラム (secd.lsp) だけではなく、micro Scheme 用のライブラリ (mlib.scm) もロードしてください。
>>> (define a '(1 2 3)) Compile => (LDC (1 2 3) DEF A STOP) Value => A >>> `(a b c) Compile => (LDC A LDC B LDC C LDC NIL ARGS 2 LDG CONS APP ARGS 2 LDG CONS APP ARGS 2 LDG CONS APP STOP) Value => (A B C) >>> `(,a b c) Compile => (LDG A LDC B LDC C LDC NIL ARGS 2 LDG CONS APP ARGS 2 LDG CONS APP ARGS 2 LDG CONS APP STOP) Value => ((1 2 3) B C) >>> `(,@a b c) Compile => (LDG A LDC B LDC C LDC NIL ARGS 2 LDG CONS APP ARGS 2 LDG CONS APP ARGS 2 LDG APPEND APP STOP) Value => (1 2 3 B C)
`(a b c) は a, b, c をリストに格納するコードにコンパイルされて、値は (A B C) になります。`(,a b c) は a の値と b, c をリストに格納するコードにコンパイルされるので、値は ((1 2 3) B C) になります。`(,@a b c) は a の値を append で連結するコードにコンパイルされるので、値は (1 2 3 B C) になります。
もちろん、unquote と unquote-splicing の引数には関数を与えることもできます。次の例を見てください。
>>> `(,(car a) b c) Compile => (LDG A ARGS 1 LDG CAR APP LDC B LDC C LDC NIL ARGS 2 LDG CONS APP ARGS 2 LDG CONS APP ARGS 2 LDG CONS APP STOP) Value => (1 B C) >>> `(,(cdr a) b c) Compile => (LDG A ARGS 1 LDG CDR APP LDC B LDC C LDC NIL ARGS 2 LDG CONS APP ARGS 2 LDG CONS APP ARGS 2 LDG CONS APP STOP) Value => ((2 3) B C) >>> `(,@(cdr a) b c) Compile => (LDG A ARGS 1 LDG CDR APP LDC B LDC C LDC NIL ARGS 2 LDG CONS APP ARGS 2 LDG CONS APP ARGS 2 LDG APPEND APP STOP) Value => (2 3 B C)
`(,(car a) b c) は (car a) が評価されるコードが生成されるので、値は (1 b c) になります。`(,(cdr a) b c) は (cdr a) が評価されるので、値は ((2 3) b c) になります。`(,@(cdr a) b c) は (cdr a) の評価結果を append で連結するので、値は (2 3 b c) になります。
次はマクロを作るときに使用するため、関数 eqv? と set! を作ります。set! は変数に値を代入します。この処理を実現するため、仮想マシンの命令に lset と gset を追加します。lset と gset の状態遷移を示します。
(v . s) e (lset (i . j) . c) d => (v . s) e c d 更新処理 : (set-lvar e i j v)
(v . s) e (gset sym . c) d => (v . s) e c d 更新処理 : (set-gvar sym v)
set! は変数に代入した値をそのまま返すことにします。
set! のコンパイルは次のようになります。
リスト : set! のコンパイル
(defun comp (expr env code)
...
((eq (car expr) 'set!)
(let ((pos (location (cadr expr) env)))
(if pos
;; 局所変数
(comp (caddr expr) env (list* 'lset pos code))
;; 大域変数
(comp (caddr expr) env (list* 'gset (cadr expr) code)))))
...
)
expr の先頭要素が set! の場合、関数 location で第 2 要素 (cadr expr) が局所変数にあるか探します。見つかった場合は、コード (list* 'lset pos code) を生成し、そこに第 3 要素 (caddr expr) を comp でコンパイルしたコードを追加します。大域変数の場合、命令は lset ではなく gset になります。
次は仮想マシン vm に lset と gset の処理を追加します。
リスト : 変数の更新処理
;;; 局所変数の値を更新する
(defun set-lvar (e i j val)
(if (<= 0 j)
(setf (nth j (nth i e)) val)
(if (= j -1)
(rplaca (nthcdr i e) val)
(rplacd (nthcdr (- (+ j 2)) (nth i e)) val))))
;;; 大域変数の値を更新する
(defun set-gvar (sym val)
(let ((cell (assoc sym *global-environment*)))
(if cell
(rplacd cell val)
(error "unbound variable: " sym))))
;;; 仮想マシン
(defun vm (s e c d)
(loop
(case (pop c)
...
((lset)
(let ((pos (pop c)))
(set-lvar e (car pos) (cdr pos) (car s))))
((gset)
(set-gvar (pop c) (car s)))
...
)))
局所変数の更新は関数 set-lvar で行います。通常の引数は setf と nth でフレームの値を破壊的に修正します。可変個引数の場合はちょっと複雑です。j の値が -1 の場合、フレーム自身が変数を表すので、フレームを格納しているリストの値を rplaca で破壊的に修正します。簡単な例を示しましょう。
((lambda x (set! x 10)) 1 2 3) E: ((1 2 3)) (set! x 10) E: (10)
((lambda x (set! x 10)) 1 2 3) を呼び出すと環境 E は ((1 2 3)) になります。この場合、x の位置は (0 . -1) で値は (1 2 3) になります。set! で x の値を 10 に書き換えると、x の値はフレームそのものなので、フレームを格納しているリストの 0 番目の要素を破壊的に修正し、環境 E は (10) になります。
それ以外の場合、通常の引数以降のフレームが変数の値になるので、rplacd でフレームを破壊的に修正します。次の図を見てください。
((lambda (a b . c) (set! a 10) (set! b 20) (set! c 30)) 1 2 3 4 5) E: ((1 2 3 4 5)) ((set! a 10) (set! b 20) (set! c 30)) E: ((10 20 . 30))
((lambda (a b . c) ...) 1 2 3 4 5) を呼び出すと環境 E は ((1 2 3 4 5)) になります。この場合、a の値は 1 で b の値は 2 になり、c の位置は (0 . -3) で値が (3 4 5) になります。ドットリストで表すと、(1 2 . (3 4 5)) になるわけです。したがって、変数 a, b, c の値を書き換えると環境 E は ((10 20 . 30)) になります。
大域変数の更新は関数 set-gvar で行います。assoc で変数と値を格納しているコンスセル cell を求めます。そして、rplacd で値を val に書き換えます。見つからない場合は error でエラーを送出します。
あとは *global-environment* に eqv? を追加します。
リスト : 初期化処理
;;; 大域変数
(setq *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 'eqv? 'primitive (lambda (x y) (if (eql x y) 'true 'false)))
(list 'pair? 'primitive (lambda (x) (if (consp x) 'true 'false)))
))
それでは実際にマクロを使ってみましょう。なお、これから示すプログラムは拙作のページ Common Lisp で作る micro Scheme (2) で作成したマクロとまったく同じです。インタプリタでもコンパイルでもマクロは正常に動作します。
まずは let を作ります。let は次に示すようにラムダ式を使って実現することができます。
(let ((a 0) (b 1) (c 2) ...) body ...)
│
↓
((lambda (a b c ...) body ...) 0 1 2 ...)
これをマクロでプログラムすると次のようになります。
リスト : let
;;; 関数 cxxr
(define cadr (lambda (x) (car (cdr x))))
(define cdar (lambda (x) (cdr (car x))))
(define caar (lambda (x) (car (car x))))
(define cddr (lambda (x) (cdr (cdr x))))
;;; let
(define-macro let
(lambda (args . body)
`((lambda ,(map car args) ,@body) ,@(map cadr args))))
(map car args) で変数名を、(map cadr args) で初期値を取り出します。関数 cadr が必要になるので、ついでに cdar, caar, cddr も定義しておきます。 あとはラムダ式を組み立て、それに初期値を渡せばいいわけです。とても簡単ですね。名前付き let はあとから作ります。
簡単な実行例を示します。
>>> (define a 0) Compile => (LDC 0 DEF A STOP) Value => A >>> (define b 1) Compile => (LDC 1 DEF B STOP) Value => B >>> (let ((a 10) (b 20)) (cons a b)) Compile => (LDC 10 LDC 20 ARGS 2 LDF (LD (0 . 0) LD (0 . 1) ARGS 2 LDG CONS APP RTN) APP STOP) Value => (10 . 20) >>> a Compile => (LDG A STOP) Value => 0 >>> b Compile => (LDG B STOP) Value => 1
Scheme の場合、処理系によっては let をシンタックス形式で定義していますが、このようにマクロでも let を実装することができます。
次は and と or を作ります。
リスト : and と or
(define-macro and
(lambda args
(if (null? args)
true
(if (null? (cdr args))
(car args)
`(if ,(car args) (and ,@(cdr args)) false)))))
(define-macro or
(lambda args
(if (null? args)
false
(if (null? (cdr args))
(car args)
`(let ((+value+ ,(car args)))
(if +value+ +value+ (or ,@(cdr args))))))))
and は引数 args の長さを調べ、空リストならば true がマクロ展開後の S 式となり、それを評価するので結果は true になります。長さが 1 ならば、リスト args の先頭要素がマクロ展開後の S 式になり、それを評価します。それ以外の場合は args の先頭の要素を評価して、真ならば args の残りの要素を and に渡してマクロ展開します。偽ならば false がマクロ展開後の S 式となり、その評価結果は false になります。
たとえば、(and 1 2 3) は次のようにマクロ展開されます。
(and 1 2 3)
↓
(if 1 (and 2 3) false)
↓
(if 1 (if 2 (and 3) false) false)
↓
(if 1 (if 2 3 false) false)
図 : (and 1 2 3) のマクロ展開
or は引数の評価結果を局所変数 +value+ に格納し、それが真ならば +value+ を返すようにします。変数捕捉を避けるため、独習 Scheme 三週間 にならって変数名に + を付けています。gensym を使いたい方は、プログラムを改造してみてください。
それでは実行例を示します。
>>> (and 1 2 3) Compile => (LDC 1 SEL (LDC 2 SEL (LDC 3 JOIN) (LDG FALSE JOIN) JOIN) (LDG FALSE JOIN) STOP) Value => 3 >>> (and false 2 3) Compile => (LDG FALSE SEL (LDC 2 SEL (LDC 3 JOIN) (LDG FALSE JOIN) JOIN) (LDG FALSE JOIN) STOP) Value => FALSE >>> (and 1 false 3) Compile => (LDC 1 SEL (LDG FALSE SEL (LDC 3 JOIN) (LDG FALSE JOIN) JOIN) (LDG FALSE JOIN) STOP) Value => FALSE >>> (and 1 2 false) Compile => (LDC 1 SEL (LDC 2 SEL (LDG FALSE JOIN) (LDG FALSE JOIN) JOIN) (LDG FALSE JOIN) STOP) Value => FALSE
>>> (or 1 2 3) Compile => (LDC 1 ARGS 1 LDF (LD (0 . 0) SEL (LD (0 . 0) JOIN) (LDC 2 ARGS 1 LDF (LD (0 . 0) SEL (LD (0 . 0) JOIN) (LDC 3 JOIN) RTN) APP JOIN) RTN) APP STOP) Value => 1 >>> (or false 2 3) Compile => (LDG FALSE ARGS 1 LDF (LD (0 . 0) SEL (LD (0 . 0) JOIN) (LDC 2 ARGS 1 LDF (LD (0 . 0) SEL (LD (0 . 0) JOIN) (LDC 3 JOIN) RTN) APP JOIN) RTN) APP STOP) Value => 2 >>> (or false false 3) Compile => (LDG FALSE ARGS 1 LDF (LD (0 . 0) SEL (LD (0 . 0) JOIN) (LDG FALSE ARGS 1 LDF (LD (0 . 0) SEL (LD (0 . 0) JOIN) (LDC 3 JOIN) RTN) APP JOIN) RTN) APP STOP) Value => 3 >>> (or false false false) Compile => (LDG FALSE ARGS 1 LDF (LD (0 . 0) SEL (LD (0 . 0) JOIN) (LDG FALSE ARGS 1 LDF (LD (0 . 0) SEL (LD (0 . 0) JOIN) (LDG FALSE JOIN) RTN) APP JOIN) RTN) APP STOP) Value => FALSE
次は let* を作ります。let* は let を入れ子にすることで実現することができます。次のリストを見てください。
リスト : let*
(define-macro let*
(lambda (args . body)
(if (null? (cdr args))
`(let (,(car args)) ,@body)
`(let (,(car args)) (let* ,(cdr args) ,@body)))))
args に要素が 1 個しかない場合は、それを let に変換します。複数ある場合は、先頭の要素を let に変換し、let の本体でマクロ let* を再帰呼び出しします。これで let* を入れ子の let に変換することができます。
簡単な実行例を示します。
>>> (let* ((a 10) (b 20) (c (cons a b))) c) Compile => (LDC 10 ARGS 1 LDF (LDC 20 ARGS 1 LDF (LD (1 . 0) LD (0 . 0) ARGS 2 LDG CONS APP ARGS 1 LDF (LD (0 . 0) RTN) APP RTN) APP RTN) APP STOP) Value => (10 . 20)
次は letrec を作ります。letrec は定義する変数を初期値の中で参照することができます。Common Lisp の labels のように、letrec で再帰関数を定義することができます。let ではこれを実現することはできません。
let は最初に初期値を評価しますが、このとき環境には定義する変数がまだ存在していないためエラーになるのです。そこで、letrec は変数を *undef* で初期化してから、あらためて set! で初期値を代入することにします。つまり、次のように変換します。
(letrec ((a expr-a) (b expr-b) ...) body ...)
│
↓
(let ((a '*undef*) (b '*undef*) ...)
(set! a expr-a)
(set! b expr-b)
...
body
... )
プログラムは次のようになります。
リスト : letrec
;;; 2 つのリストを受け取る map 関数
(define map-2
(lambda (fn xs ys)
(if (null? xs)
'()
(cons (fn (car xs) (car ys)) (map-2 fn (cdr xs) (cdr ys))))))
(define-macro letrec
(lambda (args . body)
(let ((vars (map car args))
(vals (map cadr args)))
`(let ,(map (lambda (x) `(,x '*undef*)) vars)
,@(map-2 (lambda (x y) `(set! ,x ,y)) vars vals)
,@body))))
args から map で変数名を取り出して vars に、初期値を取り出して vals にセットします。次に、let で局所変数を定義して *undef* で初期化します。そして、その変数に set! で初期値を代入します。Scheme の map は複数のリストを受け取ることができますが、前回作成した map は 1 つのリストしか受け取ることができません。そこで、2 つのリストを受け取る関数 map-2 を定義しました。
簡単な例として、リストを反転する関数 reverse を letrec で書き直します。次のリストを見てください。
リスト : リストの反転
(define reverse
(lambda (ls)
(letrec ((iter (lambda (ls a)
(if (null? ls)
a
(iter (cdr ls) (cons (car ls) a))))))
(iter ls '()))))
letrec を使うことで、iter を再帰呼び出しすることができます。簡単な実行例を示しましょう。
>>> (reverse '(a b c d e)) Compile => (LDC (A B C D E) ARGS 1 LDG REVERSE APP STOP) Value => (E D C B A) >>> (reverse '()) Compile => (LDC NIL ARGS 1 LDG REVERSE APP STOP) Value => NIL
ただし、このプログラムには問題があります。次の例を見てください。
>>> (letrec ((a a)) a) Compile => (LDC *UNDEF* ARGS 1 LDF (LD (0 . 0) LSET (0 . 0) POP LD (0 . 0) RTN) APP STOP) Value => *UNDEF*
この場合、Gauche (Scheme) ではエラーになります。この問題は Structure and Interpretation of Computer Programs (SICP) 4.1.6 Internal Definitions で説明されています。興味のある方は SICP を参考に、プログラムを改造してみてください。
次は名前付き let を作ります。名前付き let はその名が示すように let に名前を付けたもので、Common Lisp の let には無い機能です。名前付き let の構文を示します。
(let 名前
((変数１ 初期値１)
(変数２ 初期値２)
・・・・・・
(変数Ｍ 初期値Ｍ))
Ｓ式１
・・・・・・
Ｓ式Ｍ
(名前 引数１ ... 引数Ｍ))
図 : 名前付き let の構文
名前付き let は、let の後ろに名前を指定します。この名前が関数名になると考えてください。その後ろに定義される変数がその関数の引数になり、let の中の S 式がその関数の処理内容になります。そして、let の中でその関数を呼び出すことができ、let の最後で再帰呼び出しを行えば末尾再帰になります。
名前付き let は letrec に変換すると簡単です。
(let name ((a init-a) (b init-b) ...) body ...)
│
↓
(letrec ((name (lambda (a b ...) body ...)))
(name init-a init-b ...))
プログラムは次のようになります。
リスト : 名前付き let
(define-macro let
(lambda (args . body)
(if (pair? args)
`((lambda ,(map car args) ,@body) ,@(map cadr args))
;; named-let
`(letrec ((,args (lambda ,(map car (car body)) ,@(cdr body))))
(,args ,@(map cadr (car body)))))))
args の先頭要素がリストでなければ名前付き let と判断します。args が名前で、body の先頭要素が変数と初期値を格納したリストになります。あとは letrec でラムダ式を定義して、それに初期値を渡して呼び出すだけです。
簡単な例として、名前付き let で reverse を作ります。プログラムリストと実行結果を示します。
リスト : リストの反転
(define reversei
(lambda (ls)
(let loop ((ls ls) (a '()))
(if (null? ls)
a
(loop (cdr ls) (cons (car ls) a))))))
>>> (reversei '(a b c d e)) Compile => (LDC (A B C D E) ARGS 1 LDG REVERSEI APP STOP) Value => (E D C B A) >>> (reversei '()) Compile => (LDC NIL ARGS 1 LDG REVERSEI APP STOP) Value => NIL
次は begin を作ります。begin は Common Lisp の progn のことで、引数なしのラムダ式に変換するだけです。プログラムリストと実行結果を示します。
リスト : begin
(define-macro begin
(lambda args
(if (null? args)
`((lambda () '*undef*))
`((lambda () ,@args)))))
>>> (begin) Compile => (ARGS 0 LDF (LDC *UNDEF* RTN) APP STOP) Value => *UNDEF* >>> (begin 1 2 3 4 5) Compile => (ARGS 0 LDF (LDC 1 POP LDC 2 POP LDC 3 POP LDC 4 POP LDC 5 RTN) APP STOP) Value => 5
次は cond を作ります。再帰定義を使うと cond も簡単に定義することができます。次のリストを見てください。
リスト : cond
(define-macro cond
(lambda args
(if (null? args)
'*undef*
(if (eq? (caar args) 'else)
`(begin ,@(cdar args))
(if (null? (cdar args))
`(let ((+value+ ,(caar args)))
(if +value+ +value+ (cond ,@(cdr args))))
`(if ,(caar args)
(begin ,@(cdar args))
(cond ,@(cdr args))))))))
args が空リストの場合は *undef* を返します。条件部が else の場合は、残りの S 式を無条件に実行します。これは begin を使えば簡単です。そうでなければ、条件部を評価します。このとき、条件部しかない場合は評価結果を +value+ にセットし、真であればその値を返します。S 式がある場合は、begin で S 式を順番に評価します。条件部が偽の場合は、次の節をチェックします。これは cond を再帰呼び出しするだけです。
cond の簡単なテストプログラムと実行結果を示します。
リスト : cond のテスト
(define cond-test
(lambda (x)
(cond ((eq? x 'a) 1)
((eq? x 'b) 2)
((eq? x 'c) 3)
(else 0))))
>>> (cond-test 'a) Compile => (LDC A ARGS 1 LDG COND-TEST APP STOP) Value => 1 >>> (cond-test 'b) Compile => (LDC B ARGS 1 LDG COND-TEST APP STOP) Value => 2 >>> (cond-test 'c) Compile => (LDC C ARGS 1 LDG COND-TEST APP STOP) Value => 3 >>> (cond-test 'd) Compile => (LDC D ARGS 1 LDG COND-TEST APP STOP) Value => 0 >>> (cond-test 'e) Compile => (LDC E ARGS 1 LDG COND-TEST APP STOP) Value => 0
次は case を作ります。case も再帰定義を使うと簡単です。
リスト : case
;;; 探索
(define memv
(lambda (x ls)
(if (null? ls)
false
(if (eqv? x (car ls))
ls
(memv x (cdr ls))))))
(define-macro case
(lambda (key . args)
(if (null? args)
'*undef*
(if (eq? (caar args) 'else)
`(begin ,@(cdar args))
`(if (memv ,key ',(caar args))
(begin ,@(cdar args))
(case ,key ,@(cdr args)))))))
キーを探索するため、関数 memv を定義します。memv は要素の比較に eqv? を使います。case の引数 args が空リストの場合は *undef* を返します。節の先頭要素が else の場合は、begin で残りの要素を順番に評価します。そうでなければ、memv で key を探索します。見つけたら残りの S 式を begin で順番に評価します。見つからない場合は次の節をチェックします。これは case を再帰呼び出しするだけです。
簡単な case のテストプログラムと実行結果を示します。
リスト : case のテスト
(define case-test
(lambda (x)
(case x
((a b c) 1)
((d e f) 2)
((g h i) 3)
(else 0))))
>>> (case-test 'a) Compile => (LDC A ARGS 1 LDG CASE-TEST APP STOP) Value => 1 >>> (case-test 'e) Compile => (LDC E ARGS 1 LDG CASE-TEST APP STOP) Value => 2 >>> (case-test 'i) Compile => (LDC I ARGS 1 LDG CASE-TEST APP STOP) Value => 3 >>> (case-test 'j) Compile => (LDC J ARGS 1 LDG CASE-TEST APP STOP) Value => 0
最後に do を作りましょう。Common Lisp の場合、do は tagbody と go を使ってマクロ定義することができますが、go のようなジャンプ命令は Scheme に存在しないので、単純な繰り返しも再帰呼び出しで定義します。do の場合は letrec に変換すると簡単です。次のリストを見てください。
リスト : do
(define-macro do
(lambda (var-form test-form . args)
(let ((vars (map car var-form))
(vals (map cadr var-form))
(step (map cddr var-form)))
`(letrec ((loop (lambda ,vars
(if ,(car test-form)
(begin ,@(cdr test-form))
(begin
,@args
(loop ,@(map-2 (lambda (x y)
(if (null? x) y (car x)))
step
vars)))))))
(loop ,@vals)))))
まず引数 var-form から変数、初期値、更新式 (step-form) を取り出して vars, vals, step にセットします。step の要素は、step-form が存在しない場合は空リストになることに注意してください。あとは letrec で lambda 式を組み立てます。test-form の先頭要素を評価して、その結果が真であれば begin で残りの要素を評価して返します。
そうでなければ、begin で do の本体を評価して loop を再帰呼び出します。ここで、step-form がない場合、ラムダ式の引数 x は空リストになるので、対応する変数 y をそのまま渡します。そうでなければ、(car x) で step-form を取り出して渡します。これで繰り返しを実現することができます。
簡単な例として do を使って reverse をプログラムします。リストと実行結果を示します。
リスト : do のテスト
(define reverse-do
(lambda (xs)
(do ((ls xs (cdr ls)) (result '()))
((null? ls) result)
(set! result (cons (car ls) result)))))
>>> (reverse-do '(a b c d e)) Compile => (LDC (A B C D E) ARGS 1 LDG REVERSE-DO APP STOP) Value => (E D C B A)
今回はここまでです。次回は「継続」の実装に挑戦してみましょう。
;;;
;;; secd.lsp : SECD 仮想マシンによる Scheme コンパイラ
;;;
;;; (1) 基本機能の実装
;;; (2) 伝統的なマクロの実装
;;;
;;; Copyright (C) 2009-2021 Makoto Hiroi
;;;
;;; 関数宣言
(declaim (ftype (function (t list list) t) comp))
(declaim (ftype (function (list list list list) t) vm))
;;; 大域変数
(defvar *global-environment* nil)
;;; 大域変数の値を求める
(defun get-gvar (sym)
(let ((val (assoc sym *global-environment*)))
(if val
(cdr val)
(error "unbound variabl ~S" sym))))
;;; 大域変数の値を書き換える
(defun set-gvar (sym val)
(let ((cell (assoc sym *global-environment*)))
(if cell
(rplacd cell val)
(error "unbound variable ~S" sym))))
;;; 変数の位置を求める
(defun position-var (sym ls)
(labels ((iter (i ls)
(cond ((null ls) nil)
((symbolp ls)
(if (eq sym ls) (- (1+ i)) nil))
((eq sym (car ls)) i)
(t (iter (1+ i) (cdr ls))))))
(iter 0 ls)))
;;; フレームと変数の位置を求める
(defun location (sym ls)
(labels ((iter (i ls)
(if (null ls)
nil
(let ((j (position-var sym (car ls))))
(if j
(cons i j)
(iter (1+ i) (cdr ls)))))))
(iter 0 ls)))
;;; 自己評価フォームか
(defun self-evaluation-p (expr)
(and (atom expr) (not (symbolp expr))))
;;; マクロか
(defun macro-p (expr)
(let ((val (assoc expr *global-environment*)))
(and val (consp (cdr val)) (eq 'macro (cadr val)))))
;;; マクロのコードを取り出す
(defun get-macro-code (expr)
(caddr (get-gvar expr)))
;;; S 式をコンパイルする
(defun compile-expr (expr)
(comp expr '() '(stop)))
;;; 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 (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))))
((eq (car expr) 'quote)
(list* 'ldc (cadr expr) code))
((eq (car expr) 'if)
(let ((t-clause (comp (caddr expr) env '(join)))
(f-clause
(if (null (cdddr expr))
(list 'ldc '*undef* 'join)
(comp (cadddr expr) env '(join)))))
(comp (cadr expr) env (list* 'sel t-clause f-clause code))))
((eq (car expr) 'lambda)
(let ((body (comp-body (cddr expr) (cons (cadr expr) env) '(rtn))))
(list* 'ldf body code)))
((eq (car expr) 'define)
(comp (caddr expr) env (list* 'def (cadr expr) code)))
((eq (car expr) 'define-macro)
(comp (caddr expr) env (list* 'defm (cadr expr) code)))
((eq (car expr) 'set!)
(let ((pos (location (cadr expr) env)))
(if pos
;; 局所変数
(comp (caddr expr) env (list* 'lset pos code))
;; 大域変数
(comp (caddr expr) env (list* 'gset (cadr expr) code)))))
((macro-p (car expr))
;; マクロ展開してからコンパイルする
(let ((new-expr (vm '()
(list (cdr expr))
(get-macro-code (car expr))
(list (list '() '() '(stop))))))
(comp new-expr env code)))
(t ; 関数呼び出し
(complis (cdr expr)
env
(list* 'args
(length (cdr expr))
(comp (car expr) env (cons 'app code)))))))
;;;
;;; 仮想マシン
;;;
;;; 局所変数の値を求める
(defun get-lvar (e i j)
(if (<= 0 j)
(nth j (nth i e))
(nthcdr (- (1+ j)) (nth i e))))
;;; 局所変数の値を更新する
(defun set-lvar (e i j val)
(if (<= 0 j)
(setf (nth j (nth i e)) val)
(if (= j -1)
(rplaca (nthcdr i e) val)
(rplacd (nthcdr (- (+ j 2)) (nth i e)) val))))
;;; 仮想マシンでコードを実行する
(defun vm (s e c d)
(loop
(case (pop c)
((ld)
(let ((pos (pop c)))
(push (get-lvar e (car pos) (cdr pos)) s)))
((ldc)
(push (pop c) s))
((ldg)
(push (get-gvar (pop c)) s))
((ldf)
(push (list 'closure (pop c) e) s))
((lset)
(let ((pos (pop c)))
(set-lvar e (car pos) (cdr pos) (car s))))
((gset)
(set-gvar (pop c) (car s)))
((app)
(let ((clo (pop s)) (lvar (pop s)))
(if (eq (car clo) 'primitive)
(push (apply (cadr clo) lvar) s)
(progn
(push (list s e c) d)
(setq s nil
e (cons lvar (caddr clo))
c (cadr clo))))))
((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 (eq (pop s) 'false) e-clause t-clause))))
((join)
(setq c (pop d)))
((pop) (pop s))
((args)
(let ((a nil))
(dotimes (n (pop c) (push a s))
(push (pop s) a))))
((def)
(let ((sym (pop c)))
(push (cons sym (pop s)) *global-environment*)
(push sym s)))
((defm)
(let ((sym (pop c)))
(push (cons sym (cons 'macro (pop s))) *global-environment*)
(push sym s)))
((stop) (return (car s)))
(t (error "unknown opcode")))))
;;; 大域変数
(setq *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 'eqv? 'primitive (lambda (x y) (if (eql x y) 'true 'false)))
(list 'pair? 'primitive (lambda (x) (if (consp x) 'true 'false)))
))
;;;
;;; read-eval-print-loop
;;;
(defun change-readtable ()
(set-macro-character
#\`
(lambda (stream char)
(declare (ignore char))
(list 'backquote (read stream t nil t))))
(set-macro-character
#\,
(lambda (stream char)
(declare (ignore char))
(cond ((char= (peek-char nil stream) #\@)
(read-char stream)
(list 'splice (read stream t nil t)))
(t (list 'unquote (read stream t nil t)))))))
(defun repl (&rest file-list)
(unwind-protect
(progn
(change-readtable)
(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))))
(do ((output nil))
((eq output 'quit))
(princ ">>> ")
(force-output)
(handler-case
(let ((expr (compile-expr (read))))
(format t "Compile => ~S~%" expr)
(setf output (vm '() '() expr '()))
(format t "Value => ~S~%" output))
(simple-error (c) (format t "ERROR: ~a~%" c)))))
(setq *readtable* (copy-readtable nil))))
;;;
;;; mlib.scm : micro Scheme 用ライブラリ
;;;
;;; Copyright (C) 2009-2021 Makoto Hiroi
;;;
;;;
;;; 述語
;;;
(define null? (lambda (x) (eq? x '())))
(define not (lambda (x) (if (eq? x false) true false)))
;;;
;;; リスト操作関数
;;;
(define cadr (lambda (x) (car (cdr x))))
(define cdar (lambda (x) (cdr (car x))))
(define caar (lambda (x) (car (car x))))
(define cddr (lambda (x) (cdr (cdr x))))
(define cadar (lambda (x) (car (cdr (car x)))))
(define list (lambda args args))
(define append
(lambda (xs ys)
(if (null? xs)
ys
(cons (car xs) (append (cdr xs) ys)))))
;;; リストの探索
(define memq
(lambda (x ls)
(if (null? ls)
false
(if (eq? x (car ls))
ls
(memq x (cdr ls))))))
(define memv
(lambda (x ls)
(if (null? ls)
false
(if (eqv? x (car ls))
ls
(memv x (cdr ls))))))
;;; 連想リストの探索
(define assq
(lambda (x ls)
(if (null? ls)
false
(if (eq? x (car (car ls)))
(car ls)
(assq x (cdr ls))))))
(define assv
(lambda (x ls)
(if (null? ls)
false
(if (eqv? x (car (car ls)))
(car ls)
(assv x (cdr ls))))))
;;;
;;; 高階関数
;;;
;;; マップ
(define map
(lambda (fn ls)
(if (null? ls)
'()
(cons (fn (car ls)) (map fn (cdr ls))))))
(define map-2
(lambda (fn xs ys)
(if (null? xs)
'()
(cons (fn (car xs) (car ys)) (map-2 fn (cdr xs) (cdr ys))))))
;;; フィルター
(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)))))
;;;
;;; マクロ
;;;
;;; backquote
(define transfer
(lambda (ls)
(if (pair? ls)
(if (pair? (car ls))
(if (eq? (caar ls) 'unquote)
(list 'cons (cadar ls) (transfer (cdr ls)))
(if (eq? (caar ls) 'splice)
(list 'append (cadar ls) (transfer (cdr ls)))
(list 'cons (transfer (car ls)) (transfer (cdr ls)))))
(list 'cons (list 'quote (car ls)) (transfer (cdr ls))))
(list 'quote ls))))
(define-macro backquote (lambda (x) (transfer x)))
;;; let
(define-macro let
(lambda (args . body)
(if (pair? args)
`((lambda ,(map car args) ,@body) ,@(map cadr args))
; named-let
`(letrec ((,args (lambda ,(map car (car body)) ,@(cdr body))))
(,args ,@(map cadr (car body)))))))
;;; and
(define-macro and
(lambda args
(if (null? args)
true
(if (null? (cdr args))
(car args)
`(if ,(car args) (and ,@(cdr args)) false)))))
;;; or
(define-macro or
(lambda args
(if (null? args)
false
(if (null? (cdr args))
(car args)
`(let ((+value+ ,(car args)))
(if +value+ +value+ (or ,@(cdr args))))))))
;;; let*
(define-macro let*
(lambda (args . body)
(if (null? (cdr args))
`(let (,(car args)) ,@body)
`(let (,(car args)) (let* ,(cdr args) ,@body)))))
;;; letrec
(define-macro letrec
(lambda (args . body)
(let ((vars (map car args))
(vals (map cadr args)))
`(let ,(map (lambda (x) `(,x '*undef*)) vars)
,@(map-2 (lambda (x y) `(set! ,x ,y)) vars vals)
,@body))))
;;; begin
(define-macro begin
(lambda args
(if (null? args)
`((lambda () '*undef*))
`((lambda () ,@args)))))
;;; cond
(define-macro cond
(lambda args
(if (null? args)
'*undef*
(if (eq? (caar args) 'else)
`(begin ,@(cdar args))
(if (null? (cdar args))
`(let ((+value+ ,(caar args)))
(if +value+ +value+ (cond ,@(cdr args))))
`(if ,(caar args)
(begin ,@(cdar args))
(cond ,@(cdr args))))))))
;;; case
(define-macro case
(lambda (key . args)
(if (null? args)
'*undef*
(if (eq? (caar args) 'else)
`(begin ,@(cdar args))
`(if (memv ,key ',(caar args))
(begin ,@(cdar args))
(case ,key ,@(cdr args)))))))
;;; do
(define-macro do
(lambda (var-form test-form . args)
(let ((vars (map car var-form))
(vals (map cadr var-form))
(step (map cddr var-form)))
`(letrec ((loop (lambda ,vars
(if ,(car test-form)
(begin ,@(cdr test-form))
(begin
,@args
(loop ,@(map-2 (lambda (x y)
(if (null? x) y (car x)))
step
vars)))))))
(loop ,@vals)))))
;;; do のテスト
(define reverse-do
(lambda (xs)
(do ((ls xs (cdr ls)) (result '()))
((null? ls) result)
(set! result (cons (car ls) result)))))
;;; cond のテスト
(define cond-test
(lambda (x)
(cond ((eq? x 'a) 1)
((eq? x 'b) 2)
((eq? x 'c) 3)
(else 0))))
;;; case のテスト
(define case-test
(lambda (x)
(case x
((a b c) 1)
((d e f) 2)
((g h i) 3)
(else 0))))
;;;
;;; マクロを使った関数の定義
;;;
(define reverse
(lambda (ls)
(letrec ((iter (lambda (ls a)
(if (null? ls)
a
(iter (cdr ls) (cons (car ls) a))))))
(iter ls '()))))
(define reversei
(lambda (ls)
(let loop ((ls ls) (a '()))
(if (null? ls)
a
(loop (cdr ls) (cons (car ls) a))))))