前回は fncalc のコンパイラを作成しました。今回は fncalc 用の SECD 仮想マシンを作成し、実際にプログラムを動かしてみましょう。
SECD 仮想マシンのプログラムは次のようになります。
リスト : SECD 仮想マシン
(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))
((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 (car clo)
((primitive)
; (primitive function)
(vm (cons (apply (cadr clo) lvar) (cddr s)) e (cdr c) d))
(else
; (closure code env)
(vm '()
(cons lvar (caddr clo))
(cadr 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)))))
プログラムリストは少々長いですが、やっていることは簡単です。関数 vm の引数 s がスタック、c がコード、e が局所変数の環境、d がダンプです。c の先頭からコードを取り出して case で分岐します。あとは命令にしたがって s, e, c. d の値を操作するだけです。
あとのプログラムは簡単なので説明は割愛します。詳細はプログラムリストをお読みください。
それでは実行してみましょう。
Calc> 1 + 2; => 3 Calc> 1 + 2 * 3 - 4; => 3 Calc> (1 + 2) * (3 - 4); => -3 Calc> begin print(1); print(2); print(3); end 1 2 3 => 3 Calc> if 1 < 2 then 3; else 4; end => 3 Calc> if 1 > 2 then 3; else 4; end => 4 Calc> if 1 > 2 then 3; end => 0
式文、if 文、begin 文は正しく動作しています。次は let 文と while 文を試してみましょう。
Calc> let a = 0 in a + 10; end => 10 Calc> let a = 1, b = 2 in a + b; end => 3 Calc> let a = 0, b = 0 in while a <= 10 do b = b + a; a = a + 1; end b; end => 55 Calc> begin a = b = 0; while a <= 10 do b = b + a; a = a + 1; end b; end => 55 Calc> b; => 55
let 文も while 文も正常に動作していますね。次は関数定義を試してみましょう。
Calc> def square(x) x * x; end => closure Calc> square(10); => 100 Calc> def fact(n) if n == 0 then 1; else n * fact(n - 1); end end => closure Calc> fact(8); => 40320 Calc> fact(9); => 362880 Calc> fact(10); => 3628800
これも正常に動作していますね。最後に匿名関数 (クロージャ) を試してみましょう。
Calc> fn(x) x * x; end; => closure Calc> fn(x) x * x; end(10); => 100 Calc> let a = fn(x) x * x; end in a(100); end => 10000 Calc> def makeAdder(x) fn(y) x + y; end; end => closure Calc> a = makeAdder(10); => closure Calc> a(10); => 20 Calc> a(100); => 110
クロージャも正常に動作していますね。ただし、局所関数で再帰呼び出しを行う場合は注意が必要です。次のリストを見てください。
リスト : 局所関数の再帰定義
# 階乗 (末尾再帰)
def fact(n)
let iter = 0 in
iter = fn(x, a)
if x == 0 then
a;
else
iter(x - 1, a * x);
end
end;
iter(n, 1);
end
end
let 文で局所変数を定義する場合、右辺の式を評価するとき、左辺の局所変数はまだ存在していません。左辺の式でその局所変数を使用することはできないのです。この場合、局所変数を適当な値で初期化しておき、let 文本体の中で局所変数の値を fn 式で書き換えるようにしてください。これで局所関数でも再帰呼び出しが可能になります。
それでは、実際に試してみましょう。
Calc> def fact(n)
let iter = 0 in
iter = fn(x, a)
if x == 0 then
a;
else
iter(x - 1, a * x);
end
end;
iter(n, 1);
end
end
=> closure
Calc> fact(9);
=> 362880
Calc> fact(10);
=> 3628800
Calc> fact(11);
=> 39916800
それではクロージャを使って「連結リスト」を作ってみましょう。Lisp / Scheme の場合、ラムダ式だけで cons, car, cdr を実現することができます。cons, car, cdr は次の関係が成り立ちます。
(eq? x (car (cons x y))) => #t (eq? y (cdr (cons x y))) => #t
実際に Gauche で実行してみると、次のようになります。
gosh[r7rs.user]> (define a 10) a gosh[r7rs.user]> (define b 20) b gosh[r7rs.user]> (eq? a (car (cons a b))) #t gosh[r7rs.user]> (eq? b (cdr (cons a b))) #t
ここで (cons x y) で生成したオブジェクトがコンスセルではない場合を考えてみましょう。もし、そのオブジェクトに car を適用すれば cons の第 1 引数 x を返し、cdr を適用すれば第 2 引数を返すことができれば、コンスセルと同じことが実現できます。そこで、cons はコンスセルではなくクロージャを返すことにしましょう。クロージャは引数 x, y の値を保持することができます。そして、このクロージャは引数に関数を受け取ることにします。あとは、この関数に引数 x, y を渡して評価すれば car と cdr を実現することができます。
Gauche でプログラムすると次のようになります。
gosh[r7rs.user]> (define (cons2 x y) (lambda (z) (z x y))) cons2 gosh[r7rs.user]> (define (car2 x) (x (lambda (a b) a))) car2 gosh[r7rs.user]> (define (cdr2 x) (x (lambda (a b) b))) cdr2 gosh[r7rs.user]> (car2 (cons2 'a 'b)) a gosh[r7rs.user]> (cdr2 (cons2 'a 'b)) b gosh[r7rs.user]> (define a (cons2 1 (cons2 2 (cons2 3 4)))) a gosh[r7rs.user]> (car2 a) 1 gosh[r7rs.user]> (car2 (cdr2 a)) 2 gosh[r7rs.user]> (car2 (cdr2 (cdr2 a))) 3 gosh[r7rs.user]> (cdr2 (cdr2 (cdr2 a))) 4
関数 cons2 はクロージャを返します。このクロージャは引数 z に関数を受け取り、その関数に x, y を渡して評価します。car2 は引数 x にクロージャを渡して評価し、第 1 引数 a を返します。これで car と同じ動作になります。同様に、cdr2 は引数 x にクロージャを渡して評価し、第 2 引数 b を返します。これで cdr と同じ動作になります。
クロージャをサポートしているプログラミング言語であれば、Lisp / Scheme と同じように cons, car, cdr を作ることができます。fncalc で cons, car, cdr をプログラムすると次のようになります。
リスト : 連結リストの基本関数 def cons(x, y) fn(z) z(x, y); end; end def car(z) z(fn(x, y) x; end); end def cdr(z) z(fn(x, y) y; end); end
それでは実際に試してみましょう。
Calc> def cons(x, y) fn(z) z(x, y); end; end => closure Calc> def car(z) z(fn(x, y) x; end); end => closure Calc> def cdr(z) z(fn(x, y) y; end); end => closure Calc> a = cons(1, 0); => closure Calc> car(a); => 1 Calc> cdr(a); => 0 Calc> b = cons(2, a); => closure Calc> car(b); => 2 Calc> cdr(b); => closure Calc> car(cdr(b)); => 1
このように、クロージャを使って連結リストを作成することができます。ご参考までに、簡単な連結リストライブラリとその実行例を示します。なお、データ型を判定するため、組み込み関数に述語 number, string, function を追加しています。
#
# list.cal : Linked List Library
#
# Copyright (C) 2011-2021 Makoto Hiroi
#
#
nil = "nil";
#
def null(x)
x eq nil;
end
def pair(x)
function(x);
end
def cons(x, y)
fn(z) z(x, y); end;
end
def car(z)
z(fn(x, y) x; end);
end
def cdr(z)
z(fn(x, y) y; end);
end
#
def append(xs, ys)
if null(xs) then
ys;
else
cons(car(xs), append(cdr(xs), ys));
end
end
def listref(xs, n)
if null(xs) then
nil;
else
if n == 0 then
car(xs);
else
listref(cdr(xs), n - 1);
end
end
end
def member(x, ls)
if null(ls) then
nil;
else
if car(ls) == x then
ls;
else
member(x, cdr(ls));
end
end
end
def remove(x, ls)
if null(ls) then
nil;
else
if x == car(ls) then
remove(x, cdr(ls));
else
cons(car(ls), remove(x, cdr(ls)));
end
end
end
#
def map(f, ls)
if null(ls) then
nil;
else
cons(f(car(ls)), map(f, cdr(ls)));
end
end
def filter(pred, ls)
if null(ls) then
nil;
else
if pred(car(ls)) then
cons(car(ls), filter(pred, cdr(ls)));
else
filter(pred, cdr(ls));
end
end
end
def foldl(f, a, ls)
if null(ls) then
a;
else
foldl(f, f(a, car(ls)), cdr(ls));
end
end
def foldr(f, a, ls)
if null(ls) then
a;
else
f(foldr(f, a, cdr(ls)), car(ls));
end
end
def foreach(f, ls)
if not null(ls) then
begin
f(car(ls));
foreach(f, cdr(ls));
end
end
end
#
def zip(xs, ys)
if null(xs) or null(ys) then
nil;
else
cons(cons(car(xs), car(ys)), zip(cdr(xs), cdr(ys)));
end
end
def flatten(ls)
if null(ls) then
nil;
else
if pair(ls) then
append(flatten(car(ls)), flatten(cdr(ls)));
else
cons(ls, nil);
end
end
end
def iota(n, m)
let a = nil in
while m >= n do
a = cons(m, a);
m = m - 1;
end
a;
end
end
#
def printlistsub(ls)
display("(");
while pair(ls) do
if pair(car(ls)) then
printlistsub(car(ls));
else
display(car(ls));
end
ls = cdr(ls);
if not null(ls) then display(" "); end
end
if not null(ls) then
begin
display(". ");
display(ls);
end
end
display(")");
end
def printlist(ls)
printlistsub(ls);
newline();
end
Calc> a = iota(1, 8); => closure Calc> printlist(a); (1 2 3 4 5 6 7 8) => 0 Calc> printlist(member(5, a)); (5 6 7 8) => 0 Calc> printlist(member(9, a)); () => 0 Calc> listref(a, 0); => 1 Calc> listref(a, 7); => 8 Calc> printlist(append(iota(1, 5), iota(6, 10))); (1 2 3 4 5 6 7 8 9 10) => 0 Calc> printlist(remove(5, a)); (1 2 3 4 6 7 8) => 0 Calc> printlist(map(fn(x) x * x; end, a)); (1 4 9 16 25 36 49 64) => 0 Calc> printlist(filter(fn(x) x % 2 == 0; end, a)); (2 4 6 8) => 0 Calc> foldl(fn(x, y) x + y; end, 0, a); => 36 Calc> foldr(fn(x, y) x + y; end, 0, a); => 36 Calc> foreach(print, a); 1 2 3 4 5 6 7 8 => 0 Calc> b = zip(iota(1, 5), iota(11, 15)); => closure Calc> printlist(b); ((1 . 11) (2 . 12) (3 . 13) (4 . 14) (5 . 15)) => 0 Calc> printlist(flatten(b)); (1 11 2 12 3 13 4 14 5 15) => 0
リストの終端を表すため変数 nil に文字列 "nil" をセットしましたが、これはクロージャを使ってもかまいません。
なお、このままでは CAR 部と CDR 部を破壊的に修正することはできません。set-car!, set-cdr! と同じ動作を実現する場合、cons が返すクロージャに値を書き換える処理を追加します。プログラムは次のようになるでしょう。
リスト : リストの破壊的な修正
def cons(x, y)
fn(n, v)
if n < 2 then
if n == 0 then
x; # car
else
y; # cdr
end
else
if n == 2 then
x = v; # setcar
else
y = v; # setcdr
end
end
end;
end
#
def car(z) z(0, 0); end
def cdr(z) z(1, 0); end
def setcar(z, v) z(2, v); end
def setcdr(z, v) z(3, v); end
#
def listset(xs, n, v)
if null(xs) then
nil;
else
if n == 0 then
setcar(xs, v);
else
listset(cdr(xs), n - 1, v);
end
end
end
クロージャの第 1 引数 n で実行する処理を指定します。0 が car, 1 が cdr です。2 が setcar で x の値を引数 v に書き換えます。3 が setcdr で y の値を v に書き換えます。あとは、関数 car, cdr, setcar, setcdr で適切な値を指定してクロージャを呼び出すだけです。あとのプログラムは修正しなくても大丈夫です。
簡単な実行例を示しましょう。
Calc> a = cons(1, 2); => closure Calc> printlist(a); (1 . 2) => 0 Calc> car(a); => 1 Calc> cdr(a); => 2 Calc> setcar(a, 10); => 10 Calc> car(a); => 10 Calc> setcdr(a, 20); => 20 Calc> cdr(a); => 20 Calc> printlist(a); (10 . 20) => 0 Calc> a = iota(1, 10); => closure Calc> printlist(a); (1 2 3 4 5 6 7 8 9 10) => 0 Calc> listset(a, 5, 100); => 100 Calc> listref(a, 5); => 100 Calc> printlist(a); (1 2 3 4 5 100 7 8 9 10) => 0
fncalc は簡単なプログラミング言語ですが、プログラムを標準入力から打ち込むだけではなく、ファイルから読み込むことができると便利です。そこで、ファイルからプログラムをロードする組み込み関数 load を作りましょう。load は関数 load-file を呼び出します。プログラムは次のようになります。
リスト : ファイルのロード
(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)))))))
引数 name にはファイル名を表す文字列を渡します。最初に、call-with-input-file でファイルをオープンします。次に、字句解析で使用する大域変数を局所変数 env に保存し、*input* をポート in に切り替えます。あとは、ファイルの終了までプログラムを読み込み、compile でコンパイルして vm で実行します。最後に、大域変数の値を元に戻します。途中でエラーが送出される場合もあるので、with-exception-handler を使っていることに注意してください。
あとは *global-environment* に (load . ,(lambda (name) (load-file name) 1)) を追加します。たとえば、連結リストライブラリのファイル名が list.cal とすると、次のようにプログラムをロードすることができます。
Calc> load("list.cal");
=> 1
Calc>
今回はここまでです。次回は「末尾再帰最適化」と「継続」を実装してみましょう。
;;;
;;; fncalc1.scm : 関数型電卓プログラム (R7RS-small 対応版)
;;;
;;; 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)
(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)))
((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 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))
((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 (car clo)
((primitive)
;; (primitive function)
(vm (cons (apply (cadr clo) lvar) (cddr s)) e (cdr c) d))
(else
;; (closure code env)
(vm '()
(cons lvar (caddr clo))
(cadr 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)