M.Hiroi's Home Page

Common Lisp Programming

Common Lisp 入門:番外編

[ PrevPage | Common Lisp | NextPage ]

●仮想計算機 COMETⅡの簡易シミュレータ (11)

Common Lisp 入門 の番外編です。前回は COMETA2A 用の簡単な「連結リストライブラリ」にガベージコレクション機能を追加しました。今回は連結リストライブラリを使った簡単なサンプルプログラムを作ります。

●順列の生成

まずは簡単な例題として、順列を生成するプログラムを作りましょう。リストを受け取り、その要素の順列を求めるプログラムは、Common Lisp で書くと次のようになります。

リスト : 順列の生成

(defun perm (func ls &optional a)
  (if (null ls)
      (funcall func a)
    (dolist (x ls)
      (perm func (remove x ls) (cons x a)))))

perm は高階関数です。リスト ls から要素を取り出し、累積変数 a に含まれていなければ、その要素を ls から取り除いて a に追加します。ls が空リストの場合は func に a を適用します。

簡単な実行例を示します。

* (perm #'print '(a b c d))

(D C B A) 
(C D B A) 
(D B C A) 
(B D C A) 
(C B D A) 
(B C D A) 
(D C A B) 
(C D A B) 
(D A C B) 
(A D C B) 
(C A D B) 
(A C D B) 
(D B A C) 
(B D A C) 
(D A B C) 
(A D B C) 
(B A D C) 
(A B D C) 
(C B A D) 
(B C A D) 
(C A B D) 
(A C B D) 
(B A C D) 
(A B C D) 
NIL

これを COMET2A でプログラムすると次のようになります。

リスト :  順列の生成

; 入力 +2) : サブルーチン
;      +3) : リスト
;      +4) : 順列を格納するリスト
; 出力 None
perm
        (link gr7 0)
        (push 0 gr2)
        (push 0 gr3)
        (ld   gr3 3 gr7)
        (jze  perm-lab1)        ; 空リスト
perm-loop
        (lad  sp -3 sp)
        (ld   gr0 0 gr3)        ; (CAR gr3) -> gr0
        (st   gr0 0 sp)
        (ld   gr0 3 gr7)
        (st   gr0 1 sp)
        (call remove)           ; (remove x ls) -> gr0
        (ld   gr2 gr0)          ; gr0 -> gr2
        (ld   gr0 4 gr7)        ; (CAR gr3) はセットされたまま
        (st   gr0 1 sp)         ; 累積変数 (リスト) をセット
        (call cons)             ; (cons x a) -> gr0
        (st   gr2 1 sp)
        (st   gr0 2 sp)         ; リストをセット
        (ld   gr0 2 gr7)        ; 累積変数をセット
        (st   gr0 0 sp)         ; サブルーチンをセット
        (call perm)             ; 再帰呼び出し
        (lad  sp 3 sp)
        (ld   gr3 1 gr3)
        (jnz  perm-loop)
perm-exit
        (pop  gr3)
        (pop  gr2)
        (unlk gr7)
        (ret)
perm-lab1
        (ld   gr0 4 gr7)
        (push 0 gr0)            ; 累積変数をセット
        (ld   gr0 2 gr7)
        (call 0 gr0)            ; サブルーチンを呼び出す
        (pop  gr0)
        (jump perm-exit)

Common Lisp のプログラムとほぼ同じなので、とくに難しいところはないと思います。コメントをみながら、リストをお読みくださいませ。

簡単な実行例を示します。

リスト : perm のテスト

perm-test
        (call initialize-heap)
        (call initialize-list)
        (lad  sp -3 sp)
        (lad  gr0 1)
        (st   gr0 0 sp)
        (lad  gr0 4)
        (st   gr0 1 sp)
        (call iota)             ; (iota 1 4) -> gr0
        (st   gr0 1 sp)
        (xor  gr0 gr0)
        (st   gr0 2 sp)
        (lad  gr0 print-list)
        (st   gr0 0 sp)
        (call perm)
        (lad  sp 3 sp)
        (halt)
