Common Lisp 入門 の番外編です。前回の続きで、今回は仮想計算機 COMETⅡの本体を作りましょう。
最初に、仮想計算機に必要なレジスタとメモリを定義します。次のリストを見てください。
リスト : レジスタとメモリの定義
; 汎用レジスタ
(defvar *gr* (make-array 8
:element-type '(unsigned-byte 16)
:initial-element 0))
(defvar *pr* 0)
(defvar *sp* 0)
(defvar *fr* 0)
; メモリ
(defvar *memory* (make-array 65536
:element-type '(unsigned-byte 16)
:initial-element 0))
; レジスタの表示
(defun display-register ()
(format t "PR=~4,'0X " *pr*)
(format t "SP=~4,'0X " *sp*)
(format t "FR(OF,SF,ZF)=~3,'0B~%" *fr*)
(dotimes (n 8 (terpri))
(format t "GR~D=~4,'0X " n (aref *gr* n))))
; メモリの表示
(defun dump (s n)
(dotimes (x n (terpri))
(if (zerop (mod x 8)) (format t "~%~4,'0X: " (+ s x)))
(format t "~4,'0X " (aref *memory* (+ s x)))))
汎用レジスタはベクタで表して、スペシャル変数 *gr* にセットします。他のレジスタもスペシャル変数で表します。*pr* がプログラムレジスタ、*sp* スタックポインタ、*fr* がフラグレジスタです。メモリは大きさが 65536 のベクタで表し、スペシャル変数 *memory* にセットします。element-type の (unsigned-byte 16) は 16 bit 無符号整数を表します。これでベクタの要素は 0 以上 65535 以下の整数に限定されます。
関数 display-register はレジスタの値を表示し、関数 dump は s 番地から n word のメモリを表示します。これらの関数は SVC (SuperVisor Call) 命令で呼び出すようにすると、デバッグのときに便利です。
次はレジスタとメモリを操作する関数を作ります。
リスト : レジスタとメモリの操作関数
; 汎用レジスタの操作
(defun get-gr (reg) (aref *gr* reg))
(defun set-gr (reg value)
(setf (aref *gr* reg) value))
; メモリの操作
(defun read-memory (adr) (aref *memory* adr))
(defun write-memory (adr value)
(setf (aref *memory* adr) value))
(defun fetch ()
(prog1
(aref *memory* *pr*)
(incf *pr*)))
(defun fetch2 (reg)
(logand (+ (fetch) (if (<= 1 reg 7) (get-gr reg) 0))
#xffff))
関数 get-gr と set-gr は汎用レジスタのアクセス関数です。引数の reg は汎用レジスタの番号です。関数 read-memory と write-memory はメモリのアクセス関数です。引数 adr はアドレス (番地) です。関数 fetch はフェッチの動作を行います。メモリの *pr* 番地からコードを取り出して、*pr* の値を +1 します。
fetch2 は 2 word 目の命令を取り出します。引数 reg は指標レジスタの番号を表します。reg が 1 以上 7 以下の場合は、そのレジスタの値をアドレスに加算します。fetch2 の返す値は 0 以上 65535 以下でなければいけません。16 bit の範囲に収めるため、#xffff との論理積を計算しています。
なお、fetch2 は 2 の補数を使って引き算することもできます。たとえば、(lad gr1 -1 gr1) で gr1 が 1 の場合、-1 は 2 の補数で #xffff になるので、#xffff + 1 = #x10000 => 0 となり、gr1 - 1 を計算することができます。
次は仮想マシン本体を作ります。プログラムの概要を示します。
リスト : 仮想マシンの概要
(defun vm (start &optional (dump-num 32))
(init-vm start)
(loop
(let* ((op (fetch))
(r1 (get-r1 op))
(r2 (get-r2 op)))
(case (get-main-op op)
((0) nil) ; NOP
((1) ; データ転送 )
((2) ; 算術演算 )
((3) ; 論理演算 )
((4) ; 比較演算 )
((5) ; シフト演算 )
((6) ; ジャンプ命令 )
((7) ; スタック操作 )
((8) ; サブルーチン )
((15) ; その他 )
(t (error-operation-code op))))))
関数 vm の引数 start はプログラムの開始番地です。関数 init-vm で初期化を行い、次のループでメモリからコードを取り出して、それを解読 (decode) して実行 (execution) します。最初に、fetch で 1 word 目のコードを取り出します。そして、関数 get-main-op で main operation を取り出して、case 文で処理を振り分けます。この中で sub operation を取り出し、case 文てさらに処理を振り分け、指定された命令を実行します。レジスタ指定は関数 get-r1, get-r2 で取り出して、変数 r1, r2 にセットしておきます。あとは loop で処理を繰り返すだけです。
データ転送は簡単です。次のリストを見てください。
リスト : データ転送
((1)
(case (get-sub-op op)
((0) ; LD r1,adr,r2
(set-gr r1 (set-flag (read-memory (fetch2 r2)))))
((1) ; ST r1,adr,r2
(write-memory (fetch2 r2) (get-gr r1)))
((2) ; LAD r1,adr,r2
(set-gr r1 (fetch2 r2)))
((4) ; LD r1,r2
(set-gr r1 (set-flag (get-gr r2))))
(t (error-operation-code op))))
アドレス指定がある場合は fetch2 でアドレス adr を求めます。LD 命令は read-memory でメモリからデータを読み込み、ST 命令は write-memory で値をメモリへ書き込みます。LAD 命令はメモリからデータを読み込むのではなく、求めたアドレスの値をレジスタにセットします。
LD 命令はフラグに影響を与えるので、その処理を関数 set-flag で行います。次のリストを見てください。
リスト : フラグの設定
(defun set-flag (val &optional (over 0))
(if (zerop val)
(setf *fr* (logior *fr* #b001))
(setf *fr* (logand *fr* #b110)))
(if (logbitp 15 val)
(setf *fr* (logior *fr* #b010))
(setf *fr* (logand *fr* #b101)))
(if (zerop over)
(setf *fr* (logand *fr* #b011))
(setf *fr* (logior *fr* #b100)))
val)
引数 over はオーバーフローフラグ (OF) の値です。LD 命令の場合、OF は 0 にリセットされます。あとは引数 val の値によって、ゼロフラグ (ZF) とサインフラグ (SF) を設定します。
次は算術演算です。
リスト : 算術演算
((2)
(case (get-sub-op op)
((0) ; ADDA r1,adr,r2
(set-gr r1 (adda (get-gr r1) (read-memory (fetch2 r2)))))
((1) ; SUBA r1,adr,r2
(set-gr r1 (suba (get-gr r1) (read-memory (fetch2 r2)))))
((2) ; ADDL r1,adr,r2
(set-gr r1 (addl (get-gr r1) (read-memory (fetch2 r2)))))
((3) ; SUBL r1,adr,r2
(set-gr r1 (subl (get-gr r1) (read-memory (fetch2 r2)))))
((4) ; ADDA r1,r2
(set-gr r1 (adda (get-gr r1) (get-gr r2))))
((5) ; SUBA r1,r2
(set-gr r1 (suba (get-gr r1) (get-gr r2))))
((6) ; ADDl r1,r2
(set-gr r1 (addl (get-gr r1) (get-gr r2))))
((7) ; SUBL r1,r2
(set-gr r1 (subl (get-gr r1) (get-gr r2))))
(t (error-operation-code op))))
算術演算の場合、符号付き整数の加減算は関数 adda, suba で行い、無符号整数の加減算は関数 addl, subl で行います。次のリストを見てください。
リスト : 算術演算用関数 ; 加算 (defun adda (val1 val2) (to-unsigned (set-flag-a (+ (to-signed val1) (to-signed val2))))) (defun addl (val1 val2) (set-flag-l (+ val1 val2))) ; 減算 (defun suba (val1 val2) (to-unsigned (set-flag-a (- (to-signed val1) (to-signed val2))))) (defun subl (val1 val2) (set-flag-l (- val1 val2)))
adda と suba は値を Common Lisp で扱う整数に変換してから計算し、その結果を 16 bit 無符号整数に変換します。addl と subl は値をそのまま計算します。関数 to-signed は 16 bit 符号付き整数を Common Lisp の整数に変換します。逆に、関数 to-unsigned は Common Lisp の整数を 16 bit 無符号整数に変換します。
リスト : 整数の型変換
(defun to-signed (n)
(if (not (logbitp 15 n))
n
(- n #x10000)))
(defun to-unsigned (n) (logand n #xffff))
to-signed は n の 15 bit が 1 ならば、n から #x10000 を引き算します。これで Common Lisp の負の整数に変換することができます。近代的なコンピュータでは 2 の補数で負の整数を表しているので、to-unsigned は #xffff との論理積を計算するだけです。
最後にフラグを設定します。
リスト : 算術演算用のフラグ設定
; 符号付き整数
(defun set-flag-a (val)
(if (<= -32768 val 32767)
(set-flag val)
(set-flag (logand val #xffff) 1)))
; 無符号整数
(defun set-flag-l (val)
(if (<= 0 val 65535)
(set-flag val)
(set-flag (logand val #xffff) 1)))
val の値が範囲外であればオーバーフローフラグをセットします。そして、val の値を 16 bit に収めるため、#xffff との論理積を計算します。
次は論理演算です。
リスト : 論理演算
((3)
(case (get-sub-op op)
((0) ; AND r1,adr,r2
(set-gr r1 (log-op #'logand (get-gr r1) (read-memory (fetch2 r2)))))
((1) ; OR r1,adr,r2
(set-gr r1 (log-op #'logior (get-gr r1) (read-memory (fetch2 r2)))))
((2) ; XOR r1,adr,r2
(set-gr r1 (log-op #'logxor (get-gr r1) (read-memory (fetch2 r2)))))
((4) ; AND r1,r2
(set-gr r1 (log-op #'logand (get-gr r1) (get-gr r2))))
((5) ; OR r1,r2
(set-gr r1 (log-op #'logior (get-gr r1) (get-gr r2))))
((6) ; XOR r1,r2
(set-gr r1 (log-op #'logxor (get-gr r1) (get-gr r2))))
(t (error-operation-code op))))
レジスタ r2 またはメモリからデータを取り出して、レジスタ r1 との論理演算を関数 log-op で行います。
リスト : func で指定した論理演算を行う (defun log-op (func val1 val2) (set-flag (funcall func val1 val2)))
論理演算はフラグレジスタに影響を与えるので、演算結果を set-flag に渡してフラグレジスタの値を変更します。このとき、オーバーフローフラグは 0 になります。
次は比較演算です。
リスト : 比較演算
((4)
(case (get-sub-op op)
((0) ; CPA r1,adr,r2
(set-flag-cmp (- (to-signed (get-gr r1))
(to-signed (read-memory (fetch2 r2))))))
((1) ; CPL r1,adr,r2
(set-flag-cmp (- (get-gr r1)
(read-memory (fetch2 r2)))))
((4) ; CPA r1,r2
(set-flag-cmp (- (to-signed (get-gr r1))
(to-signed (get-gr r2)))))
((5) ; CPL r1,r2
(set-flag-cmp (- (get-gr r1) (get-gr r2))))
(t (error-operation-code op))))
符号付き整数を比較する場合、to-signed で値を Common Lisp の整数値に変換します。そして、レジスタ r1 の値から比較する値を引き算して、その結果を関数 set-flag-cmp に渡します。
リスト : 比較演算用フラグレジスタの指定
(defun set-flag-cmp (val)
(cond ((zerop val)
(setf *fr* #b001))
((plusp val)
(setf *fr* #b000))
(t
(setf *fr* #b010))))
val が 0 ならば比較した 2 つの値は等しいのでゼロフラグをセットします。val が正であれば、すべてのフラグをクリアします。val が負であればサインフラグをセットします。
次はシフト演算です。
リスト : シフト演算
((5)
(case (get-sub-op op)
((0) ; SLA r1,adr,r2
(set-gr r1 (shift-left-a (get-gr r1) (fetch2 r2))))
((1) ; SRA r1,adr,r2
(set-gr r1 (shift-right-a (get-gr r1) (fetch2 r2))))
((2) ; SLL r1,adr,r2
(set-gr r1 (shift-left-l (get-gr r1) (fetch2 r2))))
((3) ; SRL r1,adr,r2
(set-gr r1 (shift-right-l (get-gr r1) (fetch2 r2))))
(t (error-operation-code op))))
シフト演算は LAD 命令と同じくメモリから値を取り出すのではなく、fetch2 で求めた値をそのまま使うことに注意してください。実際の処理は対応する関数で行います。
リスト : シフト演算用操作関数
(defun shift-right-a (val k)
(let* ((val0 (to-signed val))
(val1 (to-unsigned (ash val0 (- k)))))
(if (and (plusp k) (logbitp (1- k) val0))
(set-flag val1 1)
(set-flag val1 0))))
(defun shift-left-a (val k)
(let* ((val0 (logand val #x7fff))
(flag (logand val #x8000))
(val1 (logior flag (logand (ash val0 k) #x7fff))))
(if (and (<= 1 k 15) (logbitp (- 15 k) val0))
(set-flag val1 1)
(set-flag val1 0))))
(defun shift-right-l (val k)
(let ((val1 (ash val (- k))))
(if (and (<= 1 k 16) (logbitp (1- k) val))
(set-flag val1 1)
(set-flag val1 0))))
(defun shift-left-l (val k)
(let ((val1 (logand (ash val k) #xffff)))
(if (and (<= 1 k 16) (logbitp (- 16 k) val))
(set-flag val1 1)
(set-flag val1 0))))
基本的な操作は val を k bit シフトし、その値を 16 bit に収めて、オーバーフローフラグの設定を行います。算術シフトは少々複雑です。右シフトする shift-right-a は、引数 val を Common Lisp の整数に変換してから ash で -k ビットシフトし、その結果を to-unsigned で変換します。そして、val0 の k - 1 ビットが OF の値になります。
左シフトする shift-left-a は、val の下位 15 bit を取り出して val0 に、最上位ビットを flag にセットします。そして、val0 を ash で k ビットシフトして、その値を 15 bit の範囲内に収め、flag との論理和を求めます。OF は val0 の 15 - k ビットの値になります。
論理シフトは簡単で、左右に k bit シフトしてそれを 16 bit の範囲内に収めるだけです。OF は右シフトのときが val の k - 1 ビット、左シフトのときが 16 - k ビットの値になります。
次はジャンプ命令です。
リスト : ジャンプ命令 (修正 2010/12/20)
(let ((jump-adr (fetch2 r2)))
(case (get-sub-op op)
((1) ; JMI adr,x
(when (logbitp 1 *fr*)
(setf *pr* jump-adr)))
((2) ; JNZ adr,x
(unless (logbitp 0 *fr*)
(setf *pr* jump-adr)))
((3) ; JZE adr,x
(when (logbitp 0 *fr*)
(setf *pr* jump-adr)))
((4) ; JUMP adr,x
(setf *pr* jump-adr))
((5) ; JPL adr,x
(unless (logbitp 1 *fr*)
(setf *pr* jump-adr)))
((6) ; JOV adr,x
(when (logbitp 2 *fr*)
(setf *pr* jump-adr)))
(t (error-operation-code op)))))
ジャンプ命令は簡単で、fetch2 でジャンプ先のアドレスを求め、フラグレジスタが条件を満たしていれば、*pr* の値をそのアドレスに書き換えるだけです。
次はスタック操作とサブルーチンの処理です。
リスト : スタック操作とサブルーチン
((7)
(case (get-sub-op op)
((0) ; PUSH adr,r2
(decf *sp*)
(setf (aref *memory* *sp*) (fetch2 r2)))
((1) ; POP r
(set-gr r1 (aref *memory* *sp*))
(incf *sp*))
(t (error-operation-code op))))
((8)
(case (get-sub-op op)
((0) ; CALL adr,r2 修正 2010/12/20
(let ((jump-adr (fetch2 r2)))
(decf *sp*)
(setf (aref *memory* *sp*) *pr*)
(setf *pr* jump-adr)))
((1) ; RET
(setf *pr* (aref *memory* *sp*))
(incf *sp*))
(t (error-operation-code op))))
PUSH, POP は簡単です。PUSH は *sp* を -1 してから、メモリのその位置に fetch2 で求めた値をセットします。逆に、 POP は *sp* が指し示すメモリの値を取り出してから、*sp* の値を +1 します。これでスタックの動作を実現できます。
CALL, RET も同様です。CALL は最初に fetch2 でジャンプ先アドレスを求めます。そして *sp* を -1 してから、その位置に *pr* の値をセットし、*pr* レジスタの値を fetch2 で求めた値に書き換えます。これで戻り先のアドレス (リターンアドレス) をスタックに積んで、サブルーチンの先頭へジャンプすることができます。これが関数呼び出しの仕組みです。
RET はその逆で、*pr* レジスタの値を *sp* が指し示すメモリの値に書き換えてから、*sp* の値を -1 します。これでスタックからリターンアドレスを取り出して、関数呼び出しの後の命令を実行することができます。
次はその他の命令を作ります。
リスト : その他
((15)
(case (get-sub-op op)
((0) ; SVC adr,r2
(case (fetch2 r2)
((0) ; for debug
(display-register))
((1) ; for debug
(dump (get-gr 0) dump-num))
((2) ; read-char
(set-gr 0 (char-code (read-char))))
((3) ; write-byte
(write-char (code-char (get-gr 0))))
(t (error-operation-code op))))
((1) ; HALT
(return))
(t (error-operation-code op))))
SVC 命令は、とりあえず 4 つの命令を用意しました。
SVC 2 は read-char を、SVC 3 は write-char を呼び出すだけです。
HALT は return で loop から脱出して vm の実行を終了します。
最後に、アセンブルしたコードをロードする関数を作ります。
リスト : ロード
(defun load-code (code &optional (wp 0))
(dolist (x code wp)
(if (consp x)
(case (car x)
((ds)
(dotimes (m (cadr x))
(setf (aref *memory* wp) 0)
(incf wp)))
((dc)
(dolist (m (cdr x))
(setf (aref *memory* wp)
(if (<= 0 m)
m
(to-unsigned m)))
(incf wp)))
(t
(asm-error x)))
(progn
(setf (aref *memory* wp)
(if (minusp x) (to-unsigned x) x))
(incf wp)))))
関数 load-code の引数 code はアセンブルしたコード、wp はメモリに書き込む開始番地です。これはアセンブルしたときと同じ値でなければいけません。処理は簡単で、code から要素をひとつずつ取り出して、メモリの wp 番地に書き込むだけです。
要素 x がリストの場合は ds または dc の処理を行います。リストの先頭要素が ds の場合、第 2 要素の個数だけ 0 を書き込みます。dc の場合、残りのリストから要素を取り出してメモリに書き込みます。このとき、値が負の場合は to-unsigned で無符号整数に変換してから書き込みます。
それ以外の場合は x をメモリの wp 番地に書き込みます。このとき、x が負の値であれば to-unsigned で無符号整数に変換してから書き込みます。
実際には、プログラムをアセンブルして実行まで行う関数があると便利です。次のリストを見てください。
リスト : プログラムの実行 (defun asm-run (name &optional (dump-num 32)) (load-code (assemble (read-casl2-file name))) ; 0 から開始 (vm 0 dump-num))
これで簡単にプログラムを実行することができます。
それでは実際に、前回のサンプルプログラムを実行してみましょう。
リスト : サンプルプログラム
;
; sample.cas
;
; data の bit 1 をカウントして ans にセットする
(lad gr2 0)
sample-loop
(ld gr1 data gr2)
(call logcount)
(st gr0 ans gr2)
(lad gr2 1 gr2)
(cpl gr2 len)
(jmi sample-loop)
(halt)
len (dc 4)
data (dc #x0123 #x4567 #x89ab #xcdef)
ans (ds 4)
; ビット 1 を数える (4 bit ずつ処理する)
; 入力 gr1 : データ
; 出力 gr0 : ビット 1 の個数
logcount
(push 0 gr1)
(push 0 gr2)
(xor gr0 gr0)
loop
(ld gr2 gr1)
(and gr2 mask)
(addl gr0 table gr2)
(srl gr1 4)
(jnz loop)
(pop gr2)
(pop gr1)
(ret)
mask (dc 15)
; 0 1 2 3 4 5 6 7 8 9 a b c d e f
table (dc 0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4)
* (asm-run "sample.cas") NIL * (dump 0 40) 0000: 122F 0000 1012 0010 80FF 0018 1102 0014 0008: 1222 0001 412F 000F 61FF 0002 F1FF 0004 0010: 0123 4567 89AB CDEF 0004 0008 0008 000C 0018: 70F1 0000 70F2 0000 3600 1421 302F 0029 0020: 2202 002A 531F 0004 62FF 001D 712F 711F NIL
data のアドレスが #x0010 で ans のアドレスが #x0014 です。#x0123, #x4567, #x89ab, #xcdef のオンビットの個数が ans の領域にセットされ、値が #x0004, #x0008, #x0008, #x000C になっています。正常に動作していますね。
今回はここまでです。次回は簡単なサンプルプログラムをいくつか作ってみましょう。
;
; COMET2.l : COMET2 簡易シミュレータ
;
; Copyright (C) 2010 Makoto Hiroi
;
; 修正 2010/12/20
; ジャンプ命令 : ジャンプしない場合 *pr* を +1 していなかった
; CALL 命令 : スタックに積むリターンアドレスが間違っていた
;;;
;;; アセンブラ
;;;
;;; コード表
(defvar *op-table0*
'((nop . #x0000) ; NOP
(ret . #x8100) ; RET
(halt . #xf100) ; HALT (終了命令を追加)
))
(defvar *op-table1*
'((pop . #x7100) ; POP r1
))
(defvar *op-table2*
'((ld . #x1400) ; LD r1,r2
(adda . #x2400) ; ADDA r1,r2
(suba . #x2500) ; SUBA r1,r2
(addl . #x2600) ; ADDL r1,r2
(subl . #x2700) ; SUBL r1,r2
(and . #x3400) ; AND r1,r2
(or . #x3500) ; OR r1,r2
(xor . #x3600) ; XOR r1,r2
(cpa . #x4400) ; CPA r1,r2
(cpl . #x4500) ; CPL r1,r2
))
(defvar *op-table21*
'((jmi . #x6100) ; JMI adr,r2
(jnz . #x6200) ; JNZ adr,r2
(jze . #x6300) ; JZE adr,r2
(jump . #x6400) ; JUMP adr,r2
(jpl . #x6500) ; JPL adr,r2
(jov . #x6600) ; JOV adr,r2
(push . #x7000) ; PUSH adr,r2
(call . #x8000) ; CALL adr,r2
(svc . #xf000) ; SVC adr,r2
))
(defvar *op-table3*
'((ld . #x1000) ; LD r1,adr,r2
(st . #x1100) ; ST r1,adr,r2
(lad . #x1200) ; LAD r1,adr,r2
(adda . #x2000) ; ADDA r1,adr,r2
(suba . #x2100) ; SUBA r1,adr,r2
(addl . #x2200) ; ADDL r1,adr,r2
(subl . #x2300) ; SUBL r1,adr,r2
(and . #x3000) ; AND r1,adr,r2
(or . #x3100) ; OR r1,adr,r2
(xor . #x3200) ; XOR r1,adr,r2
(cpa . #x4000) ; CPA r1,adr,r2
(cpl . #x4100) ; CPL r1,adr,r2
(sla . #x5000) ; SLA r1,adr,r2
(sra . #x5100) ; SRA r1,adr,r2
(sll . #x5200) ; SLL r1,adr,r2
(srl . #x5300) ; SRL r1,adr,r2
))
; アセンブルエラー
(defun asm-error (code)
(error "assemble error: ~S~%" code))
; 汎用レジスタの番号を取得
(defun get-gr-number (gr)
(position gr '(gr0 gr1 gr2 gr3 gr4 gr5 gr6 gr7)))
; main op を求める
(defun get-main-opcode (ls table)
(let ((op (assoc (car ls) table)))
(if op
(cdr op)
(asm-error ls))))
; 1st op の生成
(defun make-op1 (op r1 r2)
(+ op (ash r1 4) r2))
; code の生成
; ls = (op r1 adr r2)
(defun make-opcode (ls)
(case (length (cdr ls))
((0) ; (op)
(values (make-op1 (get-main-opcode ls *op-table0*) #x0f #x0f) nil))
((1) ; (op r1), (op adr)
(let ((r1 (get-gr-number (second ls))))
(if r1
(values (make-op1 (get-main-opcode ls *op-table1*) r1 #x0f)
nil)
(values (make-op1 (get-main-opcode ls *op-table21*) #x0f #x0f)
(second ls)))))
((2)
(let ((r1 (get-gr-number (second ls)))
(r2 (get-gr-number (third ls))))
(if r1
(if r2
; (op r1 r2)
(values (make-op1 (get-main-opcode ls *op-table2*) r1 r2)
nil)
; (op r1 adr)
(values (make-op1 (get-main-opcode ls *op-table3*) r1 #x0f)
(third ls)))
; (op adr r2)
(progn
(when (or (null r2) (zerop r2))
(asm-error ls))
(values (make-op1 (get-main-opcode ls *op-table21*) #x0f r2)
(second ls))))))
((3) ; (op r1 adr r2)
(let ((r1 (get-gr-number (second ls)))
(r2 (get-gr-number (fourth ls))))
(unless (and r1 r2 (plusp r2))
(asm-error ls))
(values (make-op1 (get-main-opcode ls *op-table3*) r1 r2)
(third ls))))
(t (asm-error ls))))
; 文字、文字列を数値に変換
(defun to-number (ls)
(apply #'append
(mapcar #'(lambda (x)
(cond ((stringp x)
(mapcar #'char-code (coerce x 'list)))
((characterp x)
(list (char-code x)))
(t (list x))))
ls)))
; ds の大きさを取得
(defun get-ds-size (ls)
(let ((size (second ls)))
(if (and (integerp size)
(<= 0 size #xffff))
size
(asm-error ls))))
; アセンブラ
(defun assemble (ls &optional (start 0))
(do ((ls ls (cdr ls))
(wp start)
(label nil)
(code nil))
((null ls) (sublis label (nreverse code)))
(cond ((symbolp (car ls))
(push (cons (car ls) wp) label))
((consp (car ls))
(case (caar ls)
((ds)
(let ((size (get-ds-size (car ls))))
(push (car ls) code)
(incf wp size)))
((dc)
(let ((xs (to-number (car ls))))
(push xs code)
(incf wp (length (cdr xs)))))
(t
(multiple-value-bind (op1 op2)
(make-opcode (car ls))
(push op1 code)
(incf wp)
(when op2
(push op2 code)
(incf wp))))))
(t (asm-error (car ls))))))
; プログラムファイルの読み込み
(defun read-casl2-file (filename)
(with-open-file (in filename :direction :input)
(let ((data nil) (a nil))
(loop
(setf data (read in nil))
(unless data
(return (nreverse a)))
(push data a)))))
;;;
;;; 仮想マシン
;;;
; レジスタとメモリの定義
(defvar *gr* (make-array 8
:element-type '(unsigned-byte 16)
:initial-element 0))
(defvar *pr* 0)
(defvar *sp* 0)
(defvar *fr* 0)
(defvar *memory* (make-array 65536
:element-type '(unsigned-byte 16)
:initial-element 0))
; レジスタの表示
(defun display-register ()
(format t "PR=~4,'0X " *pr*)
(format t "SP=~4,'0X " *sp*)
(format t "FR(OF,SF,ZF)=~3,'0B~%" *fr*)
(dotimes (n 8 (terpri))
(format t "GR~D=~4,'0X " n (aref *gr* n))))
; メモリの表示
(defun dump (s n)
(dotimes (x n (terpri))
(if (zerop (mod x 8)) (format t "~%~4,'0X: " (+ s x)))
(format t "~4,'0X " (aref *memory* (+ s x)))))
; 整数の型変換
(defun to-signed (n)
(if (not (logbitp 15 n))
n
(- n #x10000)))
(defun to-unsigned (n) (logand n #xffff))
; 汎用レジスタの操作
(defun get-gr (reg) (aref *gr* reg))
(defun set-gr (reg value)
(setf (aref *gr* reg) value))
; メモリの操作
(defun read-memory (adr) (aref *memory* adr))
(defun write-memory (adr value)
(setf (aref *memory* adr) value))
(defun fetch ()
(prog1
(aref *memory* *pr*)
(incf *pr*)))
(defun fetch2 (reg)
(logand (+ (fetch) (if (<= 1 reg 7) (get-gr reg) 0))
#xffff))
; op の操作
(defun get-main-op (op)
(ash op -12))
(defun get-sub-op (op)
(logand (ash op -8) #x0f))
(defun get-r1 (op)
(logand (ash op -4) #x0f))
(defun get-r2 (op)
(logand op #x0f))
; フラグの設定 (over sign zero)
(defun set-flag (val &optional (over 0))
(if (zerop val)
(setf *fr* (logior *fr* #b001))
(setf *fr* (logand *fr* #b110)))
(if (logbitp 15 val)
(setf *fr* (logior *fr* #b010))
(setf *fr* (logand *fr* #b101)))
(if (zerop over)
(setf *fr* (logand *fr* #b011))
(setf *fr* (logior *fr* #b100)))
val)
; 算術演算用
(defun set-flag-a (val)
(if (<= -32768 val 32767)
(set-flag val)
(set-flag (logand val #xffff) 1)))
(defun set-flag-l (val)
(if (<= 0 val 65535)
(set-flag val)
(set-flag (logand val #xffff) 1)))
; 比較用
(defun set-flag-cmp (val)
(cond ((zerop val)
(setf *fr* #b001))
((plusp val)
(setf *fr* #b000))
(t
(setf *fr* #b010))))
; 加算
(defun adda (val1 val2)
(to-unsigned (set-flag-a (+ (to-signed val1) (to-signed val2)))))
(defun addl (val1 val2)
(set-flag-l (+ val1 val2)))
; 減算
(defun suba (val1 val2)
(to-unsigned (set-flag-a (- (to-signed val1) (to-signed val2)))))
(defun subl (val1 val2)
(set-flag-l (- val1 val2)))
; 論理演算
(defun log-op (func val1 val2)
(set-flag (funcall func val1 val2)))
; シフト演算
(defun shift-right-a (val k)
(let* ((val0 (to-signed val))
(val1 (to-unsigned (ash val0 (- k)))))
(if (and (plusp k) (logbitp (1- k) val0))
(set-flag val1 1)
(set-flag val1 0))))
(defun shift-left-a (val k)
(let* ((val0 (logand val #x7fff))
(flag (logand val #x8000))
(val1 (logior flag (logand (ash val0 k) #x7fff))))
(if (and (<= 1 k 15) (logbitp (- 15 k) val0))
(set-flag val1 1)
(set-flag val1 0))))
(defun shift-right-l (val k)
(let ((val1 (ash val (- k))))
(if (and (<= 1 k 16) (logbitp (1- k) val))
(set-flag val1 1)
(set-flag val1 0))))
(defun shift-left-l (val k)
(let ((val1 (logand (ash val k) #xffff)))
(if (and (<= 1 k 16) (logbitp (- 16 k) val))
(set-flag val1 1)
(set-flag val1 0))))
; 初期化
(defun init-vm (start)
(fill *gr* 0)
(setf *sp* #xffff
*pr* start
*fr* 0))
; エラー
(defun error-operation-code (op)
(error "vm : error operation ~4,'0X~%" op))
;;; 仮想マシン
(defun vm (start &optional (dump-num 32))
(init-vm start)
(loop
(let* ((op (fetch))
(r1 (get-r1 op))
(r2 (get-r2 op)))
(case (get-main-op op)
((0) nil) ; NOP
((1)
(case (get-sub-op op)
((0) ; LD r1,adr,r2
(set-gr r1 (set-flag (read-memory (fetch2 r2)))))
((1) ; ST r1,adr,r2
(write-memory (fetch2 r2) (get-gr r1)))
((2) ; LAD r1,adr,r2
(set-gr r1 (fetch2 r2)))
((4) ; LD r1,r2
(set-gr r1 (set-flag (get-gr r2))))
(t (error-operation-code op))))
((2)
(case (get-sub-op op)
((0) ; ADDA r1,adr,r2
(set-gr r1 (adda (get-gr r1) (read-memory (fetch2 r2)))))
((1) ; SUBA r1,adr,r2
(set-gr r1 (suba (get-gr r1) (read-memory (fetch2 r2)))))
((2) ; ADDL r1,adr,r2
(set-gr r1 (addl (get-gr r1) (read-memory (fetch2 r2)))))
((3) ; SUBL r1,adr,r2
(set-gr r1 (subl (get-gr r1) (read-memory (fetch2 r2)))))
((4) ; ADDA r1,r2
(set-gr r1 (adda (get-gr r1) (get-gr r2))))
((5) ; SUBA r1,r2
(set-gr r1 (suba (get-gr r1) (get-gr r2))))
((6) ; ADDl r1,r2
(set-gr r1 (addl (get-gr r1) (get-gr r2))))
((7) ; SUBL r1,r2
(set-gr r1 (subl (get-gr r1) (get-gr r2))))
(t (error-operation-code op))))
((3)
(case (get-sub-op op)
((0) ; AND r1,adr,r2
(set-gr r1 (log-op #'logand (get-gr r1) (read-memory (fetch2 r2)))))
((1) ; OR r1,adr,r2
(set-gr r1 (log-op #'logior (get-gr r1) (read-memory (fetch2 r2)))))
((2) ; XOR r1,adr,r2
(set-gr r1 (log-op #'logxor (get-gr r1) (read-memory (fetch2 r2)))))
((4) ; AND r1,r2
(set-gr r1 (log-op #'logand (get-gr r1) (get-gr r2))))
((5) ; OR r1,r2
(set-gr r1 (log-op #'logior (get-gr r1) (get-gr r2))))
((6) ; XOR r1,r2
(set-gr r1 (log-op #'logxor (get-gr r1) (get-gr r2))))
(t (error-operation-code op))))
((4)
(case (get-sub-op op)
((0) ; CPA r1,adr,r2
(set-flag-cmp (- (to-signed (get-gr r1))
(to-signed (read-memory (fetch2 r2))))))
((1) ; CPL r1,adr,r2
(set-flag-cmp (- (get-gr r1)
(read-memory (fetch2 r2)))))
((4) ; CPA r1,r2
(set-flag-cmp (- (to-signed (get-gr r1))
(to-signed (get-gr r2)))))
((5) ; CPL r1,r2
(set-flag-cmp (- (get-gr r1) (get-gr r2))))
(t (error-operation-code op))))
((5)
(case (get-sub-op op)
((0) ; SLA r1,adr,r2
(set-gr r1 (shift-left-a (get-gr r1) (fetch2 r2))))
((1) ; SRA r1,adr,r2
(set-gr r1 (shift-right-a (get-gr r1) (fetch2 r2))))
((2) ; SLL r1,adr,r2
(set-gr r1 (shift-left-l (get-gr r1) (fetch2 r2))))
((3) ; SRL r1,adr,r2
(set-gr r1 (shift-right-l (get-gr r1) (fetch2 r2))))
(t (error-operation-code op))))
((6) ; 修正 2010/12/20
(let ((jump-adr (fetch2 r2)))
(case (get-sub-op op)
((1) ; JMI adr,x
(when (logbitp 1 *fr*)
(setf *pr* jump-adr)))
((2) ; JNZ adr,x
(unless (logbitp 0 *fr*)
(setf *pr* jump-adr)))
((3) ; JZE adr,x
(when (logbitp 0 *fr*)
(setf *pr* jump-adr)))
((4) ; JUMP adr,x
(setf *pr* jump-adr))
((5) ; JPL adr,x
(unless (logbitp 1 *fr*)
(setf *pr* jump-adr)))
((6) ; JOV adr,x
(when (logbitp 2 *fr*)
(setf *pr* jump-adr)))
(t (error-operation-code op)))))
((7)
(case (get-sub-op op)
((0) ; PUSH adr,r2
(decf *sp*)
(setf (aref *memory* *sp*) (fetch2 r2)))
((1) ; POP r1
(set-gr r1 (aref *memory* *sp*))
(incf *sp*))
(t (error-operation-code op))))
((8)
(case (get-sub-op op)
((0) ; CALL adr,r2 修正 2010/12/20
(let ((jump-adr (fetch2 r2)))
(decf *sp*)
(setf (aref *memory* *sp*) *pr*)
(setf *pr* jump-adr)))
((1) ; RET
(setf *pr* (aref *memory* *sp*))
(incf *sp*))
(t (error-operation-code op))))
((15)
(case (get-sub-op op)
((0) ; SVC adr,r2
(case (fetch2 r2)
((0) ; for debug
(display-register))
((1) ; for debug
(dump (get-gr 0) dump-num))
((2) ; read-char
(set-gr 0 (char-code (read-char))))
((3) ; write-byte
(write-char (code-char (get-gr 0))))
(t (error-operation-code op))))
((1) ; HALT
(return))
(t (error-operation-code op))))
(t (error-operation-code op))))))
; ロード
(defun load-code (code &optional (wp 0))
(dolist (x code wp)
(if (consp x)
(case (car x)
((ds)
(dotimes (m (cadr x))
(setf (aref *memory* wp) 0)
(incf wp)))
((dc)
(dolist (m (cdr x))
(setf (aref *memory* wp)
(if (<= 0 m)
m
(to-unsigned m)))
(incf wp)))
(t
(asm-error x)))
(progn
(setf (aref *memory* wp)
(if (minusp x) (to-unsigned x) x))
(incf wp)))))
; 実行
(defun asm-run (name &optional (dump-num 32))
(load-code (assemble (read-casl2-file name)))
; 0 から開始
(vm 0 dump-num))