今まで作成した micro Scheme コンパイラは、命令 ldg, gset で大域変数にアクセスするとき、大域変数の環境 *global-environment* を関数 assoc で線形探索していました。プログラムの実行時に探索を行うと、実行時間はどうしても遅くなります。コンパイル時に大域変数の配置を決めておくと、実行時間はもう少し速くなると思われます。
micro Scheme コンパイラで一番簡単な修正方法は、コンパイル時に変数 sym を環境 *global-environment* から探索し、見つけた場合は sym ではなくセル (sym . value) を ldg, gset 命令に渡すようにコンパイルすることです。そうすると、ldg はセルの CDR 部の値 value をスタックに積むだけ、gset はセルの CDR 部をスタックトップの値に書き換えるだけで実現できます。
変数 sym が見つからない場合、セル (sym . *undef*) を生成して環境に追加することにします。*undef* は未束縛の変数であることを表すシンボルとして使います。これで define, define-macro を処理する命令 def, defm に対応することができます。*undef* のチェックは ldg, gset 命令で行えばいいでしょう。もちろん、コンパイル時にエラーチェックしてもかまいませんが、今回は簡単な方法を選びました。
それではプログラムを修正しましょう。最初に、環境から大域変数を格納したセルを求める関数 location-gvar を作ります。
リスト : 大域変数の配置を求める
;;; 大域変数の配置を求める
(defun location-gvar (expr)
(let ((cell (assoc expr *global-environment*)))
(unless cell
(setq cell (cons expr '*undef*))
(push cell *global-environment*))
cell))
;;; 大域変数の値を求める
(defun get-gvar (expr)
(cdr (location-gvar expr)))
location-gvar は環境 *global-environment* から引数 expr を assoc で探索します。見つからない場合、(cons expr '*undef*) で expr 用のセルを生成し、それを環境に追加します。最後にそのセル cell を返します。関数 get-gvar は大域変数 expr の値を返します。location-gvar でセルを求め、その CDR 部の値を返します。
次はコンパイル処理を修正します。次のリストを見てください。
リスト : コンパイラの修正
・・・・・
((symbolp expr)
(let ((pos (location expr env)))
(if pos
;; 局所変数
(list* 'ld pos code)
;; 大域変数
(list* 'ldg (location-gvar expr) code))))
・・・・・
((eq (car expr) 'define)
(comp (caddr expr) env (list* 'def (location-gvar (cadr expr)) code) nil))
((eq (car expr) 'define-macro)
(comp (caddr expr) env (list* 'defm (location-gvar (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 (location-gvar (cadr expr)) code) nil))))
・・・・・
変数のアクセスで、大域変数の場合は location-gvar で大域変数のセルを求めて ldg のあとにセットします。set! も同様にコンパイルします。define, define-macro も修正が必要で、def, defm 命令のあとに location-gvar の返り値をセットします。
次は仮想マシン vm を修正します。次のリストを見てください。
リスト : 仮想マシンの修正
・・・・・
((ldg)
(let ((cell (pop c)))
(if (eq (cdr cell) '*undef*)
(error "unbound variable ~S" (car cell))
(push (cdr cell) s))))
・・・・・
((gset)
(let ((cell (pop c)))
(if (eq (cdr cell) '*undef*)
(error "unbound variable ~S" (car cell))
(setf (cdr cell) (car s)))))
・・・・・
((def)
(let ((cell (pop c)))
(setf (cdr cell) (pop s))
(push (car cell) s)))
((defm)
(let ((cell (pop c)))
(setf (cdr cell) (cons 'macro (pop s)))
(push (car cell) s)))
・・・・・
ldg の場合、c の先頭から大域変数のセルを取り出して変数 cell にセットします。(cdr cell) で変数の値を求め、それが *undef* ならばエラーを送出します。そうでなければ (cdr cell) をスタックに積むだけです。gset の場合も大域変数のセルを変数 cell にセットし、その CDR 部を setf でスタックトップの値 (car s) に書き換えるだけです。def と defm は gset と同様に大域変数のセル (cell) の CDR 部を setf で書き換えて、変数名 (car cell) をスタックに積むだけです。
修正はこれだけです。プログラムの詳細は プログラムリスト１ をお読みください。
それでは SBCL (ver 1.0.37) で実行してみましょう。1 から n までの和を求める関数 sum1 (末尾再帰版) とたらいまわし関数で試してみました。
表 : 実行結果
| A | B
------------------+------+------
(sum1 1000000 0) | 1.8 | 0.67
(tarai 12 6 0) | 15.4 | 6.04
(tak 16 8 0) | 2.9 | 1.16
A : 改良前
B : 改良後
単位 : 秒
実行環境 : SBCL (ver 1.4.5), Ubuntu 18.04 (WSL), Intel Core i5-6200U 2.30GHz
大域変数のアクセス方法を改良することで、実行時間は 2 倍以上速くなりました。簡単な方法ですが、関数を呼び出すときに ldg 命令を使っているので、SBCL の場合その効果はとても大きいようです。
なお、今回の修正方法がベストというわけではありません。たとえば、他の言語で実装する場合、シンボルを表すデータ構造を作り、その中に大域変数の値を格納する領域を用意します。そうすると、ldg, gset, def, defm 命令にはシンボルを渡すだけで、大域変数の値にアクセスすることができます。いろいろな方法を考えて試してみるのも面白いと思います。
;;;
;;; secd.lsp : SECD 仮想マシンによる Scheme コンパイラ
;;;
;;; (1) 基本機能の実装
;;; (2) 伝統的なマクロの実装
;;; (3) 継続の実装
;;; (4) 末尾再帰最適化
;;; (5) ldg, gset 命令の改良
;;;
;;; 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 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 location-gvar (expr)
(let ((cell (assoc expr *global-environment*)))
(unless cell
(setq cell (cons expr '*undef*))
(push cell *global-environment*))
cell))
;;; 大域変数の値を求める
(defun get-gvar (expr)
(cdr (location-gvar expr)))
;;; 自己評価フォームか
(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 (location-gvar 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 (location-gvar (cadr expr)) code) nil))
((eq (car expr) 'define-macro)
(comp (caddr expr) env (list* 'defm (location-gvar (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 (location-gvar (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)
(let ((cell (pop c)))
(if (eq (cdr cell) '*undef*)
(error "unbound variable ~S" (car cell))
(push (cdr cell) 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)
(let ((cell (pop c)))
(if (eq (cdr cell) '*undef*)
(error "unbound variable ~S" (car cell))
(setf (cdr cell) (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 ((cell (pop c)))
(setf (cdr cell) (pop s))
(push (car cell) s)))
((defm)
(let ((cell (pop c)))
(setf (cdr cell) (cons 'macro (pop s)))
(push (car cell) 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 '())))
(princ output)
(terpri))
(simple-error (c) (format t "ERROR: ~a~%" c)))))
(setq *readtable* (copy-readtable nil))))
拙作のページ Common Lisp で作る micro Scheme (2) や Common Lisp で作る micro Scheme コンパイラ (2) で作成したバッククォートの処理は簡略版で、 Scheme の仕様書 (R5RS など) に準拠しておりません。具体的には、バッククォートは入れ子にすることができるのですが、拙作の簡略版では対応していません。今回はちょっと複雑になりますが、バッククォートの入れ子にも対応するようにプログラムを修正しましょう。
バッククォートの入れ子は、レベルを考えると理解しやすいと思います。一番外側にある `expr0 をレベルを 0 とします。expr0 の中で `expr1 を見つけたら、レベルを +1 します。このとき、` はそのまま出力して、expr1 の処理を行います。その中で ,expr2 や ,@expr2 を見つけた場合、レベルが 0 ならば expr2 を評価するようにマクロ展開し、そうでなければレベルを -1 します。このとき、, や ,@ はそのまま出力して、expr2 の処理を行います。
簡単な例を示しましょう。
gosh> `(a `(b ,(c ,(+ 1 2 3))) ,(car '(d e f))) (a `(b ,(c 6)) d)
リスト A = (a ...) のレベルは 0 です。次の要素が backquote なので、リスト B = (b ...) のレベルは 1 になります。リスト B の 2 番目の要素は unquote ですが、レベルが 1 なので、unquote をそのまま出力して、リスト C = (c ,(+ 1 2 3)) を処理します。このとき、レベルは -1 されて 0 になります。リスト C の中の unquote はレベルが 0 なので、(+ 1 2 3) を評価して 6 になります。リスト A の最後の要素はレベル 0 の unquote なので (car '(d e f)) を評価して d になります。
バッククォートはリストだけではなくアトムにも適用することができます。拙作の簡略版はこの処理にも対応していません。次の例を見てください。
gosh> (define a '(1 2 3)) a gosh> `,a (1 2 3) gosh> `,@a => エラー gosh> ``,@,@a `(unquote-splicing 1 2 3)
`,a は (1 2 3) に展開されますが、`,@a はリストを外せないのでエラーになります。ただし、splice の前に unquote や splice (Scheme では unquote-splicing) などがそのまま展開される場合は、リストを外すことができるのでエラーにはなりません。
それではプログラムを作りましょう。
リスト : バッククオートの処理
(define unquote
(lambda (x) (error "unquote appeared outside backquote")))
(define splice
(lambda (x) (error "splice appeared outside backquote")))
(define translator
(lambda (ls n)
(if (pair? ls)
(if (pair? (car ls))
(translator-list ls n)
(translator-atom ls n))
(list 'quote ls))))
(define-macro backquote (lambda (x) (translator x 0)))
関数 unquote と splice はエラーを返します。これは `,,a のように、対応する backquote がない場合に呼び出されます。micro Scheme コンパイラ (secd.l) に primitive の関数 error を追加してください。
リスト : secd.scm の修正
; 大域変数
(setq *global-environment*
(list
・・・ 省略 ・・・
(list 'error 'primitive #'error) ; 追加
))
backquote の実際の処理は関数 translator で行います。引数が ls がリストでその先頭要素がリストの場合は tranlator-list を呼び出します。これはリストの中にある unquote や splice を展開します。先頭要素がアトムの場合は tranlator-atom を呼び出します。これは backquote の直後にある unquote や splice を展開します。それ以外の場合は (quote ls) を生成するコード (list 'quote ls) を出力します。
次は translator-list を作ります。
リスト : バッククオートの処理 (2)
(define translator-list
(lambda (ls n)
(if (eq? (caar ls) 'unquote)
(translator-unquote ls n)
(if (eq? (caar ls) 'splice)
(translator-splice ls n)
(if (eq? (caar ls) 'backquote)
(translator-backquote ls n)
(list 'cons
(translator (car ls) n)
(translator (cdr ls) n)))))))
translator-list は (caar ls) の種類によって処理を振り分けるだけです。unquote であれば translator-unquote を、splice であれば translator-splice を、backquote であれば translator-backquote を呼び出します。それ以外の場合は (car ls) と (cdr ls) に対して translator を適用し、その結果を cons で連結するコードを生成します。
次は unquote を展開する translator-unquote を作ります。
リスト : バッククオートの処理 (3)
(define translator-sub
(lambda (sym ls n succ)
(list 'list
(list 'quote sym)
(translator ls (+ n succ)))))
(define translator-unquote
(lambda (ls n)
(list 'cons
(if (zero? n)
(cadar ls)
(translator-sub 'unquote (cadar ls) n -1))
(translator (cdr ls) n))))
レベル n が 0 の場合、unquote の次の要素 (cadar ls) を評価するコードを生成します。これは (cadar ls) をそのまま出力するだけです。そうでなければ、unquote をそのまま出力して、(cadar ls) の中を調べます。この処理を関数 translator-sub で行います。このときレベルを -1 します。あとは、(cdr ls) に traslator を適用して、2 つの引数を cons で連結するコードを生成します。
次は splice を展開する関数 translator-splice を作ります。
リスト : バッククオートの処理 (4)
(define translator-splice
(lambda (ls n)
(if (zero? n)
(list 'append (cadar ls) (translator (cdr ls) n))
(list 'cons
(translator-sub 'splice (cadar ls) n -1)
(translator (cdr ls) n)))))
レベル n が 0 の場合は、(cadar ls) を評価した結果と (cdr ls) に translator を適用した結果を append するコードを生成します。これで (cadar ls) の評価結果のリストを外すことができます。そうでなければ、translator-sub で splice をそのまま出力するコードを生成し、(cdr ls) に translator を適用した結果と cons するコードを生成します。translator-sub を呼び出すときはレベルを -1 することをお忘れなく。
次は backquote をそのまま出力する関数 translator-backquote を作ります。
リスト : バッククオートの処理 (5)
(define translator-backquote
(lambda (ls n)
(list 'cons
(translator-sub 'backquote (cadar ls) n 1)
(translator (cdr ls) n))))
translator-backquote は簡単です。translator-sub で backquote をそのまま出力するコードを生成し、(cdr ls) に translator を適用した結果と cons するコードを生成します。translator-sub を呼び出すときはレベルを +1 することに注意してください。
最後に translator-atom を作ります。
リスト : バッククオートの処理 (6)
(define translator-atom
(lambda (ls n)
(if (eq? (car ls) 'unquote)
(if (zero? n)
(cadr ls)
(if (= n 1)
(if (eq? (car (cadr ls)) 'splice)
(list 'cons (list 'quote 'unquote) (cadr (cadr ls)))
(translator-sub 'unquote (cadr ls) n -1))
(translator-sub 'unquote (cadr ls) n -1)))
(if (eq? (car ls) 'splice)
(if (zero? n)
(error "invalid splice form")
(if (= n 1)
(if (eq? (car (cadr ls)) 'splice)
(list 'cons (list 'quote 'splice) (cadr (cadr ls)))
(translator-sub 'splice (cadr ls) n -1))
(translator-sub 'splice (cadr ls) n -1)))
(if (eq? (car ls) 'backquote)
(translator-sub 'backquote (cadr ls) n 1)
(list 'cons
(list 'quote (car ls))
(translator (cdr ls) n)))))))
(car ls) が unquote でレベル n が 0 の場合、(cadr ls) をそのまま出力します。これでマクロ展開されたあと (cadr ls) が評価されます。レベル n が 1 で、(cadr ls) の先頭要素が splice の場合、次の要素 (cadr (cadr ls)) を評価して、そのリストの先頭に unquote を cons で追加するコードを生成します。それ以外の場合は、translator-sub で unquote をそのまま出力するコードを生成します。
(car ls) が splice でレベル n が 0 の場合、リストを外せないのでエラーを返します。レベル n が 1 で、(cadr ls) の先頭要素が splice の場合、次の要素 (cadr (cadr ls)) を評価して、そのリストの先頭に splice を cons で追加するコードを生成します。それ以外の場合は、translator-sub で splice をそのまま出力するコードを生成します。
(car ls) を backquote の場合は translator-sub で backquote をそのまま出力するコードを生成します。それ以外の場合は (car ls) をそのまま出力するコードを生成し、(cdr ls) に translator-sub を適用したコードと cons するコードを生成します。
それでは実際に試してみましょう。必要なプログラムはファイル lib.scm に格納されているものとします。
>>> (define a 1) A >>> (define b '(a b c)) B >>> `(a b) (A B) >>> `(,a ,b) (1 (A B C)) >>> `(,a ,@b) (1 A B C) >>> `(a `(b ,(c ,(+ 1 2 3))) ,(car '(d e f))) (A (BACKQUOTE (B (UNQUOTE (C 6)))) D) >>> `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f) (A (BACKQUOTE (B (UNQUOTE (+ 1 2)) (UNQUOTE (FOO 4 D)) E)) F) >>> (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)) (A (BACKQUOTE (B (UNQUOTE X) (UNQUOTE 'Y) D)) E) >>> `,a 1 >>> `,b (A B C) >>> ``,,a (BACKQUOTE (UNQUOTE 1)) >>> ``,,b (BACKQUOTE (UNQUOTE (A B C))) >>> ``,,@b (BACKQUOTE (UNQUOTE A B C)) >>> ``,@,@b (BACKQUOTE (SPLICE A B C)) >>> ,a ERROR: unquote appeared outside backquote >>> ,@b ERROR: splice appeared outside backquote >>> `,@b ERROR: invalid splice form >>> `,,@b ERROR: splice appeared outside backquote >>> `,,a ERROR: unquote appeared outside backquote
どうやら基本的な機能は正常に動作しているようですが、まだバグが残っているかもしれません。興味のある方はいろいろ試してみてください。
;;;
;;; lib.scm : micro Scheme 用簡易ライブラリ
;;;
;;; Copyright (C) 2013-2021 Makoto Hiroi
;;;
;;; 述語
(define not (lambda (x) (if x false true)))
(define null? (lambda (x) (eq? x ())))
;;; 数
(define zero? (lambda (x) (= x 0)))
(define positive? (lambda (x) (< 0 x)))
(define negative? (lambda (x) (> 0 x)))
(define even? (lambda (x) (zero? (mod x 2))))
(define odd? (lambda (x) (not (even? x))))
(define abs (lambda (x) (if (negative? x) (- x) x)))
(define max
(lambda (x . xs)
(fold-left (lambda (a b) (if (< a b) b a)) x xs)))
(define min
(lambda (x . xs)
(fold-left (lambda (a b) (if (> a b) b a)) x xs)))
(define gcdi
(lambda (a b)
(if (zero? b)
a
(gcdi b (mod a b)))))
(define gcd
(lambda xs
(if (null? xs)
0
(fold-left (lambda (a b) (gcdi a b)) (car xs) (cdr xs)))))
(define lcmi (lambda (a b) (/ (* a b) (gcdi a b))))
(define lcm
(lambda xs
(if (null? xs)
1
(fold-left (lambda (a b) (lcmi a b)) (car xs) (cdr xs)))))
;;; cxxr
(define caar (lambda (xs) (car (car xs))))
(define cadr (lambda (xs) (car (cdr xs))))
(define cdar (lambda (xs) (cdr (car xs))))
(define cddr (lambda (xs) (cdr (cdr xs))))
;;; cxxxr
(define caaar (lambda (xs) (car (caar xs))))
(define caadr (lambda (xs) (car (cadr xs))))
(define cadar (lambda (xs) (car (cdar xs))))
(define caddr (lambda (xs) (car (cddr xs))))
(define cdaar (lambda (xs) (cdr (caar xs))))
(define cdadr (lambda (xs) (cdr (cadr xs))))
(define cddar (lambda (xs) (cdr (cdar xs))))
(define cdddr (lambda (xs) (cdr (cddr xs))))
;;;
;;; リスト操作
;;;
(define list (lambda x x))
(define append-1
(lambda (xs ys)
(if (null? xs)
ys
(cons (car xs) (append-1 (cdr xs) ys)))))
(define append
(lambda xs
(if (null? xs)
'()
(if (null? (cdr xs))
(car xs)
(append-1 (car xs) (apply append (cdr xs)))))))
(define length
(lambda (xs)
(fold-left (lambda (a x) (+ a 1)) 0 xs)))
(define reverse
(lambda (xs)
(fold-left (lambda (a x) (cons x a)) () xs)))
(define list-tail
(lambda (xs k)
(if (zero? k)
xs
(list-tail (cdr xs) (- k 1)))))
(define list-ref
(lambda (xs k)
(if (zero? k)
(car xs)
(list-ref (cdr xs) (- k 1)))))
;;;
;;; リストの探索
;;;
(define memq
(lambda (x ls)
(if (null? ls)
false
(if (eq? x (car ls))
ls
(memq x (cdr ls))))))
(define memv
(lambda (x ls)
(if (null? ls)
false
(if (eqv? x (car ls))
ls
(memv x (cdr ls))))))
(define member
(lambda (x ls)
(if (null? ls)
false
(if (equal? x (car ls))
ls
(member x (cdr ls))))))
;;;
;;; 高階関数
;;;
(define map-1
(lambda (f xs)
(if (null? xs)
()
(cons (f (car xs)) (map f (cdr xs))))))
(define map
(lambda (f . args)
(if (memq '() args)
'()
(cons (apply f (map-1 car args))
(apply map f (map-1 cdr args))))))
(define filter
(lambda (p xs)
(if (null? xs)
()
(if (p (car xs))
(cons (car xs) (filter p (cdr xs)))
(filter p (cdr xs))))))
(define fold-left
(lambda (f a xs)
(if (null? xs)
a
(fold-left f (f a (car xs)) (cdr xs)))))
(define fold-right
(lambda (f a xs)
(if (null? xs)
a
(f (car xs) (fold-right f a (cdr xs))))))
;;;
;;; マクロ
;;;
(define unquote
(lambda (x) (error "unquote appeared outside backquote")))
(define splice
(lambda (x) (error "splice appeared outside backquote")))
(define translator-sub
(lambda (sym ls n succ)
(list 'list
(list 'quote sym)
(translator ls (+ n succ)))))
(define translator-unquote
(lambda (ls n)
(list 'cons
(if (zero? n)
(cadar ls)
(translator-sub 'unquote (cadar ls) n -1))
(translator (cdr ls) n))))
(define translator-splice
(lambda (ls n)
(if (zero? n)
(list 'append (cadar ls) (translator (cdr ls) n))
(list 'cons
(translator-sub 'splice (cadar ls) n -1)
(translator (cdr ls) n)))))
(define translator-backquote
(lambda (ls n)
(list 'cons
(translator-sub 'backquote (cadar ls) n 1)
(translator (cdr ls) n))))
(define translator-list
(lambda (ls n)
(if (eq? (caar ls) 'unquote)
(translator-unquote ls n)
(if (eq? (caar ls) 'splice)
(translator-splice ls n)
(if (eq? (caar ls) 'backquote)
(translator-backquote ls n)
(list 'cons
(translator (car ls) n)
(translator (cdr ls) n)))))))
(define translator-atom
(lambda (ls n)
(if (eq? (car ls) 'unquote)
(if (zero? n)
(cadr ls)
(if (= n 1)
(if (eq? (car (cadr ls)) 'splice)
(list 'cons (list 'quote 'unquote) (cadr (cadr ls)))
(translator-sub 'unquote (cadr ls) n -1))
(translator-sub 'unquote (cadr ls) n -1)))
(if (eq? (car ls) 'splice)
(if (zero? n)
(error "invalid splice form")
(if (= n 1)
(if (eq? (car (cadr ls)) 'splice)
(list 'cons (list 'quote 'splice) (cadr (cadr ls)))
(translator-sub 'splice (cadr ls) n -1))
(translator-sub 'splice (cadr ls) n -1)))
(if (eq? (car ls) 'backquote)
(translator-sub 'backquote (cadr ls) n 1)
(list 'cons
(list 'quote (car ls))
(translator (cdr ls) n)))))))
(define translator
(lambda (ls n)
(if (pair? ls)
(if (pair? (car ls))
(translator-list ls n)
(translator-atom ls n))
(list 'quote ls))))
(define-macro backquote (lambda (x) (translator x 0)))
;;; 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)
true
(if (null? (cdr args))
(car args)
`(if ,(car args) (and ,@(cdr args)) false)))))
;;; or
(define-macro or
(lambda args
(if (null? args)
false
(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 (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 (lambda (x y)
(if (null? x) y (car x)))
step
vars)))))))
(loop ,@vals)))))