* (asm-run "test.cas")
4 3 2 1
3 4 2 1
4 2 3 1
2 4 3 1
3 2 4 1
2 3 4 1
4 3 1 2
3 4 1 2
4 1 3 2
1 4 3 2
3 1 4 2
1 3 4 2
4 2 1 3
2 4 1 3
4 1 2 3
1 4 2 3
2 1 4 3
1 2 4 3
3 2 1 4
2 3 1 4
3 1 2 4
1 3 2 4
2 1 3 4
1 2 3 4
NIL

(iota 1 4) よりも長いリスト、たとえば (iota 1 8) でも順列を求めることができます。

●リストのマージ

次はリストをマージするプログラムを作りましょう。マージ (併合) とは、複数のソート済み列をひとつのソート済みの列にまとめる操作です。Common Lisp でプログラムを作ると次のようになります。

リスト : リストのマージ

(defun merge-list (pred xs ys)
  (cond ((null xs) ys)
        ((null ys) xs)
        ((funcall pred (car xs) (car ys))
         (cons (car xs) (merge-list pred (cdr xs) ys)))
        (t (cons (car ys) (merge-list pred xs (cdr ys))))))

Common Lisp には関数 merge があるので、関数名は merge-list としました。最初の節は、空リストとリスト ys をマージすると ys になることを表しています。次の節は、リスト xs と空リストをマージすると xs になることを表しています。この 2 つの節が、再帰呼び出しの停止条件になります。

3 番目の節で、それぞれのリストの先頭要素を述語 pred で比較し、pred が真を返す場合は (car xs) をマージしたリストの先頭に追加し、そうでなければ最後の節で (car ys) をマージしたリストの先頭に追加します。merge-list を再帰呼び出しするときは、xs または ys の先頭要素を取り除いて呼び出すことに注意してください。

簡単な実行例を示します。

* (setq a '(1 2 5 6 9))
(1 2 5 6 9)
* (setq b '(3 4 7 8 10))
(3 4 7 8 10)
* (merge-list #'< a b)
(1 2 3 4 5 6 7 8 9 10)
* a
(1 2 5 6 9)
* b
(3 4 7 8 10)

merge-list は新しいリストを生成して返すことに注意してください。元のリスト a, b は破壊されません。

COMET2A でプログラムすると次のようになります。

リスト : リストのマージ (非破壊版)

; 入力 +2) : 比較サブルーチン
;      +3) : リスト a
;      +4) : リスト b
merge
        (link gr7 -2)           ; header を用意
        (push 0 gr2)
        (push 0 gr3)
        (push 0 gr4)
        (push 0 gr5)
        (push 0 gr6)
        (ld   gr3 3 gr7)
        (jze  merge-exit-b)     ; b を返す
        (ld   gr4 4 gr7)
        (jze  merge-exit-a)     ; a を返す
        ;
        (lad  gr2 -2 gr7)       ; gr2 は末尾セルを保持する
        (xor  gr6 gr6)          ; header を 0 クリア
        (st   gr6 0 gr2)
        (st   gr6 1 gr2)
        (ld   gr5 2 gr7)        ; 比較サブルーチン
merge-loop
        (lad  sp -2 sp)
        (ld   gr0 0 gr4)
        (st   gr0 0 sp)         ; (CAR b) をセット
        (ld   gr0 0 gr3)
        (st   gr0 1 sp)         ; (CAR a) をセット
        (call 0 gr5)            ; -> gr0 (-, 0, +)
        (lad  sp 2 sp)
        (and  gr0 gr0)
        (jmi  merge-lb)
        ; a <= b
        (lad  sp -2 sp)
        (ld   gr0 0 gr3)        ; (car a) -> gr0
        (st   gr0 0 sp)
        (st   gr6 1 sp)         ; null
        (call cons)             ; -> gr0
        (lad  sp 2 sp)
        (st   gr0 1 gr2)        ; 末尾に接続
        (ld   gr2 gr0)
        (ld   gr3 1 gr3)
        (jnz  merge-loop)
        ; a が空リストになった
        (st   gr4 1 gr2)        ; b を末尾に接続
        (jump merge-exit)
