今回は fncalc に「継続 (continuation)」の機能を追加してみましょう。fncalc では、継続を取り出す関数を callcc とします。SECD 仮想マシンの場合、継続を導入するのはとても簡単です。継続の取得はレジスタ S, E, C, D を保存するだけでよいのです。継続を再開するのも保存しておいた各レジスタを元に戻すだけですみます。
それではプログラムを作りましょう。仮想マシンに継続を取得する命令 ldct を追加します。ldct の状態遷移を示します。
s e (ldct n . c) d => ((continuation s e (drop c n) d) . s) e c d
継続はリストで表します。先頭にシンボル continuation を付けて、その後ろに s, e, (drop c n), d を格納します。n は callcc のあとに実行するコードの位置で、callcc をコンパイルするときにセットされます。コード c には callcc の引数を評価して、それを呼び出す命令がセットされます。このとき、生成した継続が引数として渡されます。
callcc のコンパイルは次のようになります。
リスト : callcc のコンパイル
(define (factor env)
(case *token*
・・・・・省略・・・・・
((callcc)
;; 継続
(get-token)
(unless (eq? *token* 'lpar)
(compile-error "callcc: '(' expected"))
(get-token)
(let ((code (append (list 'args 1) (expression env) (list 'app))))
(unless (eq? *token* 'rpar)
(compile-error "callcc: invalid token"))
(get-token)
(append (list 'ldct (length code)) code)))
・・・・・省略・・・・・
(else
(compile-error "unexpected token"))))
callcc のあとに "(" があることを確認します。そうでなければエラーを送出します。次に、カッコの中を expression でコンパイルします。その値は関数になるはずなので、それに継続をひとつ渡して呼び出します。コードの前に命令 'args 1 と後ろに命令 app を付け加えます。そして、トークンが rpar であることを確認します。callcc のあとに実行される命令は、callcc をコンパイルしたあとに追加されます。したがって、ldct のあとの n は (length code) で求めることができます。あとは append でコードを組み立てて返すだけです。
次は仮想マシン vm を修正します。命令 ldct を追加して、継続を実行できるように命令 app を修正します。プログラムは次のようになります。
リスト : 仮想マシンに継続の処理を追加
(define (vm s e c d)
(case (car c)
・・・・・省略・・・・・
((ldct)
;; 継続
(vm (cons (list 'continuation s e (drop (cddr c) (cadr c)) d) s)
e
(cddr c)
d))
・・・・・省略・・・・・
((app)
(let ((clo (car s)) (lvar (cadr s)))
(case (pop! clo)
((primitive)
(vm (cons (apply (car clo) lvar) (cddr s)) e (cdr c) d))
((continuation)
(vm (cons (car lvar) (car clo)) (cadr clo) (caddr clo) (cadddr clo)))
(else
(vm '()
(cons lvar (cadr clo))
(car clo)
(cons (list (cddr s) e (cdr c)) d))))))
・・・・・省略・・・・・
))
ldct は状態遷移をそのままプログラムしただけです。継続を実行する場合、継続に渡した引数 (1 個) が callcc の返り値となります。SECD 仮想マシンの場合、返り値はスタックに積まれます。保存しておいた S, E, C, D レジスタの値を元に戻して、スタックに引数の値 (car lvar) を追加します。これでプログラムの実行を再開することができます。
それでは実際に継続を使ってみましょう。
Calc> callcc(fn(cont) cont; end); => continuation Calc> 1 + 2 * callcc(fn(cont) 3; end); => 7 Calc> 1 + 2 * callcc(fn(cont) cont(4); 3; end); => 9
最初の例では cont をそのまま返しているので、callcc の返り値は取り出された継続になります。次の例を見てください。callcc によって取り出される継続 cont は、callcc の返り値を 2 倍して、その結果に 1 を加えるという処理になります。callcc の返り値を X とすると、継続は 1 + 2 * X という式で表すことができます。匿名関数では継続を実行せずに 3 をそのまま返しているので、1 + 2 * X をそのまま計算して値は 7 になります。
最後の例では、匿名関数の中で cont(4) を実行しています。継続を評価しているので、現在の処理を破棄して、取り出した継続 1 + 2 * X を実行します。したがって、ブロックで cont(4) の後ろにある 3 を返す処理は実行されません。X の値は cont(4) の引数 4 になるので、1 + 2 * 4 を評価して値は 9 になります。
継続を変数に保存しておいて、あとから実行することもできます。次の例を見てくください。
Calc> 1 + 2 * callcc(fn(cont) a = cont; 3; end); => 7 Calc> a(10); => 21 Calc> a(100); => 201
匿名関数の中で取り出した継続 cont をグローバル変数 a にセットします。保存された継続 a で行う処理は 1 + 2 * X です。a(10) は 1 + 2 * 10 を計算して値は 21 になります。同様に、a(100) は 1 + 2 * 100 を計算して値は 201 になります。
次は大域脱出を試してみましょう。
Calc> def bar1(cont) print("call bar1"); end
=> closure
Calc> def bar2(cont) print("call bar2"); cont(0); end
=> closure
Calc> def bar3(cont) print("call bar3"); end
=> closure
Calc> def test(cont) bar1(cont); bar2(cont); bar3(cont); end
=> closure
Calc> callcc(fn(cont) test(cont); end);
call bar1
call bar2
=> 0
Calc> callcc(test);
call bar1
call bar2
=> 0
bar2 からトップレベルへ脱出するので、bar3 は呼び出されていません。これも正常に動作していますね。
繰り返しの中断も簡単です。次のように callcc で脱出することができます。
Calc> callcc(fn(br)
let n = 0 in
while n < 10 do
if n > 5 then br(0); end
print(n);
n = n + 1;
end
end
end);
0
1
2
3
4
5
=> 0
このように、br に格納された継続を評価すれば、繰り返しを途中で中断することができます。また、二重ループからの脱出も簡単です。簡単な例を示します。
Calc> callcc(fn(br)
let i = 0 in
while i < 5 do
let j = 0 in
while j < 5 do
display(i);
print(j);
if i + j > 5 then br(0); end
j = j + 1;
end
end
i = i + 1;
end
end
end);
00
01
02
03
04
10
11
12
13
14
20
21
22
23
24
=> 0
高階関数の処理を途中で中断することも簡単にできます。たとえば、連結リストの要素をチェックし、不適当な要素を見つけた場合は nil を返すマップ関数 map_check を作ってみましょう。プログラムは次のようになります。
Calc> def map_check(pred, f, ls)
callcc(fn(br)
map(fn(x) if pred(x) then br(nil); end f(x); end, ls);
end);
end
=> closure
Calc> a = iota(1, 10);
=> closure
Calc> printlist(map_check(fn(x) x > 10; end, fn(x) x * x; end, a));
1 4 9 16 25 36 49 64 81 100
=> 0
Calc> map_check(fn(x) x > 5; end, fn(x) x * x; end, a);
=> nil
要素をチェックする述語は引数 pred に渡します。pred が真を返す場合は継続 br を実行して nil を返します。
再帰呼び出しから脱出することも簡単です。
リスト : flatten の再帰呼び出しから脱出する場合
def flatten1(ls)
callcc(fn(br)
let flat = 0 in
flat = fn(ls)
if null(ls) then
nil;
else
if pair(ls) then
if null(car(ls)) then
br(nil);
else
append(flat(car(ls)), flat(cdr(ls)));
end
else
cons(ls, nil);
end
end
end;
flat(ls);
end
end);
end
リストを平坦化する関数 flatten で、要素に nil が含まれている場合は nil を返します。
Calc> a = cons(1, cons(2, cons(nil, cons(3, nil)))); => closure Calc> printlist(a); (1 2 nil 3) => 0 Calc> b = cons(10, cons(11, cons(12, cons(13, nil)))); => closure Calc> printlist(b); (10 11 12 13) => 0 Calc> c = zip(a, b); => closure Calc> printlist(c); ((1 . 10) (2 . 11) (nil . 12) (3 . 13)) => 0 Calc> printlist(flatten(c)); (1 10 2 11 12 3 13) => 0 Calc> printlist(flatten1(c)); () => 0
これも正常に動作しています。
最後に、ジェネレータを生成する関数 make_gen を試してみます。
リスト : ジェネレータを生成する関数
def make_gen(proc, ls)
let resume = 0 in
resume = fn(ret)
proc(fn(x) ret = callcc(fn(cont) resume = cont; ret(x); end); end, ls);
ret(nil);
end;
fn() callcc(fn(cont) resume(cont); end); end;
end
end
プログラムの内容は拙作のページ 継続と継続渡しスタイル で作成した関数 make-iter と同じです。それでは実行してみましょう。
Calc> a = iota(1, 8); => closure Calc> g = make_gen(foreach, a); => closure Calc> g(); => 1 Calc> g(); => 2 Calc> g(); => 3 Calc> g(); => 4 Calc> g(); => 5 Calc> g(); => 6 Calc> g(); => 7 Calc> g(); => 8 Calc> g(); => nil
正常に動作していますね。次に示すように、make_gen は順列を生成する関数 perm に適用することも可能です。
リスト : 順列の生成
def perm(f, ls)
let iter = 0 in
iter = fn(ls, a)
if null(ls) then
f(a);
else
foreach(fn(x) iter(remove(x, ls), cons(x, a)); end, ls);
end
end;
iter(ls, nil);
end
end
Calc> perm(printlist, iota(1, 3)); (3 2 1) (2 3 1) (3 1 2) (1 3 2) (2 1 3) (1 2 3) => 0 Calc> g = make_gen(perm, iota(1, 3)); => closure Calc> printlist(g()); (3 2 1) => 0 Calc> printlist(g()); (2 3 1) => 0 Calc> printlist(g()); (3 1 2) => 0 Calc> printlist(g()); (1 3 2) => 0 Calc> printlist(g()); (2 1 3) => 0 Calc> printlist(g()); (1 2 3) => 0 Calc> printlist(g()); () => 0
今回はここまでです。次回は fncalc に「末尾再帰最適化」を実装してみましょう。
;;;
;;; fcalc2.scm : 関数型電卓プログラム (R7RS-samll 対応版)
;;;
;;; Copyright (C) 2011-2021 Makoto Hiroi
;;;
(import (scheme base) (scheme cxr) (scheme char) (scheme inexact)
(scheme bitwise) (scheme file) (scheme read) (scheme write))
;;;
;;; マクロ定義
;;;
;;; 多値は考慮しない簡略版
(define-syntax begin0
(syntax-rules ()
((_ a) a)
((_ a b ...) (let ((x a)) (begin b ...) x))))
;;; データの追加
(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 *ch* #f)
(define *token* #f)
(define *value* #f)
(define *input* (current-input-port))
(define *line* #f)
(define *col* #f)
;;;
;;; グローバルな環境
;;;
(define *global-environment*
`((exp primitive ,exp)
(log primitive ,log)
(sin primitive ,sin)
(cos primitive ,cos)
(tan primitive ,tan)
(asin primitive ,asin)
(acos primitive ,acos)
(atan primitive ,atan)
(sqrt primitive ,sqrt)
(expt primitive ,expt)
(number primitive ,(lambda (x) (if (number? x) 1 0)))
(string primitive ,(lambda (x) (if (string? x) 1 0)))
(function primitive ,(lambda (x) (if (pair? x) 1 0)))
(load primitive ,(lambda (x) (load-file x) 1))
(display primitive ,(lambda (x) (display (if (pair? x) (car x) x)) x))
(newline primitive ,(lambda () (newline) 0))
(print primitive ,(lambda (x) (display (if (pair? x) (car x) x)) (newline) x))))
;;; 大域変数を求める
(define (get-gvar sym)
(let ((val (assoc sym *global-environment*)))
(unless val
(set! val (cons sym 0))
(push! *global-environment* val))
val))
;;;
;;; 入力処理
;;;
;;; 文字の読み込み
(define (nextch)
(set! *ch* (read-char *input*))
(cond ((eof-object? *ch*)
(set! *ch* #\null))
((eqv? *ch* #\newline)
(set! *line* (+ *line* 1))
(set! *col* 0))
(else
(set! *col* (+ *col* 1)))))
;;; コンパイルエラー
(define (compile-error mes)
(error mes *token* *line* *col*))
;;; 先読み記号の取得
(define (getch) *ch*)
;;; 数値
(define (get-number)
(let ((buff '()))
;; 整数を buff に格納
(define (get-numeric)
(do ()
((not (char-numeric? (getch))))
(push! buff (getch))
(nextch)))
;; 整数部
(get-numeric)
(case (getch)
((#\.)
;; 小数部
(push! buff (getch))
(nextch)
(get-numeric)
(case (getch)
((#\d #\D #\e #\E)
;; 指数部
(push! buff (getch))
(nextch)
(when (or (eqv? (getch) #\+)
(eqv? (getch) #\-))
(push! buff (getch))
(nextch))
;; 指数の数字
(get-numeric))))
((#\/)
;; 分数
(push! buff (getch))
(nextch)
(get-numeric)))
(string->number (list->string (reverse buff)))))
;;; 識別子
(define (get-ident)
(let loop ((a '()))
(if (and (not (char-alphabetic? (getch)))
(not (char-numeric? (getch)))
(not (eqv? (getch) #\_)))
(string->symbol (list->string (reverse a)))
(loop (begin0 (cons (getch) a) (nextch))))))
;;; 文字列
(define (escape-code c)
(case c
((#\t) #\tab)
((#\n) #\newline)
(else c)))
(define (get-string)
(nextch)
(let loop ((buff '()))
(cond ((eqv? (getch) #\")
(nextch)
(list->string (reverse buff)))
((eqv? (getch) #\\)
;; エスケープ記号
(nextch)
(loop (begin0 (cons (escape-code (getch)) buff) (nextch))))
(else
(loop (begin0 (cons (getch) buff) (nextch)))))))
;;; トークンの切り出し
(define (get-token)
;; 空白文字の読み飛ばし
(do ()
((not (char-whitespace? (getch))))
(nextch))
(cond ((char-numeric? (getch))
(set! *token* 'number)
(set! *value* (get-number)))
((char-alphabetic? (getch))
(set! *value* (get-ident))
(case *value*
((def end if then else and or not while do begin let in fn eq callcc)
(set! *token* *value*))
(else
(set! *token* 'ident))))
(else
(case (getch)
((#\#)
;; コメントの読み飛ばし
(do ()
((eqv? (getch) #\newline))
(nextch))
(get-token))
((#\")
;; 文字列
(set! *token* 'string)
(set! *value* (get-string)))
((#\=)
(set! *token* '=)
(nextch)
(when (eqv? (getch) #\=)
(set! *token* '==)
(nextch)))
((#\+)
(set! *token* '+)
(nextch))
((#\-)
(set! *token* '-)
(nextch))
((#\*)
(set! *token* '*)
(nextch))
((#\%)
(set! *token* '%)
(nextch))
((#\/)
(set! *token* '/)
(nextch))
((#\()
(set! *token* 'lpar)
(nextch))
((#\))
(set! *token* 'rpar)
(nextch))
((#\<)
(set! *token* '<)
(nextch)
(when (eqv? (getch) #\=)
(set! *token* '<=)
(nextch)))
((#\>)
(set! *token* '>)
(nextch)
(when (eqv? (getch) #\=)
(set! *token* '>=)
(nextch)))
((#\!)
(set! *token* 'not)
(nextch)
(when (eqv? (getch) #\=)
(set! *token* '!=)
(nextch)))
((#\,)
(set! *token* 'comma)
(nextch))
((#\;)
(set! *token* 'semic)
(nextch))
((#\null)
(set! *token* 'eof))
(else
(set! *token* 'others))))))
;;;
;;; 式の評価
;;;
(define (expression env)
(let ((val (expr1 env)))
(case *token*
((=)
(get-token)
(case (car val)
((ld)
;; 局所変数の代入
(append (expression env) (list 'lset (cadr val))))
((ldg)
;; 大域変数の代入
(append (expression env) (list 'gset (cadr val))))
(else
(compile-error "invalid assignment form"))))
(else val))))
;;; 論理演算子 (and と or の優先順位は同じとする)
(define (expr1 env)
(let loop ((val1 (expr2 env)))
(case *token*
((and)
(get-token)
(loop (append val1 (expr2 env) (list 'and))))
((or)
(get-token)
(loop (append val1 (expr2 env) (list 'or))))
(else val1))))
;;; 比較演算子 (==, !=, <, <=, >, >= の優先順位は同じとする)
(define (expr2 env)
(let ((val1 (expr3 env)))
(case *token*
((==)
(get-token)
(append val1 (expr3 env) (list '==)))
((!=)
(get-token)
(append val1 (expr3 env) (list '!=)))
((<)
(get-token)
(append val1 (expr3 env) (list '<)))
((<=)
(get-token)
(append val1 (expr3 env) (list '<=)))
((>)
(get-token)
(append val1 (expr3 env) (list '>)))
((>=)
(get-token)
(append val1 (expr3 env) (list '>=)))
((eq)
(get-token)
(append val1 (expr3 env) (list 'eq)))
(else val1))))
(define (expr3 env)
(let loop ((val (term env)))
(case *token*
((+)
(get-token)
(loop (append val (term env) (list '+))))
((-)
(get-token)
(loop (append val (term env) (list '-))))
(else val))))
;;; 項
(define (term env)
(let loop ((val (factor env)))
(case *token*
((*)
(get-token)
(loop (append val (factor env) (list '*))))
((/)
(get-token)
(loop (append val (factor env) (list '/))))
((%)
(get-token)
(loop (append val (factor env) (list '%))))
(else val))))
;;; 実引数のコンパイル
(define (compile-argument env)
(get-token)
(if (eq? *token* 'rpar)
(begin (get-token) (list 'args 0))
(let loop ((n 1) (a '()))
(let ((expr (expression env)))
(case *token*
((rpar)
(get-token)
(append (append a expr) (list 'args n)))
((comma)
(get-token)
(loop (+ n 1) (append a expr)))
(else
(compile-error "unexpected token")))))))
;;; 仮引数の取得
(define (get-parameter)
(get-token)
(unless (eq? *token* 'lpar)
(compile-error "'(' expected"))
(get-token)
(let loop ((a '()))
(let ((val *value*))
(case *token*
((rpar)
(get-token)
(reverse a))
((ident)
(let ((val *value*))
(get-token)
(loop (cons val a))))
((comma)
(get-token)
(loop a))
(else
(compile-error "unexpected token"))))))
;;; 位置を求める
(define (position var ls)
(let loop ((i 0) (ls ls))
(cond ((null? ls) #f)
((eqv? var (car ls)) i)
(else
(loop (+ i 1) (cdr ls))))))
;;; フレームと局所変数の位置を求める
(define (location var ls)
(let loop ((i 0) (ls ls))
(if (null? ls)
#f
(let ((j (position var (car ls))))
(if j
(cons i j)
(loop (+ i 1) (cdr ls)))))))
;;; 因子
(define (factor env)
(case *token*
((lpar)
(get-token)
(begin0
(expression env)
(if (eq? *token* 'rpar)
(get-token)
(compile-error "')' expected"))))
((number)
(begin0 (list 'ldc *value*) (get-token)))
((string)
(begin0 (list 'ldc *value*) (get-token)))
((not)
(get-token)
(append (factor env) (list 'not)))
((+)
;; 単項演算子 (+ をはずすだけ)
(get-token)
(factor env))
((-)
;; 単項演算子
(get-token)
(append (factor env) (list 'neg)))
((fn)
;; クロージャの生成
(let ((code (list 'ldf
(append (compile-block (cons (get-parameter) env))
(list 'rtn)))))
(get-token)
(if (eq? *token* 'lpar)
;; 関数呼び出し
(append (compile-argument env) code (list 'app))
code)))
((callcc)
;; 継続 callcc(f)
;; ldct next args 1 引数 f の評価 app next ...
(get-token)
(unless (eq? *token* 'lpar)
(compile-error "callcc: '(' expected"))
(get-token)
(let ((code (append (list 'args 1) (expression env) (list 'app))))
(unless (eq? *token* 'rpar)
(compile-error "callcc: invalid token"))
(get-token)
(append (list 'ldct (length code)) code)))
((ident)
(let ((code #f)
(pos (location *value* env)))
(if pos
;; 局所変数
(set! code (list 'ld pos))
;; 大域変数
(set! code (list 'ldg (get-gvar *value*))))
(get-token)
(if (eq? *token* 'lpar)
;; 関数呼び出し
(append (compile-argument env) code (list 'app))
;; 変数
code)))
(else
(compile-error "unexpected token"))))
;;; if 文のコンパイル
(define (compile-if env)
(let ((test-form (expression env))
(then-form #f)
(else-form #f))
(unless (eq? *token* 'then)
(compile-error "if: then expected"))
(get-token)
(set! then-form (append (compile-statement env) (list 'join)))
(get-token) ; end, semic を読み飛ばす
(if (eq? *token* 'else)
(begin (get-token)
(set! else-form
(append (begin0 (compile-statement env)
(get-token)) ; end, semic を読み飛ばす
(list 'join))))
(set! else-form (list 'ldc 0 'join)))
(unless (eq? *token* 'end)
(compile-error "if: end expected"))
(append test-form (list 'sel then-form else-form))))
;;; while 文のコンパイル
(define (compile-while env)
(let ((test (expression env))
(body #f))
(unless (eq? *token* 'do)
(compile-error "while: do expected"))
(get-token)
(set! body (append (compile-block env) (list 'rpt)))
(append (list 'bgn) test (list 'whl) (list body))))
;;; block 文のコンパイル
(define (compile-block env)
(let loop ((code '()))
(let ((code1 (compile-statement env)))
(get-token) ; 実行文の終端 (semic, end) を読み飛ばす
(cond ((eq? *token* 'end)
(append code code1))
(else
(loop (append code code1 (list 'pop))))))))
;;; let 文のコンパイル
(define (compile-let env)
(let loop ((vars '()) (code '()))
(cond ((eq? *token* 'in)
(get-token)
;; 本体コードの生成
(append code
(list 'args
(length vars)
'ldf
(append (compile-block (cons (reverse vars) env))
(list 'rtn))
'app)))
((eq? *token* 'ident)
(let ((var *value*))
(get-token)
(unless (eq? *token* '=)
(compile-error "let: invalid assignment form"))
(get-token)
(loop (cons var vars) (append code (expr1 env)))))
((eq? *token* 'comma)
(get-token)
(loop vars code))
(else
(compile-error "let: unexpected token")))))
;;; 実行文のコンパイル
(define (compile-statement env)
(case *token*
((begin)
(get-token)
(compile-block env))
((if)
(get-token)
(compile-if env))
((while)
(get-token)
(compile-while env))
((let)
(get-token)
(compile-let env))
(else
;; 式文
(begin0
(expression env)
(unless (eq? *token* 'semic)
(compile-error "';' expected"))))))
;;; コンパイル
(define (compile)
(cond ((eq? *token* 'def)
;; 関数定義
(get-token)
(unless (eq? *token* 'ident)
(compile-error "invalid def form"))
(let ((name *value*)
(code (append (compile-block (list (get-parameter)))
(list 'rtn))))
(list 'ldf code 'gset (get-gvar name))))
(else
(compile-statement '()))))
;;;
;;; 仮想マシン
;;;
;;;
(define (drop ls n)
(if (or (zero? n) (null? ls))
ls
(drop (cdr ls) (- n 1))))
;;; 局所変数の値を求める
(define (get-lvar e i j)
(list-ref (list-ref e i) j))
;;; 局所変数の値を更新する
(define (set-lvar! e i j val)
(set-car! (drop (list-ref e i) j) val))
(define (vm s e c d)
(case (car c)
((+)
(vm (cons (+ (cadr s) (car s)) (cddr s)) e (cdr c) d))
((-)
(vm (cons (- (cadr s) (car s)) (cddr s)) e (cdr c) d))
((*)
(vm (cons (* (cadr s) (car s)) (cddr s)) e (cdr c) d))
((/)
(vm (cons (/ (cadr s) (car s)) (cddr s)) e (cdr c) d))
((%)
(vm (cons (modulo (cadr s) (car s)) (cddr s)) e (cdr c) d))
((==)
(vm (cons (if (= (cadr s) (car s)) 1 0) (cddr s)) e (cdr c) d))
((!=)
(vm (cons (if (= (cadr s) (car s)) 0 1) (cddr s)) e (cdr c) d))
((<)
(vm (cons (if (< (cadr s) (car s)) 1 0) (cddr s)) e (cdr c) d))
((<=)
(vm (cons (if (<= (cadr s) (car s)) 1 0) (cddr s)) e (cdr c) d))
((<)
(vm (cons (if (< (cadr s) (car s)) 1 0) (cddr s)) e (cdr c) d))
((<=)
(vm (cons (if (<= (cadr s) (car s)) 1 0) (cddr s)) e (cdr c) d))
((>)
(vm (cons (if (> (cadr s) (car s)) 1 0) (cddr s)) e (cdr c) d))
((>=)
(vm (cons (if (>= (cadr s) (car s)) 1 0) (cddr s)) e (cdr c) d))
((eq)
(vm (cons (if (eqv? (cadr s) (car s)) 1 0) (cddr s)) e (cdr c) d))
((and)
(vm (cons (if (zero? (bitwise-and (cadr s) (car s))) 0 1) (cddr s)) e (cdr c) d))
((or)
(vm (cons (if (zero? (bitwise-ior (cadr s) (car s))) 0 1) (cddr s)) e (cdr c) d))
((neg)
(vm (cons (- (car s)) (cdr s)) e (cdr c) d))
((not)
(vm (cons (if (zero? (car s)) 1 0) (cdr s)) e (cdr c) d))
((ld)
(let ((pos (cadr c)))
(vm (cons (get-lvar e (car pos) (cdr pos)) s) e (cddr c) d)))
((ldc)
(vm (cons (cadr c) s) e (cddr c) d))
((ldg)
;; c = (ldg (sym . val) ...)
(vm (cons (cdr (cadr c)) s) e (cddr c) d))
((ldf)
(vm (cons (list 'closure (cadr c) e) s) e (cddr c) d))
((ldct)
;; 継続
(vm (cons (list 'continuation s e (drop (cddr c) (cadr c)) d) s)
e
(cddr c)
d))
((lset)
(let ((pos (cadr c)))
(set-lvar! e (car pos) (cdr pos) (car s))
(vm s e (cddr c) d)))
((gset)
;; c = (gset (sym . val) ...)
(set-cdr! (cadr c) (car s))
(vm s e (cddr c) d))
((app)
(let ((clo (car s)) (lvar (cadr s)))
(case (pop! clo)
((primitive)
;; (primitive function)
(vm (cons (apply (car clo) lvar) (cddr s)) e (cdr c) d))
((continuation)
(vm (cons (car lvar) (car clo)) (cadr clo) (caddr clo) (cadddr clo)))
(else
;; (closure code env)
(vm '()
(cons lvar (cadr clo))
(car clo)
(cons (list (cddr s) e (cdr c)) d))))))
((rtn)
(let ((save (car d)))
(vm (cons (car s) (car save)) (cadr save) (caddr save) (cdr d))))
((sel)
(let ((t-clause (cadr c))
(e-clause (caddr c)))
(if (zero? (car s))
(vm (cdr s) e e-clause (cons (cdddr c) d))
(vm (cdr s) e t-clause (cons (cdddr c) d)))))
((join)
(vm s e (car d) (cdr d)))
((pop)
(vm (cdr s) e (cdr c) d))
((args)
(let loop ((n (cadr c)) (a '()))
(if (zero? n)
(vm (cons a s) e (cddr c) d)
(loop (- n 1) (cons (pop! s) a)))))
((bgn)
(vm s e (cdr c) (cons (cdr c) d)))
((whl)
(if (zero? (car s))
(vm (cons 0 (cdr s)) e (cddr c) (cdr d))
(vm (cdr s) e (cadr c) d)))
((rpt)
(vm (cdr s) e (car d) d))
((halt)
(car s))
(else
(error "vm: unexpected code:" (car c)))))
;;; ファイルのロード
(define (load-file name)
(define (restore-env xs)
(set! *input* (list-ref xs 0))
(set! *token* (list-ref xs 1))
(set! *value* (list-ref xs 2))
(set! *ch* (list-ref xs 3))
(set! *line* (list-ref xs 4))
(set! *col* (list-ref xs 5)))
(call-with-input-file name
(lambda (in)
(let ((env (list *input* *token* *value* *ch* *line* *col*)))
(set! *input* in)
(set! *line* 1)
(set! *col* 0)
(nextch)
(with-exception-handler
(lambda (err) (restore-env env))
(lambda ()
(let loop ()
(get-token)
(when (not (eq? *token* 'eof))
(vm '() '() (append (compile) (list 'halt)) '())
(loop)))
(restore-env env)))))))
;;; 入力をクリアする
(define (clear-input-data)
(do ()
((eqv? *ch* #\newline))
(nextch)))
;;; プロンプトの表示
(define (prompt)
(display "Calc> ")
(flush-output-port)
(set! *line* 0)
(set! *col* 0))
(define (calc)
(prompt)
(nextch)
(call/cc
(lambda (break)
(let loop ()
(guard (err
(else (display "ERROR: ")
(display (error-object-message err))
(unless
(null? (error-object-irritants err))
(display (error-object-irritants err)))
(newline)
(clear-input-data)))
(get-token)
(when (eqv? *token* 'eof) (break #t))
(let ((val (vm '() '() (append (compile) (list 'halt)) '())))
(display "=> ")
(display (if (pair? val) (car val) val))
(newline)))
(prompt)
(loop)))))
;;; 実行
(calc)