Lisp 系の言語で繰り返しといえば、Scheme では named-let などの再帰定義、Common Lisp では dotime, dolist, do や loop (または loop マクロ) でしょうか。ISLisp の場合、do のかわりに for を使います。ISLisp の仕様に dotimes や dolist といったマクロは規定されていませんが、Easy-ISLisp のライブラリ macro には用意されています。
たとえば、リストの総和を求める関数 sum-list を Scheme, Common Lisp, ISLisp で定義すると、次のようになります。
リスト : 総和を求める
;;; Scheme 版
(define (sum-list xs)
(let loop ((xs xs) (a 0))
(if (null? xs)
a
(loop (cdr xs) (+ a (car xs))))))
;;; Common Lisp 版
(defun sum-list (xs)
(do ((xs xs (cdr xs))
(a 0 (+ a (car xs))))
((null xs) a)))
;;; ISLisp 版
(defun sum-list (xs)
(for ((xs xs (cdr xs))
(a 0 (+ a (car xs))))
((null xs) a)))
使用する処理系は Gauche (Scheme), SBCL (Common Lisp), Easy-ISLisp (ISLisp) です。
gosh> (sum-list '(1 2 3 4 5)) 15
* (sum-list '(1 2 3 4 5)) 15
> (sum-list '(1 2 3 4 5)) 15
apply (apply + xs, apply #'+ xs) や畳み込み (fold や reduce など) を使ったほうが簡単ですが、あえて繰り返しでプログラムしています。ここで仕様を変更して、負の要素があったら -1 を返すことにしましょう。Scheme 版は末尾再帰なので、簡単にプログラムすることができます。
リスト : 総和 (Scheme)
(define (sum-list1 xs)
(let loop ((xs xs) (a 0))
(cond ((null? xs) a)
((negative? (car xs)) -1)
(else (loop (cdr xs) (+ a (car xs)))))))
gosh> (sum-list1 '(1 2 3 -4 5)) -1
negative? でリストの要素 (car xs) が負かチェックして、そうであれば loop を再帰呼び出しせずに -1 を返すだけです。
Common Lisp で繰り返しから脱出する場合は return を使うと簡単です。
リスト : 総和 (Common Lisp)
(defun sum-list1 (xs)
(do ((xs xs (cdr xs))
(a 0 (+ a (car xs))))
((null xs) a)
(if (minusp (car xs))
(return -1))))
* (sum-list1 '(1 2 3 -4 5)) -1
Common Lisp の場合、do, dotimes, dolist などの本体は暗黙の block (タグは nil) に囲まれていて、return や return-from nil で繰り返しから脱出することができます。リストの要素 (car xs) が負ならば、(return -1) を評価して、繰り返しから脱出します。この場合、do の返り値は return の引数 (-1) になります。
ISLisp は Common Lisp のサブセットなので、block tag と return-from tag でブロックから脱出することができます。ただし、Common Lisp とは違って、暗黙のブロックはありません。プログラムは次のようになります。
リスト : 総和 (ISLisp)
(defun sum-list1 (xs)
(block exit
(for ((xs xs (cdr xs))
(a 0 (+ a (car xs))))
((null xs) a)
(if (< (car xs) 0)
(return-from exit -1)))))
> (sum-list1 '(1 2 3 -4 5)) -1
次は、リストのリストを行列とみなして、行列の要素の総和を求める関数 sum-matrix を定義しましょう。sum-matrix は負の要素を見つけたら -1 を返します。
リスト : 行列の総和
;;; Scheme 版
(define (sum-matrix xs)
(let loop1 ((xs xs) (a 0))
(if (null? xs)
a
(let loop2 ((ys (car xs)) (b 0))
(cond ((null? ys)
(loop1 (cdr xs) (+ a b)))
((negative? (car ys)) -1)
(else (loop2 (cdr ys) (+ b (car ys)))))))))
;;; Common Lisp 版
(defun sum-matrix (xs)
(do ((xs xs (cdr xs))
(a 0))
((null xs) a)
(do ((ys (car xs) (cdr ys)))
((null ys))
(if (minusp (car ys))
(return-from sum-matrix -1)
(incf a (car ys))))))
;;; ISLisp 版
(defun sum-matrix (xs)
(block exit
(for ((xs xs (cdr xs))
(a 0))
((null xs) a)
(for ((ys (car xs) (cdr ys)))
((null ys))
(if (< (car ys) 0)
(return-from exit -1)
(setq a (+ a (car ys))))))))
gosh> (sum-matrix '((1 2 3) (4 5 6))) 21 gosh> (sum-matrix '((1 2 3) (4 -5 6))) -1
* (sum-matrix '((1 2 3) (4 5 6))) 21 * (sum-matrix '((1 2 3) (4 5 -6))) -1
> (sum-matrix '((1 2 3) (4 5 6))) 21 > (sum-matrix '((1 2 3) (-4 5 6))) -1
Scheme 版は name-let で二重ループを実現しています。負の要素を見つけたら loop1 や loop2 を再帰呼び出しせずに -1 を返すだけです。Common Lisp の場合、関数の本体は暗黙の block (タグは関数名) で囲まれているので、(return-from sum-matix -1) を評価すれば二重ループを脱出して -1 を返すことができます。ISLisp の場合、関数の本体にも暗黙のブロックはありません。関数の先頭で block exit を定義して、return-from exit で脱出します。
Common Lisp と ISLisp の場合、block のタグはレキシカルスコープです。高階関数から return-from で脱出することができます。次のリストを見てください。
リスト : リストの総和
;;; Common Lisp 版
(defun sum-list11 (xs)
(reduce #'(lambda (a x)
(if (minusp x)
(return-from sum-list11 -1)
(+ a x)))
xs
:initial-value 0))
;;; ISLisp 版
;;; 畳み込み
(defun fold-left (f a xs)
(for ((acc a (funcall f acc (car ys)))
(ys xs (cdr ys)))
((null ys) acc)))
(defun sum-list11 (xs)
(block exit
(fold-left (lambda (a x)
(if (< x 0)
(return-from exit -1)
(+ a x)))
0
xs)))
* (sum-list11 '(1 2 3 4 5 6)) 21 * (sum-list11 '(-1 2 3 4 5 6)) -1 * (sum-list11 '(1 2 3 4 5 -6)) -1
> (sum-list11 '(1 2 3 4 5 6)) 21 > (sum-list11 '(-1 2 3 4 5 6)) -1 > (sum-list11 '(-1 2 3 4 5 -6)) -1
畳み込みを行う関数 reduce や fold-left に渡すラムダ式で、要素 x が負ならば return-from で -1 を返します。タグ sum-list11 や exit はレキシカルスコープなので、ラムダ式の中から参照することができ、return-from でそのブロックから脱出することができます。
また、return-from tag をラムダ式に包んで他の関数に渡すこともできます。この場合、渡されたラムダ式を実行すると、tag で指定した block から脱出することができるのです。次のリストを見てください。
リスト : 行列の総和
;;; Common Lisp 版
(defun sum-list2 (failure xs)
(do ((xs xs (cdr xs))
(a 0 (+ a (car xs))))
((null xs) a)
(if (minusp (car xs))
(funcall failure))))
(defun sum-matrix1 (xs)
(do ((xs xs (cdr xs))
(a 0 (+ a (sum-list2 #'(lambda () (return-from sum-matrix1 -1))
(car xs)))))
((null xs) a)))
;;; ISLisp 版
(defun sum-list2 (failure xs)
(for ((xs xs (cdr xs))
(a 0 (+ a (car xs))))
((null xs) a)
(if (< (car xs) 0)
(funcall failure))))
(defun sum-matrix1 (xs)
(block exit
(for ((xs xs (cdr xs))
(a 0 (+ a (sum-list2 (lambda () (return-from exit -1))
(car xs)))))
((null xs) a))))
* (sum-matrix1 '((1 2 3) (4 5 6) (7 8 9))) 45 * (sum-matrix1 '((1 2 3) (4 5 6) (-7 8 9))) -1
> (sum-matrix1 '((1 2 3) (4 5 6) (7 8 9))) 45 > (sum-matrix1 '((1 2 3) (4 5 6) (-7 8 9))) -1
sum-matrix1 は行列 xs から 1 行ずつ取り出して sum-list2 に渡します。このとき、(return-from sum-matrix1 -1) を包んだラムダ式もいっしょに渡します。Common Lisp (ISLisp) はレキシカルスコープなので、ラムダ式の中からタグ sum-matrix1 を参照することができます。
次に、sum-list2 でリストの要素が負の場合、渡されたラムダ式 failure を評価します。すると、制御は sum-matrix1 に戻って -1 を返すことができます。
この動作は Scheme の call/cc による大域脱出とよく似ています。Scheme で同様のプログラムを作ると次のようになります。
リスト : 行列の総和 (Scheme)
(define (sum-list2 failure xs)
(let loop ((xs xs) (a 0))
(cond ((null? xs) a)
((negative? (car xs)) (failure -1))
(else (loop (cdr xs) (+ a (car xs)))))))
(define (sum-matrix1 xs)
(call/cc
(lambda (bk)
(let loop ((xs xs) (a 0))
(if (null? xs)
a
(loop (cdr xs) (+ a (sum-list2 bk (car xs)))))))))
gosh> (sum-matrix1 '((1 2 3) (4 5 6) (7 8 9))) 45 gosh> (sum-matrix1 '((1 2 3) (4 5 6) (7 -8 9))) -1
call/cc で継続を取り出して変数 bk にセットし、それを sum-list2 に渡します。sum-list2 では、要素が負であれば継続 failure を評価して -1 を返します。
Common Lisp と ISLisp は、catch, throw による例外処理をサポートしているので、block とラムダ式を使って大域脱出をプログラムすることはないでしょうが、高階関数などで処理を中断させたい場合、この方法を使うことができます。
Common Lisp (ISLisp) の block のタグはレキシカルスコープで管理されますが、同様に tagbody と go のタグ (ジャンプ先) もレキシカルスコープで管理されます。go をラムダ式に包んで他の関数に渡すこともでき、そのラムダ式を評価するとそのタグにジャンプすることができます。
簡単な例を示しましょう。
* (defun foo (x) (tagbody (let ((f #'(lambda () (go exit)))) (funcall x f) (print 1)) exit (print 2))) FOO * (foo #'(lambda (f) (funcall f))) 2 NIL * (foo #'(lambda (f) f)) 1 2 NIL
関数 foo の引数 x は関数で、その引数に go exit を包んだラムダ式を渡します。foo に渡す関数の中で引数を評価すると、go exit が実行されるので、tagbody のタグ exit に制御が移ります。したがって、(funcall x f) のあとの (print 1) は実行されません。引数を評価しない場合、(print 1) が実行されて、そのあとに (print 2) が実行されます。
ISLisp にも tagbody と go が用意されていて、その動作は Common Lisp と同じですが、普通のプログラムで tagbody と go を使うことは滅多にありません。ましてや、このような使い方をすることはまずないと思います。tagbody と go を安易に使用してはいけません。くれぐれもご注意くださいませ。
AA 木 (Arne Andersson tree) は 1993 年に Arne Andersson 氏が発表した平衡木です。二分木は左右の部分木のバランスが崩れると性能が劣化する欠点があります。極端な例ですが、ソートされたデータを二分木に挿入していくと、データは右側の部分木にしか挿入されず、連結リストと同じ線形探索になってしまいます。
これを補うために、木のバランスを一定の範囲に収める平衡木が考案されています。有名なところでは、二分木をベースにした AVL 木、赤黒木、AA 木などや、多分木をベースにした 2-3 木、2-3-4 木、B 木、B* 木などがあります。
赤黒木は 2-3-4 木の動作を二分木で実現したものですが、そのプログラムはとても複雑です。これに対して、AA 木は 2-3 木の動作を二分木で実現したものですが、とても簡単にプログラムを実装できる、という特徴があります。AA 木の詳しい説明は、拙作のページ「Algorithms with Python: AA 木」をお読みください。
今回は ILOS の例題として、AA tree を使った連想配列 <treemap> を作ってみましょう。
$ eisl
Easy-ISLisp Ver2.98
> (load "treemap.lsp")
T
> (defglobal a (make-treemap #'string= #'string<))
A
> (defglobal ks '("foo" "bar" "baz" "oops"))
KS
> (defglobal vs '(10 20 30 40))
VS
> (tree-emptyp a)
T
> (mapc (lambda (k v) (tree-set a k v)) ks vs)
("foo" "bar" "baz" "oops")
> (tree-emptyp a)
NIL
> (mapc (lambda (k) (print (tree-exists a k))) '("Foo" "foo"))
NIL
T
("Foo" "foo")
> (mapc (lambda (k) (print (tree-get a k))) ks)
10
20
30
40
("foo" "bar" "baz" "oops")
> (tree-mapc a (lambda (k v) (print (cons k v))))
("bar" . 20)
("baz" . 30)
("foo" . 10)
("oops" . 40)
NIL
> (defun to_alist (tm) (tree-fold-right tm nil (lambda (a k v) (cons (cons k v) a))))
TO_ALIST
> (to_alist a)
(("bar" . 20) ("baz" . 30) ("foo" . 10) ("oops" . 40))
> (tree-max-del a)
<instance>
> (to_alist a)
(("bar" . 20) ("baz" . 30) ("foo" . 10))
> (tree-min-del a)
<instance>
> (to_alist a)
(("baz" . 30) ("foo" . 10))
> (tree-del a "foo")
T
> (to_alist a)
(("baz" . 30))
> (tree-del a "baz")
T
> (tree-del a "baz")
NIL
> (to_alist a)
NIL
> (tree-emptyp a)
T
> (tree-push a "Foo" 10)
T
> (tree-get a "Foo")
(10)
> (tree-push a "Foo" 20)
NIL
> (tree-get a "Foo")
(20 10)
> (tree-pop a "Foo")
20
> (tree-get a "Foo")
(10)
> (tree-pop a "Foo")
10
> (tree-get a "Foo")
NIL
> (tree-pop a "Foo")
NIL
> (tree-exists a "Foo")
T
> (tree-del a "Foo")
T
> (tree-exists a "Foo")
NIL
> (tree-pop a "Foo")
NIL
実行結果は OKI-ISLisp でも同じです。
;;;
;;; treemap.lsp : 連想配列 (平衡木, AA tree)
;;;
;;; Copyright (C) 2023 Makoto Hiroi
;;;
;;; 終端
(defglobal empty nil)
;;; 節の定義
(defclass <node> ()
((key :accessor node-key :initform nil :initarg key)
(value :accessor node-value :initform nil :initarg value)
(height :accessor node-height :initform 1 :initarg height)
(left :accessor node-left :initform nil :initarg left)
(right :accessor node-right :initform nil :initarg right)))
;;; 終端の生成
(defun make-empty ()
(cond
((null empty)
(setf empty (create (class <node>)))
(setf (node-height empty) 0)
(setf (node-left empty) empty)
(setf (node-right empty) empty)))
empty)
;;; 終端のチェック
(defun node-emptyp (node) (eq node empty))
;;; 右回転
(defun rotate-right (node)
(let ((lnode (node-left node)))
(setf (node-left node) (node-right lnode))
(setf (node-right lnode) node)
lnode))
;;; 左回転
(defun rotate-left (node)
(let ((rnode (node-right node)))
(setf (node-right node) (node-left rnode))
(setf (node-left rnode) node)
rnode))
;;; 左の子が赤の場合
(defun skew (node)
(if (= (node-height (node-left node)) (node-height node))
(rotate-right node)
node))
;;; 右の孫節が赤の場合
(defun split (node)
(cond
((= (node-height node)
(node-height (node-right (node-right node))))
(setf node (rotate-left node))
(setf (node-height node) (+ (node-height node) 1))))
node)
;;; 探索
(defun node-search (node x elt= elt<)
(cond
((node-emptyp node) empty)
((funcall elt= (node-key node) x) node)
((funcall elt< x (node-key node))
(node-search (node-left node) x elt= elt<))
(t
(node-search (node-right node) x elt= elt<))))
;;; 最小値
(defun node-search-min (node)
(if (node-emptyp (node-left node))
node
(node-search-min (node-left node))))
;;; 最大値
(defun node-search-max (node)
(if (node-emptyp (node-right node))
node
(node-search-max (node-right node))))
;;; 挿入
(defun node-insert (node x v elt= elt<)
(cond
((node-emptyp node)
(cons (create (class <node>) 'key x 'value v 'left empty 'right empty) t))
((funcall elt= (node-key node) x)
(setf (node-value node) v)
(cons node nil))
((funcall elt< x (node-key node))
(let ((xs (node-insert (node-left node) x v elt= elt<)))
(setf (node-left node) (car xs))
(cons (split (skew node)) (cdr xs))))
(t
(let ((xs (node-insert (node-right node) x v elt= elt<)))
(setf (node-right node) (car xs))
(cons (split (skew node)) (cdr xs))))))
(defun node-push (node x v elt= elt<)
(cond
((node-emptyp node)
(cons (create (class <node>) 'key x 'value (list v) 'left empty 'right empty) t))
((funcall elt= (node-key node) x)
(setf (node-value node) (cons v (node-value node)))
(cons node nil))
((funcall elt< x (node-key node))
(let ((xs (node-push (node-left node) x v elt= elt<)))
(setf (node-left node) (car xs))
(cons (split (skew node)) (cdr xs))))
(t
(let ((xs (node-push (node-right node) x v elt= elt<)))
(setf (node-right node) (car xs))
(cons (split (skew node)) (cdr xs))))))
;;;
;;; 削除
;;;
;;; バランスのチェックと修正処理
(defun delete-balance (node)
(let ((h (- (node-height node) 1)))
(cond
((or (< (node-height (node-left node)) h)
(< (node-height (node-right node)) h))
(setf (node-height node) h)
(if (> (node-height (node-right node)) h)
(setf (node-height (node-right node)) h))
(setf node (skew node))
(setf (node-right node) (skew (node-right node)))
(setf (node-right (node-right node)) (skew (node-right (node-right node))))
(setf node (split node))
(setf (node-right node) (split (node-right node)))))
node))
;;; 最大値を削除
(defun node-delete-max (node)
(cond
((node-emptyp (node-right node)) (node-left node))
(t
(setf (node-right node) (node-delete-max (node-right node)))
(delete-balance node))))
;;; 最小値を削除
(defun node-delete-min (node)
(cond
((node-emptyp (node-left node)) (node-right node))
(t
(setf (node-left node) (node-delete-min (node-left node)))
(delete-balance node))))
;;; key と等しい要素を削除
(defun node-delete (node key elt= elt<)
(cond
((node-emptyp node) (cons node nil))
((funcall elt= key (node-key node))
(cond
((node-emptyp (node-left node)) (cons (node-right node) t))
((node-emptyp (node-right node)) (cons (node-left node) t))
(t
(let ((del-node (node-search-min (node-right node))))
(setf (node-key node) (node-key del-node))
(setf (node-value node) (node-value del-node))
(setf (node-right node) (node-delete-min (node-right node)))
(cons (delete-balance node) t)))))
((funcall elt< key (node-key node))
(let ((xs (node-delete (node-left node) key elt= elt<)))
(setf (node-left node) (car xs))
(cons (delete-balance node) (cdr xs))))
(t
(let ((xs (node-delete (node-right node) key elt= elt<)))
(setf (node-right node) (car xs))
(cons (delete-balance node) (cdr xs))))))
;;; 巡回
(defun node-traverse (func node)
(cond
((not (node-emptyp node))
(node-traverse func (node-left node))
(funcall func (node-key node) (node-value node))
(node-traverse func (node-right node)))))
;;; 畳み込み
(defun node-fold-left (func a node)
(if (node-emptyp node)
a
(let ((b (node-fold-left func a (node-left node))))
(node-fold-left func (funcall func b (node-key node) (node-value node)) (node-right node)))))
(defun node-fold-right (func a node)
(if (node-emptyp node)
a
(let ((b (node-fold-right func a (node-right node))))
(node-fold-right func (funcall func b (node-key node) (node-value node)) (node-left node)))))
;;; treemap の定義
(defclass <treemap> ()
((root :accessor tree-root :initform nil :initarg root)
(elt= :accessor tree-elt= :initform nil :initarg elt=)
(elt< :accessor tree-elt< :initform nil :initarg elt<)))
;;; コンストラクタ
(defun make-treemap (elt= elt<)
(create (class <treemap>) 'root (make-empty) 'elt= elt= 'elt< elt<))
;;; メソッドの定義
(defgeneric tree-emptyp (tm))
(defgeneric tree-exists (tm k))
(defgeneric tree-get (tm k))
(defgeneric tree-max (tm))
(defgeneric tree-min (tm))
(defgeneric tree-set (tm k v))
(defgeneric tree-push (tm k v))
(defgeneric tree-pop (tm k))
(defgeneric tree-del (tm k))
(defgeneric tree-max-del (tm))
(defgeneric tree-min-del (tm))
(defgeneric tree-mapc (tm fn))
(defgeneric tree-fold-left (tm a fn))
(defgeneric tree-fold-right (tm a fn))
(defmethod tree-emptyp ((tm <treemap>))
(node-emptyp (tree-root tm)))
(defmethod tree-exists ((tm <treemap>) key)
(not (node-emptyp (node-search (tree-root tm) key (tree-elt= tm) (tree-elt< tm)))))
(defmethod tree-get ((tm <treemap>) key)
(node-value (node-search (tree-root tm) key (tree-elt= tm) (tree-elt< tm))))
(defmethod tree-max ((tm <treemap>))
(if (tree-emptyp tm)
nil
(let ((node (node-search-max (tree-root tm))))
(cons (node-key node) (node-value node)))))
(defmethod tree-min ((tm <treemap>))
(if (tree-emptyp tm)
nil
(let ((node (node-search-min (tree-root tm))))
(cons (node-key node) (node-value node)))))
(defmethod tree-set ((tm <treemap>) key value)
(let ((xs (node-insert (tree-root tm) key value (tree-elt= tm) (tree-elt< tm))))
(setf (tree-root tm) (car xs))
(cdr xs)))
(defmethod tree-push ((tm <treemap>) key value)
(let ((xs (node-push (tree-root tm) key value (tree-elt= tm) (tree-elt< tm))))
(setf (tree-root tm) (car xs))
(cdr xs)))
(defmethod tree-pop ((tm <treemap>) key)
(let* ((xs (node-search (tree-root tm) key (tree-elt= tm) (tree-elt< tm)))
(ys (node-value xs)))
(cond
((consp ys)
(setf (node-value xs) (cdr ys))
(car ys)))))
(defmethod tree-del ((tm <treemap>) key)
(let ((xs (node-delete (tree-root tm) key (tree-elt= tm) (tree-elt< tm))))
(setf (tree-root tm) (car xs))
(cdr xs)))
(defmethod tree-max-del ((tm <treemap>))
(if (tree-emptyp tm)
nil
(setf (tree-root tm) (node-delete-max (tree-root tm)))))
(defmethod tree-min-del ((tm <treemap>))
(if (tree-emptyp tm)
nil
(setf (tree-root tm) (node-delete-min (tree-root tm)))))
(defmethod tree-mapc ((tm <treemap>) fn)
(node-traverse fn (tree-root tm)))
(defmethod tree-fold-left ((tm <treemap>) a fn)
(node-fold-left fn a (tree-root tm)))
(defmethod tree-fold-right ((tm <treemap>) a fn)
(node-fold-right fn a (tree-root tm)))
リスト : 簡単なテスト
(import "list")
(load "treemap.lsp")
;;; AA 木のチェック
(defun check-aatree (node)
(cond
((not (node-emptyp node))
(if (not (= (node-height node) (+ (node-height (node-left node)) 1)))
(error "aa tree error1"))
(if (and (not (= (node-height node) (node-height (node-right node))))
(not (= (node-height node) (+ (node-height (node-right node)) 1))))
(error "aa tree error2"))
(if (= (node-height node) (node-height (node-right (node-right node))))
(error "aa tree error3"))
(check-aatree (node-left node))
(check-aatree (node-right node)))))
(defun test-sub (xs)
(let ((a (make-treemap #'= #'<)))
(print "insert")
(dolist (x xs)
(tree-set a x t)
(check-aatree (tree-root a)))
(print "search")
(dolist (x xs)
(if (not (tree-get a x))
(error "test2 search error")))
(print "delete")
(dolist (x xs)
(tree-del a x)
(check-aatree (tree-root a)))
(print (tree-emptyp a))))
(defun test (n)
(print "昇順")
(test-sub (iota 1 n))
(print "逆順")
(test-sub (nreverse (iota 1 n)))
(print "ランダム")
(test-sub (tabulate (lambda (x) (random-real)) 1 n)))
$ eisl Easy-ISLisp Ver2.98> (load "testtree.lsp") T> (test 100) "昇順" "insert" "search" "delete" T "逆順" "insert" "search" "delete" T "ランダム" "insert" "search" "delete" T NIL> (test 200) "昇順" "insert" "search" "delete" T "逆順" "insert" "search" "delete" T "ランダム" "insert" "search" "delete" T NIL> (test 400) "昇順" "insert" "search" "delete" T "逆順" "insert" "search" "delete" T "ランダム" "insert" "search" "delete" T NIL
OKI-ISLisp の場合、(test 10) は動作しますが、(test 20) になると islisp が異常終了します。ISLisp (ILOS) にとって平衡木 (AA tree) のプログラムはけっこう重たい処理になるのかもしれませんね。
ちなみに、Common Lisp Object System (CLOS) に移植することも簡単にできます。興味のある方は拙作のページ「CLOS 入門: 平衡木 (AA tree)」をお読みください。SBCL で実行すると、(test 1000), (test 2000), (test 4000) と個数を増やしても、高速で正常に動作します。さすが SBCL だと改めて感心しました。