merge-lb
        ; a > b
        (lad  sp -2 sp)
        (ld   gr0 0 gr4)        ; (car b) -> gr0
        (st   gr0 0 sp)
        (st   gr6 1 sp)         ; null
        (call cons)             ; -> gr0
        (lad  sp 2 sp)
        (st   gr0 1 gr2)        ; 末尾に接続
        (ld   gr2 gr0)
        (ld   gr4 1 gr4)
        (jnz  merge-loop)
        ; b が空リストになった
        (st   gr3 1 gr2)        ; a を末尾に接続
merge-exit
        (ld   gr0 -1 gr7)       ; (cdr header) -> gr0
merge-exit1
        (pop  gr6)
        (pop  gr5)
        (pop  gr4)
        (pop  gr3)
        (pop  gr2)
        (unlk gr7)
        (ret)
merge-exit-b
        (ld   gr0 4 gr7)
        (jump merge-exit1)
merge-exit-a
        (ld   gr0 gr3)
        (jump merge-exit1)

Common Lisp は再帰呼び出しでプログラムしていますが、COMET2A は繰り返しでプログラムしています。局所変数にヘッダを用意して、末尾のセルに新しいセルをつなげていきます。あとはとくに難しいところはないでしょう。コメントをみながら、リストをお読みくださいませ。

簡単な実行例を示します。

リスト : merge のテスト

test-merge
        (call initialize-heap)
        (call initialize-list)
        (lad  sp -3 sp)
        (lad  gr0 data02a)
        (st   gr0 0 sp)
        (ld   gr0 len02)
        (st   gr0 1 sp)
        (call vector->list)
        (ld   gr2 gr0)
        (lad  gr0 data02b)
        (st   gr0 0 sp)
        (ld   gr0 len02)
        (st   gr0 1 sp)
        (call vector->list)
        (st   gr0 2 sp)
        (st   gr2 1 sp)
        (lad  gr0 cmp)
        (st   gr0 0 sp)
        (call merge)
        (st   gr0 0 sp)
        (call print-list)
        (call newline)
        (lad  sp 3 sp)
        (halt)
len02   (dc 5)
data02a (dc 2 4 6 8 10)
data02b (dc 1 3 5 7 9)

; 比較関数
cmp
        (link gr7 0)
        (ld   gr0 2 gr7)
        (suba gr0 3 gr7)
        (unlk gr7)
        (ret)
* (asm-run "test.cas")
1 2 3 4 5 6 7 8 9 10
NIL

●マージソート

マージソートは、このマージを使ってデータをソートします。次の図を見てください。

  9 5 3 7 6 4 2 8  最初の状態

 |5 9|3 7|4 6|2 8| 長さ2の列に併合

 |3 5 7 9|2 4 6 8| 長さ4の列に併合 

  2 3 4 5 6 7 8 9  ソート終了


        図 : マージソート

マージをソートに応用する場合、最初は各要素をソート済みのリストとして考えます。この状態で隣のリストとマージを行い、長さ 2 のリストを作ります。次に、このリストに対して再度マージを行い、長さ 4 のリストを作ります。このように順番にマージしていくと、最後にはひとつのリストにマージされソートが完了します。

マージソートはリストの長さを 1, 2, 4, 8, ... と増やしていくよりも、再帰的に考えた方が簡単です。まず、ソートするリストを 2 つに分割して、前半部分をソートします。次に、後半部分をソートして、その結果をマージすればいいわけです。

再帰呼び出しするたびにリストは 2 つに分割されるので、最後にリストの要素はひとつとなります。これはソート済みのリストなので、ここで再帰呼び出しを終了してマージ処理を行えばいいわけです。Common Lisp でプログラムを作ると次のようになります。

リスト : マージソート

(defun merge-sort (pred ls n)
  (if (= n 1)
      (list (car ls))
    (let ((m (floor n 2)))
      (merge-list pred
                  (merge-sort pred ls m)
                  (merge-sort pred (nthcdr m ls) (- n m))))))

