今回は micro Scheme に「伝統的なマクロ」を追加します。インタプリタの場合、効率を考慮しないでよければ、伝統的なマクロを実装するのはとても簡単です。S 式を評価してマクロ展開したあと、その結果を再度評価すればいいのです。ただし、この方法は実行速度が遅くなるので実用的ではありません。
コンパイラの場合、プログラムをコンパイルする時にマクロ展開が行われるため、翻訳されたコードにはマクロが存在しません。その分だけプログラムを高速に実行することが可能になります。つまり、マクロを使うのであれば、インタプリタよりもコンパイラの方が有利なのです。
マクロはシンタックス形式 define-macro で定義します。マクロの本体はラムダ式で表します。そして、リストに次の形式で格納します。
(macro closure code env)
ラムダ式を評価してクロージャを作り、それがマクロであることを表すため、その先頭にシンボル macro を付加します。この処理を仮想マシンの命令 defm で行います。
define-macro のコンパイルは関数 comp に次のプログラムを追加するだけです。
リスト : define-macro のコンパイル
(define (comp expr env code)
...
((eq? (car expr) 'define-macro)
(comp (caddr expr) env (list* 'defm (cadr expr) code)))
...
)
処理内容は define のコンパイルと同じです。仮想マシンの命令が defm になるだけです。
次は関数 comp にマクロをコンパイルする処理を追加します。プログラムは次のようになります。
リスト : マクロのコンパイル
;;; マクロか
(define (macro? expr)
(let ((val (assoc expr *global-environment*)))
(and val (pair? (cdr val)) (eq? 'macro (cadr val)))))
;;; マクロのコードを取り出す
(define (get-macro-code expr)
(caddr (get-gvar expr)))
;;; コンパイラ本体
(define (comp expr env code)
...
((macro? (car expr))
;; マクロ展開してからコンパイルする
(let ((new-expr (vm '()
(list (cdr expr))
(get-macro-code (car expr))
(list (list '() '() '(stop))))))
(comp new-expr env code)))
...
)
expr の先頭要素がマクロであるか関数 macro? でチェックします。micro Scheme の場合、マクロ定義は大域変数に格納されています。*global-environment* に expr があり、その値がリストでかつ先頭要素が macro であればマクロです。マクロ本体のコードを仮想マシン vm で実行して、新しい S 式 new-expr を求めます。このとき、マクロの引数 (cdr expr) は評価しないで、そのまま仮想マシンの環境レジスタ E にセットします。
マクロのコードは関数 get-macro-code で求めます。マクロのコードは命令 rtn で終了しているので、ダンプレジスタ D に仮想マシンを停止する命令 stop を入れておきます。あとはマクロ展開された S 式 new-expr を comp でコンパイルすればいいわけです。これでコンパイルするときに全てのマクロが展開されます。
次はバッククオートを処理する quasiquote をマクロで定義します。拙作のページ Scheme で作る micro Scheme (2) で作成したインタプリタでは、quasiquote をシンタックス形式として定義しましたが、コンパイラの場合はマクロを使って定義したほうが簡単です。
バッククオートで使う記号 (` , ,@) は省略形で、次に示す S 式に変換されます。
`(...) : (quasiquote (...)) ,expr : (unquote expr) ,@expr : (unquote-splicing expr)
バッククオートの中でシンボル unquote と unquote-splicing があれば、引数 expr を評価するように S 式を生成します。それ以外の場合は quote を付けて、引数を評価しない S 式を生成します。quasiquote はマクロなので、生成した S 式が再度評価されます。このとき、バッククオートの処理を行うことができます。プログラムは次のようになります。
リスト : バッククオートの処理
(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) 'unquote-splicing)
(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 quasiquote (lambda (x) (transfer x)))
実際の処理は関数 transfer で行います。ls がリストでその先頭要素がリストの場合、先頭の要素が unquote もしくは unquote-splicing であれば、その引数にクオートをつけません。そして、残りのリスト (cdr ls) を transfer で変換し、unquote であれば cons で結合する S 式を、unquote-splicing であれば append で結合する S 式を生成します。これで、unquote と unquote-splicing の引数を評価することができます。それ以外の場合は quote を付けて引数を評価しない S 式を生成します。
ここで、関数 transfer の簡単なテストを行ってみましょう。次の実行例を見てください。
gosh[r7rs.user]> (transfer '(a b c)) (cons 'a (cons 'b (cons 'c '()))) gosh[r7rs.user]> (transfer '(,a b c)) (cons a (cons 'b (cons 'c '()))) gosh[r7rs.user]> (transfer '(,a ,@b c)) (cons a (append b (cons 'c '()))) gosh[r7rs.user]> (transfer '(,(car a) ,@(cdr b) c)) (cons (car a) (append (cdr b) (cons 'c '())))
このように、transfer を評価するとリストを生成する S 式が生成されます。unquote や unquote-splicing の引数はクオートが付いていないので、S 式を評価するときにその引数が評価されます。コンパイラの場合、この生成された S 式を再度コンパイルすることで、バッククオートの処理を行うことができます。
なお、今回のバッククォートの動作は Scheme の仕様書 (R5RS など) とは異なります。このあと定義するマクロが動作するだけの簡略版にすぎません。詳しい説明は micro Scheme コンパイラの作成 (4) : バッククォートの修正 をお読みください。
それでは、簡単な実行例を示します。プログラム (secd.scm) だけではなく、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 () 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 () 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 () 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 () 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 () 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 () 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! のコンパイル
(define (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 の処理を追加します。
リスト : 変数の更新処理
;;; 局所変数の値を更新する
(define (set-lvar! e i j val)
(if (<= 0 j)
(set-car! (drop (list-ref e i) j) val)
(if (= j -1)
(set-car! (drop e i) val)
(set-cdr! (drop (list-ref e i) (- (+ j 2))) val))))
;;; 大域変数の値を更新する
(define (set-gvar! sym val)
(let ((cell (assoc sym *global-environment*)))
(if cell
(set-cdr! cell val)
(error "unbound variable " sym))))
;;; 仮想マシン
(define (vm s e c d)
(case (pop! c)
...
((lset)
(let ((pos (car c)))
(set-lvar! e (car pos) (cdr pos) (car s))
(vm s e (cdr c) d)))
((gset)
(set-gvar! (car c) (car s))
(vm s e (cdr c) d))
...
))
局所変数の更新は関数 set-lvar! で行います。通常の引数は set-car! でフレームの値を破壊的に修正します。可変個引数の場合はちょっと複雑です。j の値が -1 の場合、フレーム自身が変数を表すので、フレームを格納しているリストの値を set-car! で破壊的に修正します。簡単な例を示しましょう。
((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) になります。
それ以外の場合、通常の引数以降のフレームが変数の値になるので、set-cdr! でフレームを破壊的に修正します。次の図を見てください。
((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 を求めます。そして、set-cdr! で値を val に書き換えます。見つからない場合は error でエラーを送出します。
あとは *global-environment* に eqv? を追加します。
リスト : 初期化処理
;;; 大域変数
(define *global-environment*
(list
(list 'car 'primitive car)
(list 'cdr 'primitive cdr)
(list 'cons 'primitive cons)
(list 'eq? 'primitive eq?)
(list 'eqv? 'primitive eqv?)
(list 'pair? 'primitive pair?)
))
それでは実際にマクロを使ってみましょう。なお、これから示すプログラムは拙作のページ Scheme で作る 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
Gauche の場合、let はシンタックス形式ですが、このようにマクロでも let を実装することができます。
次は and と or を作ります。
リスト ; and と or
(define-macro and
(lambda args
(if (null? args)
#t
(if (null? (cdr args))
(car args)
`(if ,(car args) (and ,@(cdr args)) #f)))))
(define-macro or
(lambda args
(if (null? args)
#f
(if (null? (cdr args))
(car args)
`(let ((+value+ ,(car args)))
(if +value+ +value+ (or ,@(cdr args))))))))
and は拙作のページ マクロ (1) で作成したプログラムと同じです。or は引数の評価結果を局所変数 +value+ に格納し、それが真ならば +value+ を返すようにします。変数捕捉を避けるため、独習 Scheme 三週間 にならって変数名に + を付けています。gensym を使いたい方は、プログラムを改造してみてください。
それでは実行例を示します。
>>> (and 1 2 3) Compile => (ldc 1 sel (ldc 2 sel (ldc 3 join) (ldc #f join) join) (ldc #f join) stop) Value => 3 >>> (and 1 #f 3) Compile => (ldc 1 sel (ldc #f sel (ldc 3 join) (ldc #f join) join) (ldc #f join) stop) Value => #f >>> (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 #f #f 3) Compile => (ldc #f args 1 ldf (ld (0 . 0) sel (ld (0 . 0) join) (ldc #f args 1 l df (ld (0 . 0) sel (ld (0 . 0) join) (ldc 3 join) rtn) app join) rtn) app stop) Value => 3 >>> (or #f #f #f) Compile => (ldc #f args 1 ldf (ld (0 . 0) sel (ld (0 . 0) join) (ldc #f args 1 l df (ld (0 . 0) sel (ld (0 . 0) join) (ldc #f join) rtn) app join) rtn) app stop) Value => #f
次は 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 100) (b a) (c (cons a b))) c) Compile => (ldc 100 args 1 ldf (ld (0 . 0) args 1 ldf (ld (1 . 0) ld (0 . 0) arg s 2 ldg cons app args 1 ldf (ld (0 . 0) rtn) app rtn) app rtn) app stop) Value => (100 . 100)
次は letrec を作ります。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 () args 1 ldg reverse app stop) Value => ()
ただし、このプログラムには問題があります。次の例を見てください。
>>> (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 ではエラーになります。この問題は Structure and Interpretation of Computer Programs (SICP) 4.1.6 Internal Definitions で説明されています。興味のある方は SICP を参考に、プログラムを改造してみてください。
次は名前付き 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 () args 1 ldg reversei app stop) Value => ()
次は begin を作ります。begin は引数なしのラムダ式に変換するだけです。プログラムリストと実行結果を示します。
リスト : 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 s top) 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)
#f
(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 を作りましょう。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.scm : SECD 仮想マシンによる Scheme コンパイラ (R7RS-small 対応版)
;;;
;;; (1) 基本機能の実装
;;; (2) 伝統的なマクロの実装
;;;
;;; Copyright (C) 2009-2021 Makoto Hiroi
;;;
(import (scheme base) (scheme cxr) (scheme write) (scheme read)
(scheme file) (scheme process-context))
;;; データの追加
(define-syntax push!
(syntax-rules ()
((_ place x) (set! place (cons x place)))))
;;; データの取得
(define-syntax pop!
(syntax-rules ()
((_ place)
(let ((x (car place)))
(set! place (cdr place))
x))))
;;; ドットリストの生成
(define (list* . xs)
(if (null? (cdr xs))
(car xs)
(cons (car xs) (apply list* (cdr xs)))))
;;; 変数の位置を求める
(define (position-var sym ls)
(let loop ((i 0) (ls ls))
(cond ((null? ls) #f)
((symbol? ls)
(if (eq? sym ls) (- (+ i 1)) #f))
((eq? sym (car ls)) i)
(else
(loop (+ i 1) (cdr ls))))))
;;; フレームと変数の位置を求める
(define (location sym ls)
(let loop ((i 0) (ls ls))
(if (null? ls)
#f
(let ((j (position-var sym (car ls))))
(if j
(cons i j)
(loop (+ i 1) (cdr ls)))))))
;;; 自己評価フォームか
(define (self-evaluation? expr)
(and (not (pair? expr)) (not (symbol? expr))))
;;; マクロか
(define (macro? expr)
(let ((val (assoc expr *global-environment*)))
(and val (pair? (cdr val)) (eq? 'macro (cadr val)))))
;;; マクロのコードを取り出す
(define (get-macro-code expr)
(caddr (get-gvar expr)))
;;; S 式をコンパイルする
(define (compile expr)
(comp expr '() '(stop)))
(define (comp expr env code)
(cond ((self-evaluation? expr) ; 自己評価フォーム
(list* 'ldc expr code))
((symbol? 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? (car expr))
;; マクロ展開してからコンパイルする
(let ((new-expr (vm '()
(list (cdr expr))
(get-macro-code (car expr))
(list (list '() '() '(stop))))))
(comp new-expr env code)))
(else ; 関数呼び出し
(complis (cdr expr)
env
(list* 'args
(length (cdr expr))
(comp (car expr) env (cons 'app code)))))))
;;; body のコンパイル
(define (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)))))
;;; 引数を評価するコードを生成
(define (complis expr env code)
(if (null? expr)
code
(comp (car expr) env (complis (cdr expr) env code))))
;;;
;;; 仮想マシン
;;;
;;; ls の先頭から n 個の要素を取り除く
(define (drop ls n)
(if (zero? n)
ls
(drop (cdr ls) (- n 1))))
;;; 局所変数の値を求める
(define (get-lvar e i j)
(if (<= 0 j)
(list-ref (list-ref e i) j)
(drop (list-ref e i) (- (+ j 1)))))
;;; 局所変数の値を更新する
(define (set-lvar! e i j val)
(if (<= 0 j)
(set-car! (drop (list-ref e i) j) val)
(if (= j -1)
(set-car! (drop e i) val)
(set-cdr! (drop (list-ref e i) (- (+ j 2))) val))))
;;; 大域変数の値を求める
(define (get-gvar sym)
(let ((val (assoc sym *global-environment*)))
(if val
(cdr val)
(error "unbound variable " sym))))
;;; 大域変数の値を更新する
(define (set-gvar! sym val)
(let ((cell (assoc sym *global-environment*)))
(if cell
(set-cdr! cell val)
(error "unbound variable " sym))))
;;; 仮想マシンでコードを実行する
(define (vm s e c d)
(case (pop! c)
((ld)
(let ((pos (car c)))
(vm (cons (get-lvar e (car pos) (cdr pos)) s) e (cdr c) d)))
((ldc)
(vm (cons (car c) s) e (cdr c) d))
((ldg)
(vm (cons (get-gvar (car c)) s) e (cdr c) d))
((ldf)
(vm (cons (list 'closure (car c) e) s) e (cdr c) d))
((lset)
(let ((pos (car c)))
(set-lvar! e (car pos) (cdr pos) (car s))
(vm s e (cdr c) d)))
((gset)
(set-gvar! (car c) (car s))
(vm s e (cdr c) d))
((app)
(let ((clo (car s)) (lvar (cadr s)))
(if (eq? (car clo) 'primitive)
(vm (cons (apply (cadr clo) lvar) (cddr s)) e c d)
(vm '() (cons lvar (caddr clo)) (cadr clo) (cons (list (cddr s) e c) d)))))
((rtn)
(let ((save (car d)))
(vm (cons (car s) (car save)) (cadr save) (caddr save) (cdr d))))
((sel)
(let ((t-clause (car c))
(e-clause (cadr c)))
(if (car s)
(vm (cdr s) e t-clause (cons (cddr c) d))
(vm (cdr s) e e-clause (cons (cddr c) d)))))
((join)
(vm s e (car d) (cdr d)))
((pop)
(vm (cdr s) e c d))
((args)
(let loop ((n (car c)) (a '()))
(if (zero? n)
(vm (cons a s) e (cdr c) d)
(loop (- n 1) (cons (pop! s) a)))))
((def)
(let ((sym (car c)))
(push! *global-environment* (cons sym (car s)))
(vm (cons sym (cdr s)) e (cdr c) d)))
((defm)
(let ((sym (car c)))
(push! *global-environment*
(cons sym (cons 'macro (car s))))
(vm (cons sym (cdr s)) e (cdr c) d)))
((stop) (car s))
(else (error "unknown opcode"))))
;;; 大域変数
(define *global-environment*
(list
(list 'car 'primitive car)
(list 'cdr 'primitive cdr)
(list 'cons 'primitive cons)
(list 'eq? 'primitive eq?)
(list 'eqv? 'primitive eqv?)
(list 'pair? 'primitive pair?)
))
;;; read-eval-print-loop
(define (repl)
(let loop ()
(display "\n>>> ")
(guard (err
(else (display "ERROR: ")
(display (error-object-message err))
(unless
(null? (error-object-irritants err))
(display (car (error-object-irritants err))))
(newline)))
(let* ((expr (compile (read)))
(v (vm '() '() expr '())))
(when (eof-object? v) (exit))
(display "Compile => ")
(display expr)
(newline)
(display "Value => ")
(display v)
(newline)))
(loop)))
;;; ファイルの読み込み
(for-each
(lambda (name)
(with-input-from-file name
(lambda ()
(let loop ()
(let ((output (vm '() '() (compile (read)) '())))
(display output)
(newline)
(if (not (eof-object? output))
(loop)
#f))))))
(cdr (command-line)))
;;; 実行
(repl)
;;;
;;; mlib.scm : micro Scheme 用ライブラリ
;;;
;;; Copyright (C) 2009-2021 Makoto Hiroi
;;;
;;; 述語
(define null? (lambda (x) (eq? x '())))
(define not (lambda (x) (if (eq? x #f) #t #f)))
;;; 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))))
;;; cxxxr
(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)
#f
(if (eq? x (car ls))
ls
(memq x (cdr ls))))))
(define memv
(lambda (x ls)
(if (null? ls)
#f
(if (eqv? x (car ls))
ls
(memv x (cdr ls))))))
;;; 連想リストの探索
(define assq
(lambda (x ls)
(if (null? ls)
#f
(if (eq? x (car (car ls)))
(car ls)
(assq x (cdr ls))))))
(define assv
(lambda (x ls)
(if (null? ls)
#f
(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)))))
;;;
;;; マクロ
;;;
;;; quasiquote
(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) 'unquote-splicing)
(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 quasiquote (lambda (x) (transfer x)))
;;; let (named-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)
#t
(if (null? (cdr args))
(car args)
`(if ,(car args) (and ,@(cdr args)) #f)))))
;;; or
(define-macro or
(lambda args
(if (null? args)
#f
(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))
(caar 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)))))
;;;
;;; マクロを使った関数の定義
;;;
;;; reverse
(define reverse
(lambda (ls)
(letrec ((iter (lambda (ls a)
(if (null? ls)
a
(iter (cdr ls) (cons (car ls) a))))))
(iter ls '()))))
;;; reverse (named-let 版)
(define reversei
(lambda (ls)
(let loop ((ls ls) (a '()))
(if (null? ls)
a
(loop (cdr ls) (cons (car ls) a))))))