Common Lisp 入門 の番外編です。付録として COMET2A 用の簡単なサンプルプログラムを公開します。
リスト : リストのマージ (Common Lisp)
(defun nmerge-list (pred xs ys)
(do* ((header (list nil))
(tail header))
((or (null xs) (null ys))
(rplacd tail (if (null xs) ys xs))
(cdr header))
(cond ((funcall pred (car xs) (car ys))
(rplacd tail xs)
(setf tail xs)
(pop xs))
(t
(rplacd tail ys)
(setf tail ys)
(pop ys)))))
* (setf a '(2 4 6 8)) (2 4 6 8) * (setf b '(1 3 5 7 9)) (1 3 5 7 9) * (nmerge-list #'> a b) (1 2 3 4 5 6 7 8 9) * a (2 3 4 5 6 7 8 9) * b (1 2 3 4 5 6 7 8 9)
リスト : リストのマージ (COMET2A)
; 入力 +2) : 比較サブルーチン
; +3) : リスト a
; +4) : リスト b
nmerge
(link gr7 -2) ; header を用意
(push 0 gr2)
(push 0 gr3)
(push 0 gr4)
(push 0 gr5)
(push 0 gr6)
(ld gr3 3 gr7)
(jze nmerge-exit-b) ; b を返す
(ld gr4 4 gr7)
(jze nmerge-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) ; 比較サブルーチン
nmerge-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 nmerge-lb)
; a <= b
(st gr3 1 gr2) ; 末尾に接続
(ld gr2 gr3)
(ld gr3 1 gr3)
(jnz nmerge-loop)
; a が空リストになった
(st gr4 1 gr2) ; b を末尾に接続
(jump nmerge-exit)
nmerge-lb
; a > b
(st gr4 1 gr2) ; 末尾に接続
(ld gr2 gr4)
(ld gr4 1 gr4)
(jnz nmerge-loop)
; b が空リストになった
(st gr3 1 gr2) ; a を末尾に接続
nmerge-exit
(ld gr0 -1 gr7) ; (cdr header) -> gr0
nmerge-exit1
(pop gr6)
(pop gr5)
(pop gr4)
(pop gr3)
(pop gr2)
(unlk gr7)
(ret)
nmerge-exit-b
(ld gr0 4 gr7)
(jump nmerge-exit1)
nmerge-exit-a
(ld gr0 gr3)
(jump nmerge-exit1)
リスト : nmerge のテスト
test-nmerge
(call initialize-heap)
(call initialize-list)
(lad sp -3 sp)
(lad gr0 data04a)
(st gr0 0 sp)
(ld gr0 len04)
(st gr0 1 sp)
(call vector->list)
(ld gr2 gr0)
(lad gr0 data04b)
(st gr0 0 sp)
(ld gr0 len04)
(st gr0 1 sp)
(call vector->list)
(st gr0 2 sp)
(st gr2 1 sp)
(lad gr0 cmp)
(st gr0 0 sp)
(call nmerge)
(st gr0 0 sp)
(call print-list)
(call newline)
(lad sp 3 sp)
(halt)
len04 (dc 5)
data04a (dc 2 4 6 8 10)
data04b (dc 1 3 5 7 9)
; 比較関数
cmp
(link gr7 0)
(ld gr0 2 gr7)
(suba gr0 3 gr7)
(unlk gr7)
(ret)
* (asm-run "list.cas") 1 2 3 4 5 6 7 8 9 10 NIL
リスト : マージソート (Common Lisp)
(defun nmerge-sort (pred ls n)
(if (= n 1)
(rplacd ls nil)
(let ((m (floor n 2)))
(nmerge-list pred
; 後半からソートすること
(nmerge-sort pred (nthcdr m ls) (- n m))
(nmerge-sort pred ls m)))))
* (setf a '(5 6 4 7 3 8 2 9 1 0)) (5 6 4 7 3 8 2 9 1 0) * (nmerge-sort #'< a 10) (0 1 2 3 4 5 6 7 8 9) * a (5 6 7 8 9)
リスト : マージソート (COMET2A)
; 入力 +2) : 比較サブルーチン
; +3) : リスト
; +4) : 長さ N
; 出力 gr0 : ソート済みリスト
nmerge-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 nmerge-sort-1) ; 要素はひとつ
(jpl nmerge-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 gr2 0 sp) ; 後半からソートする
(st gr6 1 sp)
(call drop) ; -> gr0 (後半の先頭)
(st gr5 0 sp) ; 後半をソート
(st gr0 1 sp)
(st gr3 2 sp)
(call nmerge-sort) ; -> gr0
(ld gr4 gr0) ; gr0 -> gr4
(st gr5 0 sp) ; 前半をソート
(st gr6 1 sp)
(st gr2 2 sp)
(call nmerge-sort) ; -> gr0
(st gr5 0 sp) ; 前半と後半をマージする
(st gr0 1 sp)
(st gr4 2 sp)
(call nmerge) ; -> gr0
(lad sp 3 sp)
nmerge-sort-exit
(pop gr6)
(pop gr5)
(pop gr4)
(pop gr3)
(pop gr2)
(unlk gr7)
(ret)
nmerge-sort-1
(xor gr0 gr0)
(st gr0 1 gr6) ; 長さ 1 のリストに切断する
(ld gr0 gr6)
(jump nmerge-sort-exit)
nmerge-sort-0
(xor gr0 gr0)
(jump nmerge-sort-exit)
リスト : nmerge-sort のテスト
test-nmerge-sort
(call initialize-heap)
(call initialize-list)
(lad sp -3 sp)
(lad gr0 data05)
(st gr0 0 sp)
(ld gr0 len05)
(st gr0 1 sp)
(call vector->list)
(st gr0 1 sp)
(lad gr0 cmp)
(st gr0 0 sp)
(ld gr0 len05)
(st gr0 2 sp)
(call nmerge-sort)
(st gr0 0 sp)
(call print-list)
(call newline)
(lad sp 3 sp)
(halt)
len05 (dc 12)
data05 (dc 5 6 4 7 3 8 2 9 1 0 -1 -2)
; 比較関数
cmp
(link gr7 0)
(ld gr0 2 gr7)
(suba gr0 3 gr7)
(unlk gr7)
(ret)
* (asm-run "listc.cas") -2 -1 0 1 2 3 4 5 6 7 8 9 NIL
| 名前 | 機能 |
|---|---|
| addl32 a b | a + b |
| subl32 a b | a - b |
| cpl32 a b | a と b を比較する |
| sll32one a | a を左へ 1 bit 論理シフトする |
| srl32one a | a を右へ 1 bit 論理シフトする |
| sll32 a n | a を左へ n bit 論理シフトする |
| srl32 a n | a を右へ n bit 論理シフトする |
| mull32 a b | a * b |
| divl32 a b | a / b |
| printu32 a n | a を n 進数で表示する |
| print32 a | a を 32 bit 符号付き整数で表示する |
;;; 32 bit 無符号整数演算ルーチン
;
; 整数値はビッグエンディアンで格納する
; (a + 0) : 1234 => #x12345678
; (a + 1) : 5678
;
;;; 定数
carry-lsb
(dc 1)
carry-msb
(dc #x8000)
; 無符号加算
; 入力 +2) : a (high)
; +3) : a (low)
; +4) : b (high)
; +5) : b (low)
; 出力 : gr0 (high), gr1 (low)
; フラグは不定
addl32
(link gr7 0)
(ld gr0 2 gr7) ; a を取り出す
(ld gr1 3 gr7)
(addl gr1 5 gr7) ; low を加算
(jov addl32-carry) ; 繰り上げ
addl32-high
(addl gr0 4 gr7) ; high を加算
(unlk gr7)
(ret)
addl32-carry
(addl gr0 carry-lsb) ; high += 1
(jump addl32-high)
; 無符号減算
; 入力 +2) : a (high)
; +3) : a (low)
; +4) : b (high)
; +5) : b (low)
; 出力 : gr0 (high), gr1 (low)
; フラグは不定
subl32
(link gr7 0)
(ld gr0 2 gr7) ; a を取り出す
(ld gr1 3 gr7)
(subl gr1 5 gr7) ; low を減算
(jov subl32-carry) ; 繰り下げ
subl32-high
(subl gr0 4 gr7) ; 上位 word を減算
(unlk gr7)
(ret)
subl32-carry
(subl gr0 carry-lsb) ; gr0 -= 1
(jump subl32-high)
; 無符号整数の比較
; 入力 +2) : a (high)
; +3) : a (low)
; +4) : b (high)
; +5) : b (low)
cpl32
(link gr7 0)
(ld gr0 2 gr7) ; high を比較
(cpl gr0 4 gr7)
(jnz cpl32-exit)
(ld gr0 3 gr7) ; low を比較
(cpl gr0 5 gr7)
cpl32-exit
(unlk gr7)
(ret)
; 左へ 1 ビット論理シフト
; 入力 +2) high
; +3) low
; 出力 : gr0 (high), gr1 (low)
sll32one
(link gr7 0)
(ld gr0 2 gr7)
(sll gr0 1) ; high <<= 1
(ld gr1 3 gr7)
(sll gr1 1) ; low <<= 1
(jov sll32one-ov) ; high の LSB をセット
sll32one-exit
(unlk gr7)
(ret)
sll32one-ov
(or gr0 carry-lsb)
(jump sll32one-exit)
; 右へ 1 ビット論理シフト
; 入力 +2) : high
; +3) : low
; 出力 : gr0 (high), gr1 (low)
srl32one
(link gr7 0)
(ld gr1 3 gr7)
(srl gr1 1) ; low >>= 1
(ld gr0 2 gr7)
(srl gr0 1) ; high >>= 1
(jov srl32one-ov) ; low の MSB をセット
srl32one-exit
(unlk gr7)
(ret)
srl32one-ov
(or gr1 carry-msb)
(jump srl32one-exit)
; 左へ N ビット論理シフト
; 入力 +2) : high
; +3) : low
; +4) : シフトする値 (N)
; 出力 : gr0 (high), gr1 (low)
sll32
(link gr7 0)
(push 0 gr2)
(push 0 gr3)
(ld gr2 4 gr7)
(lad gr3 16)
(cpl gr2 gr3)
(jpl sll32-lab1) ; N が 16 以上はジャンプ
; 16 bit 未満のシフト
(ld gr0 2 gr7) ; high -> gr0
(sll gr0 0 gr2) ; high <<= N
(ld gr1 3 gr7) ; low -> gr1
(sll gr1 0 gr2) ; low <<= N
(subl gr3 gr2) ; gr3 = (16 - N)
(ld gr2 3 gr7) ; low -> gr2
(srl gr2 0 gr3) ; low <<= gr3 : high に移るビット
(or gr0 gr2)
sll32-exit
(pop gr3)
(pop gr2)
(unlk gr7)
(ret)
sll32-lab1
; 16 bit 以上のシフト
; low <= 0
; high <= (srl low N-16)
(subl gr2 gr3) ; gr3 = N - 16
(ld gr0 3 gr7) ; low -> gr0 (high)
(sll gr0 0 gr2) ; (N-16) ビットシフト
(xor gr1 gr1) ; low (gr1) = 0
(jump sll32-exit)
; 右へ N ビット論理シフト
; 入力 +2) : high
; +3) : low
; +4) : シフトする値 (N)
; 出力 : gr0 (high), gr1 (low)
srl32
(link gr7 0)
(push 0 gr2)
(push 0 gr3)
(ld gr2 4 gr7)
(lad gr3 16)
(cpl gr2 gr3)
(jpl srl32-lab1) ; N が 16 以上はジャンプ
; 16 bit 未満のシフト
(ld gr0 2 gr7) ; high -> gr0
(srl gr0 0 gr2) ; high >>= N
(ld gr1 3 gr7) ; low -> gr1
(srl gr1 0 gr2) ; low >>= N
(subl gr3 gr2) ; gr3 = (16 - N)
(ld gr2 2 gr7) ; high -> gr2
(sll gr2 0 gr3) ; high >>= gr3 : low に移るビット
(or gr1 gr2)
srl32-exit
(pop gr3)
(pop gr2)
(unlk gr7)
(ret)
srl32-lab1
; 16 bit 以上のシフト
; high <= 0
; low <= (srl high N-16)
(subl gr2 gr3) ; gr3 = N - 16
(ld gr1 2 gr7) ; high -> gr1 (low)
(srl gr1 0 gr2) ; (N-16) ビットシフト
(xor gr0 gr0) ; high (gr0) = 0
(jump srl32-exit)
; 無符号整数の乗算
; 入力 +2) : a (high)
; +3) : a (low)
; +4) : b (high)
; +5) : b (low)
; 出力 gr0 (high), gr1 (low)
mull32
(link gr7 0)
(push 0 gr3)
(push 0 gr4)
(ld gr3 3 gr7) ; a(low)
(ld gr4 5 gr7) ; b(low)
(mull gr3 gr4) ; gr3 * gr4 -> gr3 (low), gr4 (high)
(ld gr0 gr4) ; high -> gr0
(ld gr1 gr3) ; low -> gr1
(ld gr3 2 gr7) ; a(high)
(ld gr4 5 gr7) ; b(low)
(mull gr3 gr4)
(addl gr0 gr3) ; gr3 + gr0 (gr4 は桁あふれ)
; 繰り上がりも桁あふれ
(ld gr3 3 gr7) ; a(low)
(ld gr4 4 gr7) ; b(high)
(mull gr3 gr4)
(addl gr0 gr3) ; gr3 + gr0 (gr4 は桁あふれ)
; 繰り上がりも桁あふれ
; a(high) * b(high) はすべて桁あふれ
(pop gr4)
(pop gr3)
(unlk gr7)
(ret)
; 無符号整数の除算
; -2) : 商 (high)
; -1) : 商 (low)
; +0) : gr7
; +1) : ret adr
; 入力 +2) : a(high)
; +3) ; a(low)
; +4) ; b(high)
; +5) : b(low)
; 出力 gr0(high), gr1(low) 商 (a / b)
; gr2(high), gr3(low) 余り (a mod b)
divl32
(link gr7 -2)
(push 0 gr4)
(push 0 gr5)
(xor gr0 gr0)
(st gr0 -1 gr7) ; 商を 0 clear
(st gr0 -2 gr7)
(ld gr2 2 gr7) ; a (余りになる)
(ld gr3 3 gr7)
(ld gr4 4 gr7) ; b
(ld gr5 5 gr7)
divl32-loop1 ; a と b の桁あわせ
(ld gr4 gr4)
(jmi divl32-loop2) ; 最上位ビットがオン
(lad sp -4 sp)
(st gr4 0 sp)
(st gr5 1 sp)
(st gr2 2 sp)
(st gr3 3 sp)
(call cpl32)
(lad sp 4 sp)
(jpl divl32-loop2) ; b >= a
;
; b <<= 1
;
(sll gr4 1)
(sll gr5 1)
(jov divl32-shift1)
(jump divl32-loop1)
divl32-shift1
(or gr4 carry-lsb)
(jump divl32-loop1)
;
divl32-loop2
(lad sp -4 sp)
(st gr4 0 sp) ; b をセット
(st gr5 1 sp)
(ld gr0 4 gr7) ; 元b をセット
(st gr0 2 sp)
(ld gr0 5 gr7)
(st gr0 3 sp)
(call cpl32)
(lad sp 4 sp)
(jmi divl32-exit) ; b > 元b ならば終了
;
; (商) <<= 1
;
(ld gr0 -2 gr7)
(ld gr1 -1 gr7)
(sll gr0 1)
(sll gr1 1)
(jov divl32-shift2)
(jump divl32-shift3)
divl32-shift2
(or gr0 carry-lsb)
divl32-shift3
(st gr0 -2 gr7)
(st gr1 -1 gr7)
;
(lad sp -4 sp)
(st gr2 0 sp) ; a をセット
(st gr3 1 sp)
(st gr4 2 sp) ; b をセット
(st gr5 3 sp)
(call cpl32)
(lad sp 4 sp)
(jmi divl32-l2) ; a > b なので引き算できない
(lad sp -4 sp)
(call subl32) ; a - b (引数はそのままでよい)
(lad sp 4 sp)
(ld gr2 gr0)
(ld gr3 gr1)
(ld gr1 -1 gr7)
(lad gr1 1 gr1)
(st gr1 -1 gr7) ; 商の LSB をオン
divl32-l2
;
; b >>= 1
;
(srl gr5 1)
(srl gr4 1)
(jov divl32-shift4)
(jump divl32-loop2)
divl32-shift4
(or gr5 carry-msb)
(jump divl32-loop2)
;
divl32-exit
(ld gr0 -2 gr7) ; 商をセット
(ld gr1 -1 gr7)
(pop gr5)
(pop gr4)
(unlk gr7)
(ret)
; 32 bit無符号整数の N 進表示
; 入力 +2) : high
; +3) : low
; +4) : 基数 (16 まで)
; 出力 : 無し
printu32
(link gr7 0)
(push 0 gr1)
(push 0 gr2)
(push 0 gr3)
(lad sp -4 sp)
(ld gr0 2 gr7)
(st gr0 0 sp)
(ld gr0 3 gr7)
(st gr0 1 sp)
(xor gr0 gr0)
(st gr0 2 sp)
(ld gr0 4 gr7)
(st gr0 3 sp)
(call divl32) ; -> gr0(h) gr1(l) 商, gr2(h)=0 gr3(l) 余り
(lad sp 4 sp)
(ld gr2 gr0)
(or gr2 gr1) ; 商は 0 かチェックする
(jze printu32-lab1)
(lad sp -3 sp)
(st gr0 0 sp) ; 商をセット
(st gr1 1 sp)
(ld gr0 4 gr7) ; 基数をセット
(st gr0 2 sp)
(call printu32) ; 再帰呼び出し
(lad sp 3 sp)
printu32-lab1
(ld gr3 code-table gr3)
(push 0 gr3)
(call write-char)
(pop gr3)
(pop gr3)
(pop gr2)
(pop gr1)
(unlk gr7)
(ret)
; 32 bit 符号付き整数の表示
; 入力 +2) : high
; +3) : low
; 出力 : None
print32
(link gr7 0)
(ld gr0 2 gr7)
(jmi print32-lab1) ; 最上位ビットオン
(lad sp -3 sp)
(st gr0 0 sp) ; 引数セット
(ld gr0 3 gr7)
(st gr0 1 sp)
(lad gr0 10) ; 基数セット
(st gr0 2 sp)
(call printu32)
(lad sp 3)
print32-exit
(unlk gr7)
(ret)
print32-lab1
(push 0 gr1)
(push 0 gr2)
(ld gr1 gr0) ; high -> gr1
(ld gr2 3 gr7) ; low -> gr2
(lad gr0 #xffff) ; ビット反転
(xor gr1 gr0)
(xor gr2 gr0)
(lad gr0 1)
(addl gr2 gr0) ; low += 1
(jov print32-lab2) ; 繰り上げ
print32-lab3
(push 45)
(call write-char) ; '-' を出力
(lad sp -2 sp)
(st gr1 0 sp)
(st gr2 1 sp)
(lad gr0 10)
(st gr0 2 sp)
(call printu32)
(lad sp 3 sp)
(pop gr2)
(pop gr1)
(jump print32-exit)
print32-lab2
(lad gr1 1 gr1) ; high += 1
(jump print32-lab3)
リスト : 階乗 32 bit 版
; 入力 +2) : 整数 N
; 出力 gr0 (high), grl (low)
fact32
(link gr7 0)
(ld gr1 2 gr7)
(jze fact32-zero)
(lad gr1 -1 gr1) ; N - 1
(push 0 gr1)
(call fact32) ; 再帰呼び出し -> gr0, gr1
(lad sp -3 sp)
(st gr0 0 sp) ; (N - 1)! をセット
(st gr1 1 sp)
(xor gr0 gr0) ; N をセット
(st gr0 2 sp)
(ld gr0 2 gr7)
(st gr0 3 sp)
(call mull32) ; (N - 1)! * N -> gr0, gr1
(lad sp 4 sp)
fact32-exit
(unlk gr7)
(ret)
fact32-zero
(xor gr0 gr0) ; 1 を返す
(lad gr1 1)
(jump fact32-exit)
リスト : fact32 のテスト
test-fact32
(lad gr2 0)
(lad gr3 13)
test-fact32-loop
(cpl gr2 gr3)
(jze test-fact32-exit)
(push 0 gr2)
(call fact32)
(lad sp -1 sp)
(st gr0 0 sp)
(st gr1 1 sp)
(call print32)
(lad sp 2 sp)
(call newline)
(lad gr2 1 gr2)
(jump test-fact32-loop)
test-fact32-exit
(halt)
* (asm-run "arithmetic.cas") 1 1 2 6 24 120 720 5040 40320 362880 3628800 39916800 479001600 NIL
リスト : フィボナッチ関数 (32 bit 版)
; 入力 +2) : N
; 出力 gr0, gr1
fibo32
(link gr7 -6)
(push 0 gr2)
(push 0 gr3)
; 局所変数を 1 に初期化
(xor gr0 gr0)
(lad gr1 1)
(st gr0 -6 gr7) ; a0
(st gr1 -5 gr7)
(st gr0 -4 gr7) ; a1
(st gr1 -3 gr7)
(st gr0 -2 gr7) ; a2
(st gr1 -1 gr7)
;
(ld gr2 2 gr7)
(lad gr3 2)
fibo32-loop
(cpl gr2 gr3)
(jmi fibo32-exit)
(lad sp -4 sp)
(ld gr0 -4 gr7) ; a1 をセット
(st gr0 0 sp)
(ld gr0 -3 gr7)
(st gr0 1 sp)
(ld gr0 -2 gr7) ; a2 をセット
(st gr0 2 sp)
(ld gr0 -1 gr7)
(st gr0 3 sp)
(call addl32) ; a1 + a2 -> gr0, gr1
(lad sp 4 sp)
(st gr0 -6 gr7) ; a0 に代入
(st gr1 -5 gr7)
; a1 -> a2
(ld gr0 -4 gr7)
(st gr0 -2 gr7)
(ld gr0 -3 gr7)
(st gr0 -1 gr7)
; a0 -> a1
(ld gr0 -6 gr7)
(st gr0 -4 gr7)
(ld gr0 -5 gr7)
(st gr0 -3 gr7)
;
(lad gr2 -1 gr2)
(jump fibo32-loop)
fibo32-exit
(ld gr0 -6 gr7)
(ld gr1 -5 gr7)
(pop gr3)
(pop gr2)
(unlk gr7)
(ret)
リスト : fibo32 のテスト
test-fibo32
(lad gr2 0)
(lad gr3 47)
test-fibo32-loop
(cpl gr2 gr3)
(jze test-fibo32-exit)
(push 0 gr2)
(call fibo32)
(lad sp -1 sp)
(st gr0 0 sp)
(st gr1 1 sp)
(call print32)
(lad sp 2 sp)
(call newline)
(lad gr2 1 gr2)
(jump test-fibo32-loop)
test-fibo32-exit
(halt)
* (asm-run "arithmetic.cas") 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181 6765 10946 17711 28657 46368 75025 121393 196418 317811 514229 832040 1346269 2178309 3524578 5702887 9227465 14930352 24157817 39088169 63245986 102334155 165580141 267914296 433494437 701408733 1134903170 1836311903 -1323752223 NIL