最初の節は、空リストとリスト ys をマージすると ys になることを表しています。次の節は、リスト xs と空リストをマージすると xs になることを表しています。この 2 つの節が、再帰呼び出しの停止条件になります。

3 番目の節で、それぞれのリストの先頭要素を述語 pred で比較し、pred が真を返す場合は (car xs) をマージしたリストの先頭に追加し、そうでなければ最後の節で (car ys) をマージしたリストの先頭に追加します。merge-list を再帰呼び出しするときは、xs または ys の先頭要素を取り除いて呼び出すことに注意してください。

簡単な実行例を示します。

* (merge-sort #'< '(5 6 4 7 3 8 2 9 1) 9)
(1 2 3 4 5 6 7 8 9)

merge-sort は新しいリストを生成して返すことに注意してください。

COMET2A でプログラムを作ると、次のようになります。

リスト : マージソート (非破壊版)

; 入力 +2) : 比較サブルーチン
;      +3) : リスト
;      +4) : 長さ N
; 出力 gr0 : ソート済みリスト
merge-sort
        (link gr7 0)
        (push 0 gr2)
        (push 0 gr3)
        (push 0 gr4)
        (push 0 gr5)
        (push 0 gr6)
        (ld   gr6 3 gr7)        ; リスト -> gr6
        (ld   gr2 4 gr7)        ; N -> gr2
        (lad  gr0 1)
        (cpl  gr0 gr2)
        (jze  merge-sort-1)     ; 要素はひとつ
        (jpl  merge-sort-0)     ; 要素はない
        (ld   gr5 2 gr7)        ; 比較サブルーチン -> gr5
        (ld   gr3 gr2)
        (srl  gr2 1)            ; N / 2 -> gr2
        (subl gr3 gr2)          ; N - (N / 2) -> gr3
        (lad  sp -3 sp)
        (st   gr5 0 sp)         ; 前半をソート
        (st   gr6 1 sp)
        (st   gr2 2 sp)
        (call merge-sort)       ; -> gr0
        (ld   gr4 gr0)          ; gr0 -> gr4
        (st   gr2 0 sp)
        (st   gr6 1 sp)
        (call drop)             ; -> gr0 (後半の先頭)
        (st   gr5 0 sp)         ; 後半をソート
        (st   gr0 1 sp)
        (st   gr3 2 sp)
        (call merge-sort)       ; -> gr0
        (st   gr5 0 sp)         ; 前半と後半をマージする
        (st   gr4 1 sp)
        (st   gr0 2 sp)
        (call merge)            ; -> gr0
        (lad  sp 3 sp)
merge-sort-exit
        (pop  gr6)
        (pop  gr5)
        (pop  gr4)
        (pop  gr3)
        (pop  gr2)
        (unlk gr7)
        (ret)
merge-sort-1
        (lad  sp -2 sp)
        (ld   gr0 0 gr6)        ; (car gr6) -> gr0
        (st   gr0 0 sp)
        (xor  gr0 gr0)
        (st   gr0 1 sp)
        (call cons)             ; -> gr0
        (lad  sp 2 sp)
        (jump merge-sort-exit)
merge-sort-0
        (xor  gr0 gr0)
        (jump merge-sort-exit)

プログラムは長くなりましたが、とくに難しいところはないと思います。コメントをみながらリストをお読みくださいませ。

簡単な実行例を示します。

リスト : merge-sort のテスト

test-merge-sort
        (call initialize-heap)
        (call initialize-list)
	(lad  sp -3 sp)
	(lad  gr0 data03)
	(st   gr0 0 sp)
	(ld   gr0 len03)
	(st   gr0 1 sp)
	(call vector->list)	; -> gr0
	(st   gr0 1 sp)
	(lad  gr0 cmp)
	(st   gr0 0 sp)
	(ld   gr0 len03)
	(st   gr0 2 sp)
	(call merge-sort)
	(st   gr0 0 sp)
	(call print-list)
	(call newline)
	(lad  sp 3 sp)
	(halt)
