今回は micro Scheme に「継続 (continuation)」を導入します。拙作のページ Common Lisp で作る micro Scheme (3) では、インタプリタを「継続渡しスタイル」で書き直すことで「継続」を実装しました。SECD 仮想マシンの場合、継続を導入するのはとても簡単です。継続の取得はレジスタ S, E, C, D を保存するだけでよいのです。継続を再開するのも保存しておいた各レジスタを元に戻すだけですみます。
それではプログラムを作りましょう。仮想マシンに継続を取得する命令 ldct を追加します。ldct の状態遷移を示します。
s e (ldct code . c) d => ((continuation s e code d) . s) e c d
継続はリストで表します。先頭にシンボル continuation を付けて、その後ろに s, e, code, d を格納します。code は call/cc のあとに実行するコードで、call/cc をコンパイルするときにセットされます。コード c には call/cc の引数を評価して、それを呼び出す命令がセットされます。このとき、生成した継続が引数として渡されます。
call/cc のコンパイルは次のようになります。
リスト : call/cc のコンパイル
(defun comp (expr env code)
...
((eq (car expr) 'call/cc)
(list* 'ldct code 'args 1 (comp (cadr expr) env (cons 'app code))))
...
)
call/cc の後に実行する命令は comp の引数 code に格納されています。命令 ldct のあとに code を格納します。call/cc の引数に渡される値は関数で、その関数に生成した継続を渡します。args でスタックに積まれた継続を取り出してリストに格納します。そして、call/cc の引数 (cadr expr) を comp でコンパイルします。値は関数になるはずなので、それを命令 app で呼び出します。
次は仮想マシン vm を修正します。命令 ldct を追加して、継続を実行できるように命令 app を修正します。プログラムは次のようになります。
リスト : 仮想マシンに継続の処理を追加
(defun vm (s e c d)
(loop
(case (pop c)
...
((ldct)
(push (list 'continuation s e (pop c) d) s))
...
((app)
(let ((clo (pop s)) (lvar (pop s)))
(case (pop clo)
((primitive)
(push (apply (car clo) lvar) s))
((continuation)
(setq s (cons (car lvar) (car clo))
e (cadr clo)
c (caddr clo)
d (cadddr clo)))
(t
(push (list s e c) d)
(setq s nil
e (cons lvar (cadr clo))
c (car clo))))))
...
)))
ldct は状態遷移をそのままプログラムしただけです。継続を実行する場合、継続に渡した引数 (1 個) が call/cc の返り値となります。SECD 仮想マシンの場合、返り値はスタックに積まれます。保存しておいた S, E, C, D レジスタの値を元に戻して、スタックに引数の値 (car lvar) を追加します。これでプログラムの実行を再開することができます。
最後に高階関数 apply を追加します。apply は継続のテストで使用します。apply は引数に特別な処理が必要になるので、仮想マシンに新しい命令 args-ap を追加します。コンパイルは次のようになります。
リスト : apply のコンパイル
(defun comp (expr env code)
...
((eq (car expr) 'apply)
(complis (cddr expr)
env
(list* 'args-ap
(length (cddr expr))
(comp (cadr expr) env (cons 'app code)))))
...
)
関数呼び出しの処理と同様に、complis で引数を評価するコードを生成します。このとき、引数は (cddr expr) になることに注意してください。そして、命令 args-ap のあとに、2 番目の引数 (cadr expr) を comp でコンパイルし、それを命令 app で呼び出します。
次は仮想マシン vm に命令 args-ap を追加します。
リスト : 命令 args-ap の追加
(defun vm (s e c d)
(loop
(case (pop c)
...
((args-ap)
(let ((a (copy-list (pop s))))
(dotimes (n (1- (pop c)) (push a s))
(push (pop s) a))))
...
)))
apply に与えられる最後の引数はリストです。args-ap は最後の引数の先頭に、今までの引数を追加して返します。このとき、最後の引数 (リスト) を copy-list でコピーしないと、可変個引数の関数を呼び出して引数の値を書き換えるときに不具合が発生します。
簡単な実行例を示します。
>>> (apply cons '(1 2)) (1 . 2) >>> (apply cons 1 '(2)) (1 . 2) >>> (define a '(1 2 3 4 5)) A >>> (define foo (lambda (a b . c) (set! a 10) (set! b 20) (set! c 30))) FOO >>> (apply foo a) 30 >>> a (1 2 3 4 5)
apply で関数 foo を呼び出すとき、最後の引数 (リスト) をコピーしないと、変数 a の値が (10 20 . 30) に書き換えられてしまいます。
最後に、継続のテストで使うため *global-environment* に関数 display と newline を追加します。これでプログラムの修正は完了です。
それでは実際に継続を使ってみましょう。なお、継続の実行例は拙作のページ Common Lisp で作る micro Scheme (3) で作成したプログラムとまったく同じです。インタプリタでもコンパイラでも継続の動作は同じになります。
>>> (define a false) A >>> (define list (lambda x x)) LIST >>> (list 'a 'b (call/cc (lambda (k) (set! a k) 'c)) 'd) (A B C D) >>> (a 'e) (A B E D) >>> (a 'f) (A B F D)
変数 a に取り出した継続をセットします。この場合、継続は (list a b [ ] 'd) になります。list の処理だけではなく、'd を評価する処理も残っています。継続 a に引数を渡して評価すると、[ ] の部分に継続の引数がセットされ、'd を評価して list に渡されます。したがって、(a 'e) を評価すると (a b e d) になり、(a 'f) を評価すると (a b f d) になります。
次は大域脱出を試してみましょう。
リスト : 大域脱出 (define bar1 (lambda (cont) (display "call bar1") (newline))) (define bar2 (lambda (cont) (display "call bar2") (newline) (cont false))) (define bar3 (lambda (cont) (display "call bar3") (newline))) (define test (lambda (cont) (bar1 cont) (bar2 cont) (bar3 cont)))
>>> (call/cc (lambda (cont) (test cont))) call bar1 call bar2 FALSE
bar2 からトップレベルへ脱出するので、bar3 は呼び出されていません。
当然ですが、繰り返しから脱出することもできます。次の例を見てください。
リスト : do から脱出する場合
(define find-do
(lambda (fn ls)
(call/cc
(lambda (k)
(do ((xs ls (cdr xs)))
((null? xs) false)
(if (fn (car xs)) (k (car xs))))))))
リスト ls から関数 fn が真を返す要素を探します。継続のテストということで、あえて do を使って実装しています。fn が真を返す場合、継続 k でその要素を返します。それでは実行してみましょう。
>>> (find-do (lambda (x) (eq? 'c x)) '(a b c d e)) C >>> (find-do (lambda (x) (eq? 'c x)) '(a b d e f)) FALSE
もちろん高階関数からも脱出することができます。
リスト : map から脱出する場合
(define map-check (lambda (fn chk ls)
(call/cc
(lambda (k)
(map (lambda (x) (if (chk x) (k '()) (fn x))) ls)))))
>>> (map-check (lambda (x) (cons x x)) (lambda (x) (eq? x 'e)) '(a b c d e f)) NIL >>> (map-check (lambda (x) (cons x x)) (lambda (x) (eq? x 'e)) '(a b c d f)) ((A . A) (B . B) (C . C) (D . D) (F . F))
関数 chk が真となる要素がある場合、処理を中断して空リストを返します。これも正常に動いていますね。
再帰呼び出しから脱出することも簡単です。
リスト : flatten の再帰呼び出しから脱出する場合
(define flatten (lambda (ls)
(call/cc
(lambda (cont)
(letrec ((flatten-sub
(lambda (ls)
(cond ((null? ls) '())
((not (pair? ls)) (list ls))
((null? (car ls)) (cont '()))
(else (append (flatten-sub (car ls))
(flatten-sub (cdr ls))))))))
(flatten-sub ls))))))
関数 flatten はリストを平坦化します。ただし、要素に空リストが含まれている場合は空リストを返します。flatten は継続 cont を取り出して局所関数 flatten-sub に渡します。flatten-sub は空リストを見つけたら継続 cont を評価します。そうすると、再帰呼び出しの処理は破棄されて flatten の処理に戻り、cont に渡した空リストが返り値となります。
>>> (flatten '(a (b (c (d . e) f) g) h)) (A B C D E F G H) >>> (flatten '(a (b (c (d () . e) f) g) h)) NIL
最後に、イテレータを生成する関数 make-iter を試してみます。
リスト : イテレータを生成する関数
(define make-iter (lambda (proc . args)
(letrec ((iter
(lambda (return)
(apply
proc
(lambda (x) ; 高階関数に渡す関数の本体
(set! return ; 脱出先継続の書き換え
(call/cc
(lambda (cont)
(set! iter cont) ; 継続の書き換え
(return x)))))
args)
;; 終了後は継続 return で脱出
(return false))))
(lambda ()
(call/cc
(lambda (cont) (iter cont)))))))
リスト : 木の高階関数
(define for-each-tree (lambda (fn ls)
(let loop ((ls ls))
(cond ((null? ls) '())
((pair? ls)
(loop (car ls))
(loop (cdr ls)))
(else (fn ls))))))
拙作のページ お気楽 Scheme プログラミング入門 継続と継続渡しスタイル で作成したプログラムと同じです。それでは実行してみましょう。
>>> (define a (make-iter for-each-tree '(a (b (c (d . e) f) g) h))) A >>> (a) A >>> (a) B >>> (a) C >>> (a) D >>> (a) E >>> (a) F >>> (a) G >>> (a) H >>> (a) FALSE
正常に動作していますね。
今回はここまでです。次回は「末尾再帰最適化」の実装に挑戦してみましょう。
;;;
;;; secd.lsp : SECD 仮想マシンによる Scheme コンパイラ
;;;
;;; (1) 基本機能の実装
;;; (2) 伝統的なマクロの実装
;;; (3) 継続の実装
;;;
;;; 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 variable ~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)))))
((eq (car expr) 'call/cc)
(list* 'ldct code 'args 1 (comp (cadr expr) env (cons 'app code))))
((eq (car expr) 'apply)
(complis (cddr expr)
env
(list* 'args-ap
(length (cddr expr))
(comp (cadr expr) env (cons 'app 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))
((ldct)
(push (list 'continuation s e (pop c) d) 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)))
(case (pop clo)
((primitive)
(push (apply (car clo) lvar) s))
((continuation)
(setq s (cons (car lvar) (car clo))
e (cadr clo)
c (caddr clo)
d (cadddr clo)))
(t
(push (list s e c) d)
(setq s nil
e (cons lvar (cadr clo))
c (car 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))))
((args-ap)
(let ((a (copy-list (pop s))))
(dotimes (n (1- (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)))
(list 'display 'primitive (lambda (x) (princ x) '*undef*))
(list 'newline 'primitive (lambda () (terpri) '*undef*))
))
;;;
;;; 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))))
(setf output (vm '() '() expr '()))
(princ output)
(terpri))
(simple-error (c) (format t "ERROR: ~a~%" c)))))
(setq *readtable* (copy-readtable nil))))