●仮想計算機 COMETⅡの簡易シミュレータ (9)
Common Lisp 入門 の番外編です。前回は COMET2A 用の簡単な「連結リストライブラリ」を作成しました。今回はガベージコレクション (Garbage Collection : GC) 機能付きの「連結リストライブラリ」に挑戦してみましょう。ただし、Lisp / Scheme のようなリストを実装するのは大変なので、リストの中にリストを格納することはできない、つまりリストの入れ子はできないこととします。大きな制限ですが、これによりプログラムは簡単になります。
●リストを操作するサブルーチン
最初に、リストを操作する基本的なサブルーチンを表に示します。
| サブルーチン | 機能 |
|---|---|
| cons x ls | ls の先頭に x を追加する |
| list n x y z ... | n 個の引数をリストに格納して返す |
| vector->list vec n | 大きさ n のベクタ vec をリストに変換する |
| iota n m | 整数 n, n + 1, n + 2, ..., m - 1, m を格納したリストを生成する |
| list-ref ls n | ls の n 番目の要素を返す |
| member x ls | ls から x と等しい最初の要素を探す |
| length ls | ls の長さを求める |
| reverse ls | ls を逆順する |
| nreverse ls | ls を破壊的に逆順する |
| append ls1 ls2 | ls1 と ls2 を連結する |
| drop n ls | ls の先頭から n 個の要素を取り除く |
| take n ls | ls の先頭から n 個の要素を取り出す |
| map fn ls | ls の要素に fn を適用し、その結果をリストに格納して返す |
| remove x ls | ls から x と等しい要素を取り除く |
| remove-if fn x ls | ls の要素と x を fn に渡し、fn が 1 を返す要素をリストから削除する |
| fold-left fn a ls | ls の先頭から畳み込みを行う |
| fold-rigth fn a ls | ls の末尾から畳み込みを行う |
| for-each fn ls | ls の要素に fn を適用する |
引数の ls はリスト、fn はサブルーチンを表します。引数は右側からスタックに積むことにします。つまり、左側の引数がスタックの低位アドレスに格納されます。要素の位置はベクタと同様に 0 から数えます。list-ref の場合、位置 n がリストの長さよりも大きい場合はエラー終了することにします。
●セル領域の初期化
まず最初に、セルのメモリ割り当てを変更します。前回はセルをひとつ取得するのに malloc を呼び出していたので、ひとつのセルに 4 word のメモリを消費していました。これでは非効率なので、8 k 個のセルをまとめて malloc で確保することにします。そして、下図のように未使用なセルをつないで管理します。
free-cell --> [ | ] --> [ | ] --> ... --> [ | ] --> null (0)
図 : 未使用なセルのリンケージ
セルが必要な場合は free-cell から先頭のセルを取り出します。free-cell が null (0) の場合は未使用なセルが無くなったので、ガベージコレクタ (GC) を起動して不要になったセルを回収します。
それでは、セルを初期化するサブルーチン initialize-list を作りましょう。次のリストを見てください。
リスト : セル領域の初期化
; 入力 : None
; 出力 : None
initialize-list
(push #x4000) ; 引数セット
(call malloc) ; メモリ取得 (cell は 8k 個)
(pop gr1) ; 引数破棄
(and gr0 gr0)
(jze initialize-list-err)
(st gr0 cell-top) ; セル領域開始アドレス
(lad gr1 #x4000 gr0)
(st gr1 cell-end) ; セル領域終了アドレス
;
(st gr0 free-cell) ; フリーリストの先頭
initialize-loop
(lad gr1 2 gr0) ; 次のセルのアドレス
(cpl gr1 cell-end)
(jze initialize-exit)
(st gr1 1 gr0) ; CDR にセット
(ld gr0 gr1)
(jump initialize-loop)
initialize-exit
(xor gr1 gr1)
(st gr1 1 gr0) ; null で終端
(ret)
initialize-list-err
; エラー終了
(push list-error1)
(call write-line)
(halt)
list-error1
(dc "initialize-list : Out of memory" 0)
;;;
;;; セル領域
;;;
cell-top
(ds 1)
cell-end
(ds 1)
free-cell
(ds 1)
最初に malloc を呼び出して #x4000 (16384) word のメモリを取得します。セルの個数は半分の #x2000 (8192) 個になります。malloc の返り値が 0 の場合はエラー終了します。取得したメモリ領域の先頭アドレスを cell-top と free-cell に、末尾アドレスを cell-end にセットします。cell-top と cell-end は GC で使用します。
次に、取得したセル領域を初期化します。下図を見てください。
領域の先頭 cell-top から順番にセルの CDR を次のセルのアドレスに初期化していけば、free-cell を先頭に未使用なセルのリストを構成することができます。
プログラムでは initialize-loop の中で初期化を行っています。gr0 はフリーリストの末尾セルを表します。(lad gr1 2 gr0) で次のセルのアドレスを gr1 にセットします。その値が cell-end と等しい場合は、initialize-exit にジャンプしてループから脱出します。そうでなければ、gr0 の CDR に gr1 をセットします。これで gr0 と gr1 をつなぐことができます。そして、gr1 を gr0 にセットして、処理を繰り返します。最後に、末尾セルの CDR に null (0) をセットします。
●セルの取得
次は新しいセルを取得するサブルーチン make-cell を作ります。
リスト : 新しいセルを取得
; 入力 : None
; 出力 : gr0 (New Cell)
make-cell
(ld gr0 free-cell)
(jze make-cell-error)
make-cell-lab1
(ld gr1 1 gr0)
(st gr1 free-cell)
(ret)
make-cell-error
(call gc)
(ld gr0 free-cell)
(jnz make-cell-lab1)
; GC で回収できず (エラー終了)
(push list-error2)
(call write-line)
(halt)
list-error2
(dc "make-cell : Out of memory" 0)
; CONS
; 入力 : +2) a データ
; +3) b セル or null(0)
; 出力 : gr0 新しいセル
cons
(link gr7 0)
(call make-cell) ; -> gr0
(ld gr1 2 gr7)
(st gr1 0 gr0) ; CAR
(ld gr1 3 gr7)
(st gr1 1 gr0) ; CDR
(unlk gr7)
(ret)
セルの取得は簡単です。free-cell の先頭からセルをひとつ取り出すだけです。free-cell が 0 ならば、フリーなセルがなくなったので GC を起動します。不要になったセルを GC で回収できなかった場合はエラー終了します。連結リストライブラリでは、新しいセルを取得するのにサブルーチン cons を使います。これは Lisp / Scheme の関数 cons と同じです。cons a b は make-cell で新しいセルを取得し、引数 a, b をセルの CAR と CDR にセットします。
●リストの生成
次はリストを生成するサブルーチン vector->list, list, iota を作ります。
リスト : リストの生成 (1)
; VECTOR->LIST
; 入力 +2) : バッファアドレス
; +3) : 個数
; 出力 gr0 : リスト
vector->list
(link gr7 0)
(push 0 gr2)
(push 0 gr3)
(push 0 gr4)
(xor gr4 gr4) ; リストを保持
(ld gr2 2 gr7) ; 先頭アドレス
(ld gr3 3 gr7) ; 個数
(addl gr3 gr2)
(lad gr3 -1 gr3) ; 末尾要素のアドレス
vector->list-loop
(cpl gr3 gr2) ; 末尾から先頭へ
(jmi vector->list-exit)
(lad sp -2 sp)
(ld gr0 0 gr3) ; 要素を取り出す
(st gr0 0 sp)
(st gr4 1 sp)
(call cons) ; -> gr0
(lad sp 2 sp)
(ld gr4 gr0)
(lad gr3 -1 gr3)
(jump vector->list-loop)
vector->list-exit
(ld gr0 gr4)
(pop gr4)
(pop gr3)
(pop gr2)
(unlk gr7)
(ret)
; LIST
; 入力 +2) : 個数 N
; +3) : これ以降にリストに格納する要素が N 個続く
; 出力 gr0 : リスト
list
(link gr7 0)
(lad sp -2 sp)
(ld gr0 2 gr7)
(st gr0 1 sp) ; 個数をセット
(lad gr0 3 gr7) ; スタックのアドレスをセット
(st gr0 0 sp)
(call vector->list) ; -> gr0
(lad sp 2 sp)
(unlk gr7)
(ret)
vector->list は前回作成した連結リストライブラリの vector->list とほとんど同じです。gr4 にリストの先頭セルを保持します。gr2 にベクタの先頭アドレス、gr3 に末尾要素のアドレスをセットし、末尾から順番に要素を取り出して、cons でリストの先頭に追加していくだけです。サブルーチン list は vector->list を呼び出すだけです。
次は iota を作りましょう。iota は拙作のページ リスト操作と高階関数 で作成したことがあります。このときは n から値を増やしていきましたが、今回は値が整数しかないので、m から始めて値を 1 ずつ減らしていくにします。プログラムは次のようになります。
リスト : リストの生成 (2)
; IOTA
; 入力 +2) : n
; +3) : m
; 出力 gr0 : (n ... m)
iota
(link gr7 0)
(push 0 gr2)
(push 0 gr3)
(ld gr3 3 gr7) ; m
(xor gr2 gr2) ; 生成するリスト
iota-loop
(cpa gr3 2 gr7)
(jmi iota-exit)
; m を gr2 の先頭に追加
(lad sp -2 sp)
(st gr3 0 sp)
(st gr2 1 sp)
(call cons)
(lad sp 2 sp)
(ld gr2 gr0)
(lad gr3 -1 gr3)
(jump iota-loop)
iota-exit
(ld gr0 gr2)
(pop gr3)
(pop gr2)
(unlk gr7)
(ret)
gr2 にリストを保持し、gr3 に m の値をセットします。あとは、gr3 が n 以上であれば、gr3 の値をリストの先頭に追加します。gr3 が n よりも小さくなったら、繰り返しを脱出して生成したリストを返します。
●再帰呼び出しとスタックオーバーフロー
リストの操作は再帰呼び出しを使うと簡単ですが、COMET2A のスタックは 8 k word の大きさしかありません。このため、再帰呼び出しが深くなるとスタックがオーバーフローする危険性があります。たとえば、リストを連結する append を Common Lisp でプログラムすると次のようになります。
リスト : リストの連結 (Common Lisp 版)
(defun append-rec (xs ys)
(if (null xs)
ys
(cons (car xs) (append-rec (cdr xs) ys))))
再帰を使っているので関数名は append-rec としました。このように、リストの連結は再帰を使うと簡単です。これをそのまま COMET2A でプログラムすると次のようになります。
リスト : リストの連結 (再帰版)
; APPEND
; 入力 +2) : リスト a
; +3) : リスト b
; 出力 gr0 : リスト (a + b)
append-rec
(link gr7 0)
(ld gr0 2 gr7) ; a -> gr0
(jze append-rec-null)
(lad sp -2 sp)
(ld gr0 1 gr0) ; (cdr gr0) -> gr0
(st gr0 0 sp)
(ld gr0 3 gr7)
(st gr0 1 sp)
(call append-rec) ; 再帰 -> gr0
(st gr0 1 sp)
(ld gr0 2 gr7) ; a -> gr0
(ld gr0 0 gr0) ; (car gr0) -> gr0
(st gr0 0 sp)
(call cons) ; -> gr0
(lad sp 2 sp)
append-rec-exit
(unlk gr7)
(ret)
append-rec-null
(ld gr0 3 gr7) ; b をそのまま返す
(jump append-rec-exit)
引数のリスト a を取り出して gr0 にセットします。その値が null (0) であれば引数のリスト b を返します。そうでなければ、append-rec を再帰呼び出しします。そして、その返り値にリスト a の先頭要素を追加します。このように COMET2A でも再帰呼び出しを使えば簡単にプログラムできます。
append-rec は呼び出すたびに 2 つの引数がスタックに積まれます。それだけではなく、リターンアドレスとフレームポインタの値も積まれるため、1 回の呼び出しでスタックを 4 word 消費します。スタックの大きさは 8192 - 1 = 8191 しかないので、append-rec の再帰呼び出しは最大で 2047 回までしか行えません。つまり、append-rec では長さが 2047 までのリストしか連結できないわけです。
今回のプログラムではセルの総数が 8192 個あるので、append-rec で連結するとスタックオーバーフローするような長いリストを扱うこともできます。このままでは不便なので、基本的なリスト操作は再帰呼び出しをなるべく使わずに繰り返しでプログラムすることにします。
Common Lisp の場合、append-rec を繰り返しに変換すると次のようになります。
リスト : リストの連結 (非再帰、Common Lisp 版)
(defun append+ (xs ys)
(do* ((header (list nil))
(p header)
(ls xs (cdr ls)))
((null ls) (rplacd p ys) (cdr header))
(let ((q (list (car ls))))
(rplacd p q)
(setf p q))))
関数名は append+ としました。まず最初にヘッダ header を用意します。リストは header の後ろにつなげます。変数 p は末尾のセルを保持します。繰り返しの中で、リストの要素を取り出して新しいセル q を生成します。そして、p の CDR に q をセットします。これでリストの末尾に新しいセルを接続することができます。あとは q を p にセットして処理を繰り返します。最後に p の CDR に ys をセットして、(cdr header) を返します。これで xs と ys を連結することができます。
これをそのまま COMET2A でプログラムすると次のようになります。
リスト : リストの連結
; APPEND (非再帰版)
; 入力 +2) : リスト a
; +3) : リスト b
; 出力 gr0 : リスト (a + b)
append
(link gr7 -2) ; header を用意
(push 0 gr2)
(push 0 gr3)
(push 0 gr4)
(lad gr2 -2 gr7)
(xor gr3 gr3) ; gr3 = null (0)
(st gr3 0 gr2) ; header を 0 クリア
(st gr3 1 gr2)
(ld gr4 2 gr7) ; a -> gr4
append-loop
(jze append-exit)
(lad sp -2 sp)
(ld gr0 0 gr4) ; (car gr4) -> gr0
(st gr0 0 sp)
(st gr3 1 sp) ; null
(call cons) ; -> gr0
(lad sp 2 sp)
(st gr0 1 gr2) ; 末尾セルに接続
(ld gr2 gr0)
(ld gr4 1 gr4) ; (cdr gr4) -> gr4
(jump append-loop)
append-exit
(ld gr0 3 gr7)
(st gr0 1 gr2) ; リスト b を接続
(ld gr0 -1 gr7) ; (cdr header) -> gr0
(pop gr4)
(pop gr3)
(pop gr2)
(unlk gr7)
(ret)
header は局所変数として用意し、gr2 が末尾のセルを保持します。引数のリスト a を gr4 にセットし、要素を順番に取り出して cons で新しいセルに格納します。そして、それを末尾セル gr2 の CDR にセットします。最後に局所変数 header からリストを取り出して返します。
●畳み込み
リストの先頭から畳み込みを行う fold-left は繰り返しで簡単にプログラムできますが、リストの末尾から畳み込みを行う fold-right はちょっと工夫が必要になります。Common Lisp でプログラムを作ると次のようになります。
リスト : 畳み込み
; 再帰版
(defun fold-right (fn a ls)
(if (null ls)
a
(funcall fn (car ls) (fold-right fn a (cdr ls)))))
; 繰り返し版
(defun fold-right+ (fn a ls)
(dolist (x (reverse ls) a)
(setf a (funcall fn x a))))
fold-right+ はリスト ls を reverse で反転することで繰り返しに変換しています。この場合、新しいリストを作ることになるので、残念ながら効率的なプログラムとはいえませんが、再帰版の fold-right と違ってスタックオーバーフローすることはありません。
fold-right+ を COMET2A でプログラムすると次のようになります。
リスト : 畳み込み
; FOLD-RIGHT
; 入力 +2) : サブルーチン (2 引数 (func x a))
; +3) : 初期値
; +4) : リスト
; 出力 gr0 :
fold-right
(link gr7 0)
(push 0 gr2)
(push 0 gr3)
(push 0 gr4)
(ld gr4 3 gr7) ; リスト -> gr4
(ld gr2 2 gr7) ; サブルーチン -> gr2
(ld gr3 4 gr7) ; 累積変数 -> gr3
; リストを反転する
(push 0 gr4)
(call reverse) ; -> gr4
(pop gr4)
(ld gr4 gr0) ; リスト -> gr4
fold-right-loop
(jze fold-right-exit) ; null check
(lad sp -2 sp)
(ld gr0 0 gr4) ; (car gr4) -> gr0
(st gr0 0 sp) ; 要素をセット
(st gr3 1 sp)
(call 0 gr2) ; -> gr0
(lad sp 2 sp)
(ld gr3 gr0)
(ld gr4 1 gr4)
(jump fold-right-loop)
fold-right-exit
(ld gr0 gr3)
(pop gr4)
(pop gr3)
(pop gr2)
(unlk gr7)
(ret)
引数からリストを取り出して gr4 にセットし、それを reverse で反転します。あとは、リストの要素を順番に取り出して fn に適用し、その結果を累積変数 gr3 にセットします。この処理は繰り返しで簡単に実現できます。
●リストの削除
あとのサブルーチンはとくに難しいところはないのですが、remove-if が他と少し変わっているので、ここで詳しく説明しましょう。サブルーチン remove-if は述語 fn と fn に渡す引数 x とリストを受け取ります。Common Lisp でプログラムすると次のようになります。
リスト : リストの要素を削除する
(defun remove-if+ (fn x ls)
(cond ((null ls) nil)
((funcall fn (car ls) x)
(remove-if+ fn x (cdr ls)))
(t (cons (car ls) (remove-if+ fn x (cdr ls))))))
関数名は remove-if+ としました。簡単な例として n の倍数を削除する関数 remove-multiple を作ってみます。クロージャを使うと、remove-if で簡単にプログラムできます。
リスト : n の倍数を削除する (defun remove-multiple (n ls) (remove-if #'(lambda (x) (zerop (mod x n))) ls))
(remove-multiple 3 '(1 2 3 4 5 6 7 8 9)) => (1 2 4 5 7 8)
クロージャを使わない場合、二つの引数を受け取る関数 multiple を定義して、remove-if+ から呼び出します。プログラムは次のようになります。
リスト : n の倍数を削除する (2) (defun multiplep (n m) (zerop (mod n m))) (defun remove-multiple+ (n ls) (remove-if+ #'multiplep n ls))
(remove-multiple+ 3 '(1 2 3 4 5 6 7 8 9)) => (1 2 4 5 7 8)
multiplep にリストの要素と引数 n が渡されるので、リスト ls から n の倍数を削除することができます。COMET2A にはクロージャという便利な機能がないので、そのかわりに引数 x をサブルーチンに渡すことにしたわけです。
COMET2A 用のサブルーチン remove-if は、Common Lisp 版の remove-if+ を繰り返しでプログラムしたものです。次のリストを見てください。
リスト : リストの削除
; REMOVE-IF (非再帰版)
; 入力 +2) : サブルーチン
; +3) : 要素と比較するデータ
; +4) : リスト
remove-if
(link gr7 -2) ; header を用意
(push 0 gr2)
(push 0 gr3)
(push 0 gr4)
(push 0 gr5)
(push 0 gr6)
(lad gr4 -2 gr7) ; gr4 は末尾セルを保持する
(xor gr5 gr5) ; gr5 = null (0)
(st gr5 0 gr4) ; header を 0 クリア
(st gr5 1 gr4)
(ld gr2 2 gr7) ; サブルーチン
(ld gr3 3 gr7) ; 比較するデータ
(ld gr6 4 gr7) ; リスト
remove-if-loop
(jze remove-if-exit)
(lad sp -2 sp)
; サブルーチンを呼び出す
(ld gr0 0 gr6) ; (car gr6) -> gr0
(st gr0 0 sp)
(st gr3 1 sp)
(call 0 gr2) ; -> gr0 (0:false, 1:true)
(and gr0 gr0)
(jnz remove-if-true) ; true の場合は削除
(ld gr0 0 gr6) ; (car gr6) -> gr0
(st gr0 0 sp)
(st gr5 1 sp)
(call cons) ; -> gr0
(st gr0 1 gr4) ; 末尾セルに接続
(ld gr4 gr0)
remove-if-true
(lad sp 2 sp)
(ld gr6 1 gr6) ; (cdr gr6) -> gr6
(jump remove-if-loop)
remove-if-exit
(ld gr0 -1 gr7) ; (cdr header) -> gr0
(pop gr6)
(pop gr5)
(pop gr4)
(pop gr3)
(pop gr2)
(unlk gr7)
(ret)
局所変数に header を用意して、その後ろにセルをつなげていきます。gr4 が末尾セルを保持します。サブルーチンに渡すデータは gr3 にセットします。サブルーチン fn を呼び出すとき、第 1 引数にリストの要素を、第 2 引数に gr3 を渡します。返り値 gr0 が 0 でなけれは、その要素をリストに追加しません。返り値が 0 ならば要素を新しいセルに格納し、末尾セル gr4 の CDR にセットします。
あとはとくに難しいところはないと思います。説明は割愛するので、詳細は プログラムリスト をお読みください。
●エラトステネスの篩
それでは、簡単な例題として「エラトステネスの篩 (ふるい) 」で素数を求めるプログラムを作りましょう。Common Lisp でプログラムを作ると次のようになります。
リスト : エラトステネスの篩 (Common Lisp 版)
(defun iota (n m)
(if (< m n)
nil
(cons n (iota (1+ n) m))))
(defun sieve (n)
(do ((ls (iota 2 n))
(a nil))
((null ls) (nreverse a))
(push (car ls) a)
(setf ls (remove-if #'(lambda (x) (zerop (mod x (car ls))))
(cdr ls)))))
sieve の処理は do ループで行います。iota で 2 から n までの整数列を生成し、それを変数 ls にセットします。繰り返しの中で、ls の先頭要素で割り切れる要素を remove-if で取り除きます。このとき、累積変数 a に (car ls) を追加します。ls が空リストになったら、nreverse でリスト a を反転して返します。
これを COMET2A でプログラムすると次のようになります。
リスト : エラトステネスの篩
sieve
(call initialize-heap)
(call initialize-list)
;
(lad sp -2 sp)
(lad gr0 2)
(st gr0 0 sp)
(lad gr0 100)
(st gr0 1 sp)
(call iota) ; 2 - 100 のリストを生成
(lad sp -2 sp)
(xor gr3 gr3) ; 素数のリスト -> gr3
(ld gr4 gr0) ; リスト -> gr4
sieve-loop
(lad sp -3 sp)
(ld gr2 0 gr4) ; 先頭要素 (gr2) は素数
(st gr2 0 sp)
(st gr3 1 sp)
(call cons)
(ld gr3 gr0) ; 素数をリスト gr3 に追加
(lad gr0 multiplep)
(st gr0 0 sp)
(st gr2 1 sp) ; 素数をセット
(ld gr0 1 gr4)
(st gr0 2 sp) ; CDR をセット
(call remove-if) ; ふるいにかける
(ld gr4 gr0)
(lad sp 3 sp)
(jnz sieve-loop) ; 空リストになれば終了
sieve-exit
(push 0 gr3)
(call nreverse)
(st gr0 0 sp)
(call print-list)
(call newline)
(pop gr0)
(halt)
; N は M の倍数か
; 入力 +2) : N
; +3) : M
; 出力 gr0 : N mod M == 0 ならば 1, else 0
multiplep
(link gr7 0)
(ld gr0 2 gr7)
(ld gr1 3 gr7)
(divl gr0 gr1) ; -> gr0 (商), gr1 (剰余)
(and gr1 gr1)
(jze multiplep-true)
(xor gr0 gr0)
multiplep-exit
(unlk gr7)
(ret)
multiplep-true
(lad gr0 1)
(jump multiplep-exit)
最初に initialize-heap でヒープ領域を初期化し、それから initialize-list でセル領域を初期化します。次に iota で 2 から 100 までの整数を格納したリストを生成します。このリストを gr4 にセットして、素数のリストを gr3 で保持します。
次に sieve-loop の中で、gr4 の先頭要素 (素数) を gr3 の先頭に追加します。そして、リスト (cdr gr4) から先頭要素の倍数を remove-if で削除します。このとき、第 2 引数に素数 (gr2) をセットします。これで gr2 の倍数を削除したリストが生成されます。あとはこの処理を繰り返して、gr4 が空リストになったら gr3 を nreverse で反転して print-list で表示します。
実行例を示します。
* (asm-run "lista.cas") 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97 NIL
100 以下の素数は全部で 25 通りあります。まだ GC が未実装なので、大きな素数を求めることはできません。たとえば、600 までの素数は求めることができますが、700 までの素数を求めると Out of memory になります。もちろん、GC が実装されるともっと大きな素数を求めることができます。
今回はここまでです。次回はガベージコレクションの実装に挑戦します。
●プログラムリスト
;
; lista.cas : 連結リストライブラリ (GC は未実装)
;
; Copyright (C) 2011 Makoto Hiroi
;
; セルのデータ構造
;
; CELL 0 [ data ] : CAR
; 1 [ adrs ] : CDR size = 2 word
;
; gr1 = CELL とすると
; ld gr0 0 gr1 => data
; ld gr0 1 gr1 => adrs
;
; 最初に initialize-list を呼び出すこと
; 新しいセルを取得
; 入力 : None
; 出力 : gr0 (New Cell)
make-cell
(ld gr0 free-cell)
(jze make-cell-error)
make-cell-lab1
(ld gr1 1 gr0)
(st gr1 free-cell)
(ret)
make-cell-error
(call gc)
(ld gr0 free-cell)
(jnz make-cell-lab1)
; GC で回収できず (エラー終了)
(push list-error2)
(call write-line)
(halt)
list-error2
(dc "make-cell : Out of memory" 0)
; CONS
; 入力 : +2) a データ
; +3) b セル or null(0)
; 出力 : gr0 新しいセル
cons
(link gr7 0)
(call make-cell) ; -> gr0
(ld gr1 2 gr7)
(st gr1 0 gr0) ; CAR
(ld gr1 3 gr7)
(st gr1 1 gr0) ; CDR
(unlk gr7)
(ret)
; ベクタ -> リスト
; 入力 +2) : バッファアドレス
; +3) : 個数
; 出力 gr0 : リスト
vector->list
(link gr7 0)
(push 0 gr2)
(push 0 gr3)
(push 0 gr4)
(xor gr4 gr4) ; リストを保持
(ld gr2 2 gr7) ; 先頭アドレス
(ld gr3 3 gr7) ; 個数
(addl gr3 gr2)
(lad gr3 -1 gr3) ; 末尾要素のアドレス
vector->list-loop
(cpl gr3 gr2) ; 末尾から先頭へ
(jmi vector->list-exit)
(lad sp -2 sp)
(ld gr0 0 gr3) ; 要素を取り出す
(st gr0 0 sp)
(st gr4 1 sp)
(call cons) ; -> gr0
(lad sp 2 sp)
(ld gr4 gr0)
(lad gr3 -1 gr3)
(jump vector->list-loop)
vector->list-exit
(ld gr0 gr4)
(pop gr4)
(pop gr3)
(pop gr2)
(unlk gr7)
(ret)
; LIST
; 入力 +2) : 個数 N
; +3) : これ以降にリストに格納する要素が N 個続く
; 出力 gr0 : リスト
list
(link gr7 0)
(lad sp -2 sp)
(ld gr0 2 gr7)
(st gr0 1 sp) ; 個数をセット
(lad gr0 3 gr7) ; スタックのアドレスをセット
(st gr0 0 sp)
(call vector->list) ; -> gr0
(lad sp 2 sp)
(unlk gr7)
(ret)
; IOTA
; 入力 +2) : n
; +3) : m
; 出力 gr0 : (n ... m)
iota
(link gr7 0)
(push 0 gr2)
(push 0 gr3)
(ld gr3 3 gr7) ; m
(xor gr2 gr2) ; 生成するリスト
iota-loop
(cpa gr3 2 gr7)
(jmi iota-exit)
; m を gr2 の先頭に追加
(lad sp -2 sp)
(st gr3 0 sp)
(st gr2 1 sp)
(call cons)
(lad sp 2 sp)
(ld gr2 gr0)
(lad gr3 -1 gr3)
(jump iota-loop)
iota-exit
(ld gr0 gr2)
(pop gr3)
(pop gr2)
(unlk gr7)
(ret)
; LIST-REF
; 入力 +2) : リスト
; +3) : 位置
; 出力 gr0 : 要素
list-ref
(link gr7 0)
(push 0 gr2)
(xor gr2 gr2)
(ld gr1 2 gr7)
list-ref-loop
(jze list-ref-err)
(cpl gr2 3 gr7)
(jze list-ref-exit)
(lad gr2 1 gr2)
(ld gr1 1 gr1)
(jump list-ref-loop)
list-ref-exit
(ld gr0 0 gr1)
(pop gr2)
(unlk gr7)
(ret)
list-ref-err
(push list-error3)
(call write-line)
(halt)
list-error3
(dc "list-ref : Out of range" 0)
; MEMBER
; 入力 +2) : データ
; +3) : リスト
; 出力 gr0 : リスト or null
member
(link gr7 0)
(ld gr0 3 gr7)
member-loop
(jze member-exit)
(ld gr1 0 gr0)
(cpa gr1 2 gr7)
(jze member-exit)
(ld gr0 1 gr0)
(jump member-loop)
member-exit
(unlk gr7)
(ret)
; リストの長さを求める
; 入力 +2) : セル
; 出力 gr0 : 長さ
length
(link gr7 0)
(xor gr0 gr0) ; 長さ
(ld gr1 2 gr7) ; リスト
length-loop
(jze length-exit)
(lad gr0 1 gr0) ; 長さ += 1
(ld gr1 1 gr1) ; (cdr gr1) -> gr1
(jump length-loop)
length-exit
(unlk gr7)
(ret)
; REVERSE
; 入力 +2) : セル
; 出力 gr0 : 逆順にしたリスト
reverse
(link gr7 0)
(push 0 gr2)
(push 0 gr3)
(xor gr2 gr2) ; 反転したリスト
(ld gr3 2 gr7) ; 引数のリスト
reverse-loop
(jze reverse-exit)
; gr3 の要素を gr2 の先頭に追加
(lad sp -2 sp)
(ld gr0 0 gr3) ; (car gr3) -> gr0
(st gr0 0 sp)
(st gr2 1 sp)
(call cons) ; -> gr0 (new-cell)
(lad sp 2 sp)
(ld gr2 gr0)
(ld gr3 1 gr3) ; (cdr gr3) -> gr3
(jump reverse-loop)
reverse-exit
(ld gr0 gr2)
(pop gr3)
(pop gr2)
(unlk gr7)
(ret)
; NREVERSE (破壊的操作)
; 入力 +2) : セル
; 出力 gr0 : 逆順にしたリスト
nreverse
(link gr7 0)
(push 0 gr2)
(xor gr0 gr0)
(ld gr1 2 gr7)
nreverse-loop
(jze nreverse-exit)
(ld gr2 1 gr1) ; 次のセル -> gr2
(st gr0 1 gr1) ; gr1 の CDR を gr0 に書き換える
(ld gr0 gr1)
(ld gr1 gr2)
(jump nreverse-loop)
nreverse-exit
(pop gr2)
(unlk gr7)
(ret)
; APPEND (非再帰版)
; 入力 +2) : リスト a
; +3) : リスト b
; 出力 gr0 : リスト (a + b)
append
(link gr7 -2) ; header を用意
(push 0 gr2)
(push 0 gr3)
(push 0 gr4)
(lad gr2 -2 gr7)
(xor gr3 gr3) ; gr3 = null (0)
(st gr3 0 gr2) ; header を 0 クリア
(st gr3 1 gr2)
(ld gr4 2 gr7) ; a -> gr4
append-loop
(jze append-exit)
(lad sp -2 sp)
(ld gr0 0 gr4) ; (car gr4) -> gr0
(st gr0 0 sp)
(st gr3 1 sp) ; null
(call cons) ; -> gr0
(lad sp 2 sp)
(st gr0 1 gr2) ; 末尾セルに接続
(ld gr2 gr0)
(ld gr4 1 gr4) ; (cdr gr4) -> gr4
(jump append-loop)
append-exit
(ld gr0 3 gr7)
(st gr0 1 gr2) ; リスト b を接続
(ld gr0 -1 gr7) ; (cdr header) -> gr0
(pop gr4)
(pop gr3)
(pop gr2)
(unlk gr7)
(ret)
; DROP
; 入力 +2) : N
; +3) : リスト
; 出力 gr0 :
drop
(link gr7 0)
(ld gr1 2 gr7)
(ld gr0 3 gr7)
drop-loop
(jze drop-exit)
(and gr1 gr1)
(jze drop-exit)
(lad gr1 -1 gr1)
(ld gr0 1 gr0)
(jump drop-loop)
drop-exit
(unlk gr7)
(ret)
; TAKE
; 入力 +2) : N
; +3) : リスト
; 出力 gr0 :
take
(link gr7 -2) ; header を用意
(push 0 gr2)
(push 0 gr3)
(push 0 gr4)
(lad gr2 -2 gr7) ; gr2 は末尾セルを保持
(xor gr0 gr0) ; header を 0 クリア
(st gr0 0 gr2)
(st gr0 1 gr2)
(ld gr3 2 gr7) ; N -> gr3
(ld gr4 3 gr7) ; リスト -> gr4
take-loop
(jze take-exit)
(and gr3 gr3)
(jze take-exit)
(lad sp -2 sp)
(ld gr0 0 gr4) ; (car gr4) -> gr0
(st gr0 0 sp)
(xor gr0 gr0)
(st gr0 1 sp)
(call cons) ; -> gr0
(lad sp 2 sp)
(st gr0 1 gr2) ; 末尾に接続
(ld gr2 gr0)
(lad gr3 -1 gr3)
(ld gr4 1 gr4) ; (cdr gr4) -> gr4
(jump take-loop)
take-exit
(ld gr0 -1 gr7) ; (cdr header) -> gr0
(pop gr4)
(pop gr3)
(pop gr2)
(unlk gr7)
(ret)
; MAP (非再帰版)
; 入力 +2) : サブルーチン (1 引数)
; +3) : リスト
; 出力 gr0 : リスト
map
(link gr7 -2) ; header を用意
(push 0 gr2)
(push 0 gr3)
(push 0 gr4)
(push 0 gr5)
(lad gr2 -2 gr7) ; gr2 は末尾セルを表す
(xor gr4 gr4) ; gr4 = null (0)
(st gr4 0 gr2) ; header を 0 クリア
(st gr4 1 gr2)
(ld gr3 2 gr7) ; サブルーチン -> gr3
(ld gr5 3 gr7) ; リスト -> gr5
map-loop
(jze map-exit)
(lad sp -2 sp)
; 要素にサブルーチンを適用する
(ld gr0 0 gr5) ; (car gr5) -> gr0
(st gr0 0 sp)
(call 0 gr3) ; -> gr0
; 結果をリストに格納
(st gr0 0 sp)
(st gr4 1 sp)
(call cons) ; -> gr0
(lad sp 2 sp)
(st gr0 1 gr2) ; 末尾セルに接続
(ld gr2 gr0)
(ld gr5 1 gr5)
(jump map-loop)
map-exit
(ld gr0 -1 gr7) ; (cdr header) -> gr0
(pop gr5)
(pop gr4)
(pop gr3)
(pop gr2)
(unlk gr7)
(ret)
; REMOVE (非再帰版)
; 入力 +2) : 削除する要素
; +3) : リスト
; 出力 gr0 : リスト
remove
(link gr7 -2) ; header を用意
(push 0 gr2)
(push 0 gr3)
(push 0 gr4)
(lad gr2 -2 gr7) ; gr2 は末尾セルを保持する
(xor gr3 gr3) ; gr3 = null (0)
(st gr3 0 gr2) ; header を 0 クリア
(st gr3 1 gr2)
(ld gr4 3 gr7) ; リスト -> gr4
remove-loop
(jze remove-exit)
(ld gr0 0 gr4) ; (car gr4) -> gr0
(cpa gr0 2 gr7)
(jze remove-true)
; 削除しないで gr2 に追加
(lad sp -2 sp)
(st gr0 0 sp)
(st gr3 1 sp)
(call cons) ; -> gr0
(lad sp 2 sp)
(st gr0 1 gr2)
(ld gr2 gr0)
remove-true
(ld gr4 1 gr4) ; (cdr gr4) -> gr4
(jump remove-loop)
remove-exit
(ld gr0 -1 gr7) ; (cdr header) -> gr0
(pop gr4)
(pop gr3)
(pop gr2)
(unlk gr7)
(ret)
; REMOVE-IF (非再帰版)
; 入力 +2) : サブルーチン
; +3) : 要素と比較するデータ
; +4) : リスト
remove-if
(link gr7 -2) ; header を用意
(push 0 gr2)
(push 0 gr3)
(push 0 gr4)
(push 0 gr5)
(push 0 gr6)
(lad gr4 -2 gr7) ; gr4 は末尾セルを保持する
(xor gr5 gr5) ; gr5 = null (0)
(st gr5 0 gr4) ; header を 0 クリア
(st gr5 1 gr4)
(ld gr2 2 gr7) ; サブルーチン
(ld gr3 3 gr7) ; 比較するデータ
(ld gr6 4 gr7) ; リスト
remove-if-loop
(jze remove-if-exit)
(lad sp -2 sp)
; サブルーチンを呼び出す
(ld gr0 0 gr6) ; (car gr6) -> gr0
(st gr0 0 sp)
(st gr3 1 sp)
(call 0 gr2) ; -> gr0 (0:false, 1:true)
(and gr0 gr0)
(jnz remove-if-true) ; true の場合は削除
(ld gr0 0 gr6) ; (car gr6) -> gr0
(st gr0 0 sp)
(st gr5 1 sp)
(call cons) ; -> gr0
(st gr0 1 gr4) ; 末尾セルに接続
(ld gr4 gr0)
remove-if-true
(lad sp 2 sp)
(ld gr6 1 gr6) ; (cdr gr6) -> gr6
(jump remove-if-loop)
remove-if-exit
(ld gr0 -1 gr7) ; (cdr header) -> gr0
(pop gr6)
(pop gr5)
(pop gr4)
(pop gr3)
(pop gr2)
(unlk gr7)
(ret)
; 畳み込み
; 入力 +2) : サブルーチン (2 引数 (func a x))
; +3) : 初期値
; +4) : リスト
; 出力 gr0 :
fold-left
(link gr7 0)
(push 0 gr2)
(push 0 gr3)
(push 0 gr4)
(ld gr2 3 gr7) ; 初期値 (累積変数)
(ld gr3 2 gr7) ; サブルーチン
(ld gr4 4 gr7) ; リスト
fold-left-loop
(jze fold-left-exit)
(lad sp -2 sp)
(st gr2 0 sp) ; 累積変数
(ld gr0 0 gr4) ; (car gr4) -> gr0
(st gr0 1 sp)
(call 0 gr3) ; -> gr0
(lad sp 2 sp)
(ld gr2 gr0)
(ld gr4 1 gr4)
(jump fold-left-loop)
fold-left-exit
(ld gr0 gr2)
(pop gr4)
(pop gr3)
(pop gr2)
(unlk gr7)
(ret)
; 畳み込み (非再帰版)
; 入力 +2) : サブルーチン (2 引数 (func x a))
; +3) : 初期値
; +4) : リスト
; 出力 gr0 : 結果
fold-right
(link gr7 0)
(push 0 gr2)
(push 0 gr3)
(push 0 gr4)
(ld gr4 4 gr7) ; リスト -> gr4
(ld gr2 2 gr7) ; サブルーチン -> gr2
(ld gr3 3 gr7) ; 累積変数 -> gr3
; リストを反転する
(push 0 gr4)
(call reverse) ; -> gr4
(pop gr4)
(ld gr4 gr0) ; リスト -> gr4
fold-right-loop
(jze fold-right-exit) ; null check
(lad sp -2 sp)
(ld gr0 0 gr4) ; (car gr4) -> gr0
(st gr0 0 sp) ; 要素をセット
(st gr3 1 sp)
(call 0 gr2) ; -> gr0
(lad sp 2 sp)
(ld gr3 gr0)
(ld gr4 1 gr4)
(jump fold-right-loop)
fold-right-exit
(ld gr0 gr3)
(pop gr4)
(pop gr3)
(pop gr2)
(unlk gr7)
(ret)
; リストの要素にサブルーチンを適用する
; 入力 +2) : サブルーチン
; +3) : リスト
; 出力 None
for-each
(link gr7 0)
(push 0 gr2)
(push 0 gr3)
(ld gr2 2 gr7) ; サブルーチン
(ld gr3 3 gr7) ; セル
for-each-loop
(jze for-each-exit)
(ld gr0 0 gr3) ; 要素をセット
(push 0 gr0)
(call 0 gr2) ; サブルーチンを呼び出す
(pop gr0)
(ld gr3 1 gr3) ; 次のセル
(jump for-each-loop)
for-each-exit
(pop gr3)
(pop gr2)
(unlk gr7)
(ret)
; 空白付き出力
; 入力 +2) : 数値
; 出力 None
prints
(link gr7 0)
(ld gr0 2 gr7)
(push 0 gr0)
(call print) ; 要素を出力
(lad gr0 32) ; 空白
(st gr0 0 sp)
(call write-char)
(pop gr0)
(unlk gr7)
(ret)
; リストの表示
; 入力 +2) : セル
print-list
(link gr7 0)
(lad sp -2 sp)
(lad gr0 prints) ; 表示用関数
(st gr0 0 sp)
(ld gr0 2 gr7) ; セル
(st gr0 1 sp)
(call for-each)
(lad sp 2 sp)
(unlk gr7)
(ret)
;;;
;;; GC (未実装)
;;;
gc
(ret)
; リストの初期化
; 入力 : None
; 出力 : None
initialize-list
(push #x4000) ; 引数セット
(call malloc) ; メモリ取得 (cell は 8k 個)
(pop gr1) ; 引数破棄
(and gr0 gr0)
(jze initialize-list-err)
(st gr0 cell-top) ; セル領域開始アドレス
(lad gr1 #x4000 gr0)
(st gr1 cell-end) ; セル領域終了アドレス
;
(st gr0 free-cell) ; フリーリストの先頭
initialize-loop
(lad gr1 2 gr0) ; 次のセルのアドレス
(cpl gr1 cell-end)
(jze initialize-exit)
(st gr1 1 gr0) ; CDR にセット
(ld gr0 gr1)
(jump initialize-loop)
initialize-exit
(xor gr1 gr1)
(st gr1 1 gr0) ; null で終端
(ret)
initialize-list-err
; エラー終了
(push list-error1)
(call write-line)
(halt)
list-error1
(dc "initialize-list : Out of memory" 0)
; 終了
; 入力 None
; 出力 None
destroy-list
(ld gr0 cell-top)
(push 0 gr0)
(call free)
(pop gr0)
(ret)
;;;
;;; セル領域
;;;
cell-top
(ds 1)
cell-end
(ds 1)
free-cell
(ds 1)