len03	(dc 10)
data03	(dc 5 6 4 7 3 8 2 9 1 0)
* (asm-run "test.cas")
0 1 2 3 4 5 6 7 8 9
NIL

ところで、merge-list と merge-sort はリストを破壊的に操作してもプログラムすることができます。興味のある方は挑戦してみてください。


●プログラムリスト

;
; 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 4 gr7)        ; 初期値 (累積変数)
        (ld   gr3 2 gr7)        ; サブルーチン
        (ld   gr4 3 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 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)

; リストの要素にサブルーチンを適用する
; 入力 +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 (Mark-sweep 法)
;;;

; MARK
; 入力 +2) : 開始アドレス
;      +3) : 終了アドレス
; 出力 None
gc-mark
        (link gr7 0)
        (ld   gr1 2 gr7)        ; 開始アドレス
gc-mark-loop0
        (cpl  gr1 3 gr7)
        (jze  gc-mark-exit)
        (ld   gr2 0 gr1)
        (cpl  gr2 cell-top)
        (jmi  gc-mark-lab1)     ; cell-top 未満
        (cpl  gr2 cell-end)
        (jpl  gc-mark-lab1)     ; cell-end 以上
        (ld   gr0 gr2)
        (and  gr0 gc-flag)
        (jnz  gc-mark-lab1)     ; 奇数は関係なし
        ;
gc-mark-loop1
        (ld   gr0 1 gr2)        ; CDR -> gr0
        (and  gr0 gc-flag)
        (jnz  gc-mark-lab1)     ; mark 済み
        (ld   gr0 1 gr2)
        (ld   gr3 gr0)          ; CDR -> gr0, gr3
        (or   gr0 gc-flag)
        (st   gr0 1 gr2)        ; flag-on
        (ld   gr2 gr3)          ; 次のセルへ
        (jnz  gc-mark-loop1)
gc-mark-lab1
        (lad  gr1 1 gr1)
        (jump gc-mark-loop0)
        ;
gc-mark-exit
        (unlk gr7)
        (ret)

; SWEEP
gc-sweep
        (xor  gr0 gr0)
        (st   gr0 free-cell)    ; null clear
        (ld   gr1 cell-top)
gc-sweep-loop
        (cpl  gr1 cell-end)
        (jze  gc-sweep-exit)
        (ld   gr0 1 gr1)        ; CDR
        (and  gr0 gc-flag)
        (jnz  gc-sweep-lab1)    ; 使用中
        ; フリーセル
        (ld   gr0 free-cell)
        (st   gr0 1 gr1)
        (st   gr1 free-cell)
        (lad  gr1 2 gr1)
        (jump gc-sweep-loop)
gc-sweep-lab1
        ; 使用中 (flag clear)
        (ld   gr0 1 gr1)
        (and  gr0 gc-mask)
        (st   gr0 1 gr1)
        (lad  gr1 2 gr1)
        (jump gc-sweep-loop)
gc-sweep-exit
        (ret)

;;;
;;; GC 本体
;;;
gc
        (push 0 gr0)            ; レジスタをスタックに退避
        (push 0 gr1)
        (push 0 gr2)
        (push 0 gr3)
        (push 0 gr4)
        (push 0 gr5)
        (push 0 gr6)
        (push 0 gr7)
        ; スタック上のセルをマークする
        (ld   gr0 sp)
        (lad  sp -2 sp)
        (st   gr0 0 sp)
        (lad  gr0 #xffff)
        (st   gr0 1 sp)
        (call gc-mark)
        (lad  sp 2 sp)
        ; 回収
        (call gc-sweep)
        ;
        (pop  gr7)
        (pop  gr6)
        (pop  gr5)
        (pop  gr4)
        (pop  gr3)
        (pop  gr2)
        (pop  gr1)
        (pop  gr0)
        (ret)
gc-mask (dc   #xfffe)
gc-flag (dc   #x0001)

; リストの初期化
; 入力 : 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)

Copyright (C) 2011 Makoto Hiroi
All rights reserved.

[ PrevPage | Common Lisp | NextPage ]