今回は micro Scheme コンパイラに「末尾再帰最適化」を実装しましょう。ここでいう末尾再帰最適化は処理速度のことではなく、次に示すような関数呼び出しにおいて、メモリを消費せずに実行できることです。
>>> (define foo (lambda () (foo))) FOO >>> (foo) => 無限ループになる
末尾再帰最適化が行われる場合、foo を評価すると無限ループになります。
末尾再帰の末尾とは最後に行われる処理のことで、一般に末尾で関数を呼び出すことを「末尾呼び出し」といいます。関数を呼び出す場合、そのあとに行う処理のために、必要な情報を保存しておかなければいけません。ところが、末尾呼び出しはそのあと実行する処理がないので、情報を保存しておく必要がありません。このため、末尾再帰は繰り返しに変換することができるのです。
簡単な例として、Common Lisp で階乗を計算する関数 fact を作りましょう。
リスト : 末尾再帰を繰り返しに変換する
(defun fact (x a)
(if (= x 0)
a
(fact (- x 1) (* a x))))
(defun facti (x a)
(tagbody
loop
(if (= x 0)
(return-from facti a))
(setf a (* a x)
x (- x 1))
(go loop)))
fact は末尾再帰になっています。これを繰り返しに変換すると facti のようになります。引数 x と a の値を保存する必要が無いので、値を書き換えてから先頭の処理へジャンプします。tagbody はジャンプ命令 go を使うための特殊形式 (シンタックス形式) です。Scheme に tagbody と go はありませんが、末尾再帰は最適化が行われるため効率的に処理することができます。
micro Scheme の場合、仮想マシン vm は繰り返し loop でプログラムしているので、vm の実行でメモリを消費することはありません。問題は命令 sel と app を実行するときです。たとえば、fact を micro Scheme でコンパイルすると次のようになります。
リスト : 階乗 (末尾再帰)
(define fact
(lambda (n a)
(if (= n 0)
a
(fact (- n 1) (* a n)))))
(CLOSURE
(
LD (0 . 0)
LDC 0
ARGS 2
LDG =
APP
SEL
(
LD (0 . 1)
JOIN
)
(
LD (0 . 0)
LDC 1
ARGS 2
LDG -
APP
LD (0 . 1)
LD (0 . 0)
ARGS 2
LDG *
APP
ARGS 2
LDG FACT
APP
JOIN
)
RTN
)
())
SECD 仮想マシンは sel 命令を実行するとき、コードレジスタ C をダンプに保存します。ここでメモリが消費されます。fact の場合、if は末尾呼び出しであり、その後の命令は rtn しかありません。この場合、join を rtn に変更すると、コードレジスタ C をダンプに保存する必要がなりなります。
そこで、仮想マシンに新しい命令 selr を追加します。selr の状態遷移を図に示します。
(v . s) e (selr ct cf . c) d = v (真) => s e ct d
= v (偽) => s e cf d
sel はコード c をダンプ d に保存します。selr 命令の場合、ct と cf が末尾呼び出しになるので、コード c をダンプに保存する必要はありません。また、ct と cf は join 命令ではなく rtn 命令で終了します。
selr 命令を使うと、fact は次のようにコンパイルされます。
(CLOSURE
(
LD (0 . 0)
LDC 0
ARGS 2
LDG =
APP
SELR
(
LD (0 . 1)
RTN
)
(
LD (0 . 0)
LDC 1
ARGS 2
LDG -
APP
LD (0 . 1)
LD (0 . 0)
ARGS 2
LDG *
APP
ARGS 2
LDG FACT
APP
RTN
)
)
())
ここで fact を呼び出す app 命令に注目してください。fact は末尾呼び出しで、その後に実行する命令は rtn しかありません。この場合、レジスタ S, E, C をダンプレジスタに保存する必要はありません。そこで、新しい命令 tapp を追加します。tapp の状態遷移を示します。
((closure code env) vs . s) e (tapp . c) d => s (vs . env) code d
app は s, e, c をダンプ d に保存します。tapp 命令の場合、実行する関数は末尾呼び出しになるので、s, e, c をダンプに保存する必要はありません。コード code を環境 (v . env) の元で評価するだけです。
このように、selr と tapp 命令を追加することで、micro Scheme でも末尾呼び出しの最適化を実現することができます。
それではプログラムを修正しましょう。S 式をコンパイルする関数 comp は次のようになります。
リスト : コンパイルの修正
(defun comp (expr env code tail)
(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)
(if tail
;; 末尾呼び出し
(let ((t-clause (comp (caddr expr) env '(rtn) t))
(f-clause
(if (null (cdddr expr))
(list 'ldc '*undef* 'join)
(comp (cadddr expr) env '(rtn) t))))
(comp (cadr expr) env (list* 'selr t-clause f-clause (cdr code)) nil))
(let ((t-clause (comp (caddr expr) env '(join) nil))
(f-clause
(if (null (cdddr expr))
(list 'ldc '*undef* 'join)
(comp (cadddr expr) env '(join) nil))))
(comp (cadr expr) env (list* 'sel t-clause f-clause code) nil))))
((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) nil))
((eq (car expr) 'define-macro)
(comp (caddr expr) env (list* 'defm (cadr expr) code) nil))
((eq (car expr) 'set!)
(let ((pos (location (cadr expr) env)))
(if pos
;; 局所変数
(comp (caddr expr) env (list* 'lset pos code) nil)
;; 大域変数
(comp (caddr expr) env (list* 'gset (cadr expr) code) nil))))
((eq (car expr) 'call/cc)
(list* 'ldct code 'args 1 (comp (cadr expr) env (cons 'app code) nil)))
((eq (car expr) 'apply)
(complis (cddr expr)
env
(list* 'args-ap
(length (cddr expr))
(comp (cadr expr) env (cons 'app code) nil))))
((macro-p (car expr))
;; マクロ展開してからコンパイルする
(let ((new-expr (vm '()
(list (cdr expr))
(get-macro-code (car expr))
(list (list '() '() '(stop))))))
(comp new-expr env code nil)))
(t ; 関数呼び出し
(complis (cdr expr)
env
(list* 'args
(length (cdr expr))
(comp (car expr) env (cons (if tail 'tapp 'app) code) nil))))))
comp の引数に末尾呼び出しを示すフラグ tail を追加します。tail が真の場合、引数 expr は末尾呼び出しです。tail が真になるときは、ラムダ式本体の最後尾の S 式をコンパイルするときと、tail が真のときに if の then 節と else 節をコンパイルするときです。あとはすべて nil になります。
if をコンパイルするとき、tail が偽の場合は今までと同じです。tail が真の場合、then 節と else 節をコンパイルするとき、tail に t を指定して、最後の命令を rtn にします。生成するコードは (list* 'selr t-clause f-clause (cdr code)) となります。このとき、code の先頭は rtn 命令になります。rtn が重複するので cdr で取り除きます。
関数呼び出しの場合、tail が真であれば命令を tapp に、そうでなければ app にします。tail が真の場合、code の先頭は rtn 命令になります。評価する関数がクロージャの場合、この rtn を削除することができますが、primitive の場合は rtn が必要になります。コンパイルの段階では区別がつかないので、rtn は削除しないでそのままにしておきます。
ラムダ式本体をコンパイルする関数 comp-body は簡単です。
リスト : ラムダ式本体のコンパイル
(defun comp-body (body env code)
(if (null (cdr body))
(comp (car body) env code t)
(comp (car body)
env
(list* 'pop
(comp-body (cdr body) env code))
nil)))
本体末尾の S 式をコンパイルするとき、comp の引数 tail を t にセットします。それ以外の場合は nil にセットします。
次は仮想マシン vm を修正します。
リスト : 仮想マシン vm の修正
(defun vm (s e c d)
(loop
(case (pop c)
...
((tapp)
(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
(setq e (cons lvar (cadr clo))
c (car clo))))))
...
((selr)
(let ((t-clause (pop c))
(e-clause (pop c)))
(setq c (if (eq (pop s) 'false) e-clause t-clause))))
...
)))
tapp の場合、primitive と continuation の処理は app と同じです。それ以外の場合はコード (car clo) を環境 (cons lvar (cadr clo)) の元で評価します。s, e, c をダンプ d に保存する必要はありません。selr も簡単です。then 節 (t-clause) と else 節 (e-clause) どちらを評価するにしても、ダンプ d にコード c を保存する必要はありません。
それでは簡単な実行例を示しましょう。なお、簡単にテストできるように、primitive に算術演算子 (+, -, *, /) と比較演算子 (=, <, >, <=, >=) を追加しました。簡単な例として 1 から x までの合計値を求めるプログラムを作ります。次のリストを見てください。
リスト : 1 から x までの合計値を求める
(define sum
(lambda (x)
(if (= x 0)
0
(+ x (sum (- x 1))))))
(define sum1
(lambda (x a)
(if (= x 0)
a
(sum1 (- x 1) (+ a x)))))
関数 sum は末尾再帰になっていないので、大きな値を計算するとメモリを大量に消費します。関数 sum1 は末尾再帰になっているので、大きな値でもメモリを消費せずに計算することができます。実行結果は次のようになりました。
>>> (sum 1000000) 500000500000 >>> (sum1 1000000 0) 500000500000
CLISP ver 2.44, Windows XP で実行した場合、どちらの関数でも値を求めることができますが、sum は sum1 よりも約 65 MB ほどメモリの消費量が多くなります。
また、次の関数を実行するとメモリを消費せずに無限ループとなります。
>>> (define foo (lambda () (foo))) FOO >>> (foo) => 無限ループになる
次は「たらいまわし関数」でインタプリタとコンパイラの実行速度を計測してみましょう。プログラムリストと実行結果を示します。
リスト : たらいまわし関数
(define tarai
(lambda (x y z)
(if (<= x y)
y
(tarai (tarai (- x 1) y z) (tarai (- y 1) z x) (tarai (- z 1) x y)))))
(define tak
(lambda (x y z)
(if (<= x y)
z
(tak (tak (- x 1) y z) (tak (- y 1) z x) (tak (- z 1) x y)))))
表 : たらいまわし関数の実行結果
: A : B
---------------+------+------
(tarai 12 6 0) : 16.1 : 15.4
(tak 16 8 0) : 3.2 : 2.9
A : インタプリタ (micro.l)
B : コンパイラ (secd.l)
単位 : 秒
SBCL (ver 1.4.5), Ubuntu 18.04 (WSL), Intel Core i5-6200U 2.30GHz
インタプリタ (micro.l) よりもコンパイラ (secd.l) の方がちょっとだけ速くなりました。予想していたよりもインタプリタの実行速度が速かったのには驚きました。SBCL はとても優秀ですね。インタプリタとコンパイラで実行速度にほとんど差がつきませんでしたが、マクロを多用したプログラムでは、もっと差がつくでしょう。
コンパイラの性能ですが、末尾呼び出し以外の最適化はほとんど行っていないので、改良する余地はまだまだあると思います。興味のある方はいろいろ試してみてください。
関数 tarai は「遅延評価 (delayed evaluation または lazy evaluation)」を行う処理系、たとえば関数型言語の Haskell では高速に実行することができます。また、Scheme でも delay と force を使って遅延評価を行うことができます。
tarai のプログラムを見てください。x <= y のときに y を返しますが、このとき引数 z の値は必要ありませんね。引数 z の値は x > y のときに計算するようにすれば、無駄な計算を省略することができます。なお、関数 tak は x <= y のときに z を返しているため、遅延評価で高速化することはできません。ご注意ください。
Scheme の delay と force は、micro Scheme でもマクロを使って簡単に実装することができます。次のリストを見てください。
リスト : delay と force
(define-macro delay
(lambda (expr)
`(make-promise (lambda () ,expr))))
(define make-promise
(lambda (f)
(let ((flag false) (result false))
(lambda ()
(if (not flag)
(let ((x (f)))
(if (not flag)
(begin (set! flag true)
(set! result x)))))
result))))
(define force
(lambda (promise) (promise)))
リストの delay と force は 参考文献 1 に掲載されているプログラムを micro Scheme で書き直したものです。delay の引数 expr をクロージャに格納して関数 make-promis に渡します。make-promise はクロージャを生成して返します。このデータを Scheme では「プロミス」といいます。force は簡単で、引数 promise を評価するだけです。
make-promise はクロージャを生成し、その中にクロージャ f の評価結果を格納します。flag が false の場合は f を評価していないので、f を評価して返り値を result にセットし、flag の値を true に書き換えます。flag が true ならば f は評価済みなので result を返します。
簡単な使用例を示しましょう。
>>> (define a (delay (+ 10 20))) A >>> (force a) 30
(delay (+ 10 20)) の返り値を変数 a にセットします。このとき、S 式 (+ 10 20) は評価されていません。プロミスの値を実際に求める関数が force です。(force a) を評価すると、S 式 (+ 10 20) を評価して値 30 を返します。
また、プロミスは式の評価結果をキャッシュします。したがって、(force a) を再度実行すると、同じ式を再評価することなく値を求めることができます。次の例を見てください。
>>> (define b (delay (begin (display "oops! ") (+ 10 20)))) B >>> (force b) oops! 30 >>> (force b) 30
最初に (force b) を実行すると、S 式 (begin (display "oops! ") (+ 10 20)) が評価されるので、画面に oops! が表示されます。次に、(force b) を実行すると、式を評価せずにキャッシュした値を返すので oops! は表示されません。
delay と force を使うと、tarai は次のようになります。
リスト : delay と force による遅延評価
(define tarai
(lambda (x y z)
(if (<= x y)
y
(let ((zz (force z)))
(tarai (tarai (- x 1) y (delay zz))
(tarai (- y 1) zz (delay x))
(delay (tarai (- zz 1) x (delay y))))))))
関数 tarai の引数 z にデータを渡すとき、delay で遅延オブジェクトを生成します。そして、その値を取り出すときは (force z) とします。これで遅延評価を行うことができます。
それでは、実際に実行してみましょう。
表 : たらいまわし関数の実行結果
(tarai 100 50 (delay 0))
| A | B
------+------+-------
SBCL : 0.36 | 0.029
A : インタプリタ (micro.l)
B : コンパイラ (secd.l)
単位 : 秒
SBCL (ver 1.4.5), Ubuntu 18.04 (WSL), Intel Core i5-6200U 2.30GHz
tarai に大きな値を与えても、高速に実行することができます。遅延評価の効果は十分に出ていると思います。また、インタプリタよりもコンパイラのほうが約 12 倍高速になりました。マクロを使ったプログラムは、コンパイラのほうが高速に実行できることがわかります。
;;;
;;; secd.lsp : SECD 仮想マシンによる Scheme コンパイラ
;;;
;;; (1) 基本機能の実装
;;; (2) 伝統的なマクロの実装
;;; (3) 継続の実装
;;; (4) 末尾再帰最適化
;;;
;;; Copyright (C) 2009-2021 Makoto Hiroi
;;;
;;; 関数宣言
(declaim (ftype (function (t list list t) 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) nil))
;;; body のコンパイル
(defun comp-body (body env code)
(if (null (cdr body))
(comp (car body) env code t)
(comp (car body)
env
(list* 'pop
(comp-body (cdr body) env code))
nil)))
;;; 引数を評価するコードを生成する
(defun complis (expr env code)
(if (null expr)
code
(comp (car expr) env (complis (cdr expr) env code) nil)))
;;; コンパイル本体
(defun comp (expr env code tail)
(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)
(if tail
;; 末尾呼び出し
(let ((t-clause (comp (caddr expr) env '(rtn) t))
(f-clause
(if (null (cdddr expr))
(list 'ldc '*undef* 'join)
(comp (cadddr expr) env '(rtn) t))))
(comp (cadr expr) env (list* 'selr t-clause f-clause (cdr code)) nil))
(let ((t-clause (comp (caddr expr) env '(join) nil))
(f-clause
(if (null (cdddr expr))
(list 'ldc '*undef* 'join)
(comp (cadddr expr) env '(join) nil))))
(comp (cadr expr) env (list* 'sel t-clause f-clause code) nil))))
((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) nil))
((eq (car expr) 'define-macro)
(comp (caddr expr) env (list* 'defm (cadr expr) code) nil))
((eq (car expr) 'set!)
(let ((pos (location (cadr expr) env)))
(if pos
;; 局所変数
(comp (caddr expr) env (list* 'lset pos code) nil)
;; 大域変数
(comp (caddr expr) env (list* 'gset (cadr expr) code) nil))))
((eq (car expr) 'call/cc)
(list* 'ldct code 'args 1 (comp (cadr expr) env (cons 'app code) nil)))
((eq (car expr) 'apply)
(complis (cddr expr)
env
(list* 'args-ap
(length (cddr expr))
(comp (cadr expr) env (cons 'app code) nil))))
((macro-p (car expr))
;; マクロ展開してからコンパイルする
(let ((new-expr (vm '()
(list (cdr expr))
(get-macro-code (car expr))
(list (list '() '() '(stop))))))
(comp new-expr env code nil)))
(t ; 関数呼び出し
(complis (cdr expr)
env
(list* 'args
(length (cdr expr))
(comp (car expr) env (cons (if tail 'tapp 'app) code) nil))))))
;;;
;;; 仮想マシン
;;;
;;; 局所変数の値を求める
(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))))))
((tapp)
(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
(setq 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))))
((selr)
(let ((t-clause (pop c))
(e-clause (pop c)))
(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*))
(list '+ 'primitive #'+)
(list '- 'primitive #'-)
(list '* 'primitive #'*)
(list '/ 'primitive #'/)
(list '= 'primitive (lambda (&rest x) (if (apply #'= x) 'true 'false)))
(list '< 'primitive (lambda (&rest x) (if (apply #'< x) 'true 'false)))
(list '> 'primitive (lambda (&rest x) (if (apply #'> x) 'true 'false)))
(list '<= 'primitive (lambda (&rest x) (if (apply #'<= x) 'true 'false)))
(list '>= 'primitive (lambda (&rest x) (if (apply #'>= 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))))
;; (time (setf output (vm '() '() expr '())))
(setf output (vm '() '() expr '()))
(princ output)
(terpri))
(simple-error (c) (format t "ERROR: ~a~%" c)))))
(setq *readtable* (copy-readtable nil))))