(defvar *memory* #(#x31 #x04 #x33 #xaa #x40 #x02 #x80 #x03 #x52 #x00 #x72 #x01 #x73 #x01 #xb2 #x50 #x30 #x14 #xc0 #x01 #x80 #x00 #x10 #x10 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x98 #xab #xd9 #xa1 #x9f #xa7 #x83 #x83 #xf2 #xb1 #x34 #xb6 #xe4 #xb7 #xca #xb8 #xc9 #xb8 #x0e #xbd #x7d #x0f #xc0 #xf1 #xd9 #x03 #xc5 #x3a #xc6 #xc7 #xc8 #xc9 #xca #xcb #xcc #xcd #xce #xcf #xd0 #xd1 #xd2 #xd3 #xd4 #xd5 #xd6 #xd7 #xd8 #xd9 #xda #xdb #xa9 #xcd #xdf #xdf #xe0 #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 #xe7 #xe8 #xe9 #x26 #xeb #xec #xed #xee #xef #xf0 #xf1 #xf2 #xf3 #xf4 #xf5 #xf6 #xf7 #xf8 #xf9 #x7d #x1f #x15 #x60 #x4d #x4d #x52 #x7d #x0e #x27 #x6d #x10 #x6d #x5a #x06 #x56 #x47 #x14 #x42 #x0e #xb6 #xb2 #xb2 #xe6 #xeb #xb4 #x83 #x8e #xd7 #xe5 #xd4 #xd9 #xc3 #xf0 #x80 #x95 #xf1 #x82 #x82 #x9a #xbd #x95 #xa4 #x8d #x9a #x2b #x30 #x69 #x4a #x69 #x65 #x55 #x1c #x7b #x69 #x1c #x6e #x04 #x74 #x35 #x21 #x26 #x2f #x60 #x03 #x4e #x37 #x1e #x33 #x54 #x39 #xe6 #xba #xb4 #xa2 #xad #xa4 #xc5 #x95 #xc8 #xc1 #xe4 #x8a #xec #xe7 #x92 #x8b #xe8 #x81 #xf0 #xad #x98 #xa4 #xd0 #xc0 #x8d #xac #x22 #x52 #x65 #x7e #x27 #x2b #x5a #x12 #x61 #x0a #x01 #x7a #x6b #x1d #x67 #x75 #x70 #x6c #x1b #x11 #x25 #x25 #x70 #x7f #x7e #x67 #x63 #x30 #x3c #x6d #x6a #x01 #x51 #x59 #x5f #x56 #x13 #x10 #x43 #x19 #x18 #xe5 #xe0 #xbe #xbf #xbd #xe9 #xf0 #xf1 #xf9 #xfa #xab #x8f #xc1 #xdf #xcf #x8d #xf8 #xe7 #xe2 #xe9 #x93 #x8e #xec #xf5 #xc8 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x37 #x7a #x07 #x11 #x1f #x1d #x68 #x25 #x32 #x77 #x1e #x62 #x23 #x5b #x47 #x55 #x53 #x30 #x11 #x42 #xf6 #xf1 #xb1 #xe6 #xc3 #xcc #xf8 #xc5 #xe4 #xcc #xc0 #xd3 #x85 #xfd #x9a #xe3 #xe6 #x81 #xb5 #xbb #xd7 #xcd #x87 #xa3 #xd3 #x6b #x36 #x6f #x6f #x66 #x55 #x30 #x16 #x45 #x5e #x09 #x74 #x5c #x3f #x29 #x2b #x66 #x3d #x0d #x02 #x30 #x28 #x35 #x15 #x09 #x15 #xdd #xec #xb8 #xe2 #xfb #xd8 #xcb #xd8 #xd1 #x8b #xd5 #x82 #xd9 #x9a #xf1 #x92 #xab #xe8 #xa6 #xd6 #xd0 #x8c #xaa #xd2 #x94 #xcf #x45 #x46 #x67 #x20 #x7d #x44 #x14 #x6b #x45 #x6d #x54 #x03 #x17 #x60 #x62 #x55 #x5a #x4a #x66 #x61 #x11 #x57 #x68 #x75 #x05 #x62 #x36 #x7d #x02 #x10 #x4b #x08 #x22 #x42 #x32 #xba #xe2 #xb9 #xe2 #xd6 #xb9 #xff #xc3 #xe9 #x8a #x8f #xc1 #x8f #xe1 #xb8 #xa4 #x96 #xf1 #x8f #x81 #xb1 #x8d #x89 #xcc #xd4 #x78 #x76 #x61 #x72 #x3e #x37 #x23 #x56 #x73 #x71 #x79 #x63 #x7c #x08 #x11 #x20 #x69 #x7a #x14 #x68 #x05 #x21 #x1e #x32 #x27 #x59 #xb7 #xcf #xab #xdd #xd5 #xcc #x97 #x93 #xf2 #xe7 #xc0 #xeb #xff #xe9 #xa3 #xbf #xa1 #xab #x8b #xbb #x9e #x9e #x8c #xa0 #xc1 #x9b #x5a #x2f #x2f #x4e #x4e #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00)) (defconstant r0 0) (defconstant r1 1) (defconstant r2 2) (defconstant r3 3) (defconstant cs 4) (defconstant ds 5) (defconstant fl 6) (defconstant ip 7) (defvar *registers* #(#x00 #x00 #x00 #x00 ; r0 -- r3 #x00 #x10 ; cs, ds == r4, r5 #x00 ; fl #x00)) ; ip (defvar *instructions* #(jmp movr movm add xor cmp jmpe hlt)) (defun disasm-instr (mem addr) (let* ((instr (aref mem addr)) (opcode (ldb (byte 4 4) instr)) (op1 (ldb (byte 4 0) instr)) (op2 (case opcode ((0 12 14 15) nil) (t (aref mem (1+ addr)))))) (format t ";; ~(~4,'0X : ~2,'0X ~:[~* ~;~2,'0X~]~) : " addr instr op2 op2) (flet ((reg (n) (case n (4 "cs") (5 "ds") (t (format nil "r~A" n)))) (imm (n) (format nil "#x~(~2,'0X~)" n))) (ecase opcode ( 0 (format t "jmp ~A" (reg op1))) ( 1 (format t "jmp ~A:~A" (imm op2) (reg op1))) ( 2 (format t "movr ~A, ~A" (reg op1) (reg op2))) ( 3 (format t "movr ~A, ~A" (reg op1) (imm op2))) ( 4 (format t "movm ~A, [ds:~A]" (reg op1) (reg op2))) ( 5 (format t "movm [ds:~A], ~A" (reg op1) (reg op2))) ( 6 (format t "add ~A, ~A" (reg op1) (reg op2))) ( 7 (format t "add ~A, ~A" (reg op1) (imm op2))) ( 8 (format t "xor ~A, ~A" (reg op1) (reg op2))) ( 9 (format t "xor ~A, ~A" (reg op1) (imm op2))) (10 (format t "cmp ~A, ~A" (reg op1) (reg op2))) (11 (format t "cmp ~A, ~A" (reg op1) (imm op2))) (12 (format t "jmpe ~A" (reg op1))) (13 (format t "jmpe ~A:~A" (imm op2) (reg op1))) ((14 15) (format t "hlt"))) (terpri) (+ addr (if op2 2 1))))) (defun disasm (mem &key (start 0) (end nil)) (unless end (setf end (length mem))) (let ((addr start)) (loop (when (>= addr end) (return)) (setf addr (disasm-instr mem addr))))) (defun exec-instr (regs mem) (flet ((segment (seg off) (+ (ash seg 4) off)) (cmp (x y) (cond ((= x y) 0) ((< x y) #xff) (t 1)))) (let* ((pc (segment (aref regs cs) (aref regs ip))) (instr (aref mem pc)) (opcode (ldb (byte 4 4) instr)) (op1 (ldb (byte 4 0) instr)) (op2 (case opcode ((0 12 14 15) nil) (t (aref mem (1+ pc)))))) (incf (aref regs ip) (if op2 2 1)) (ecase opcode ( 0 (setf (aref regs ip) (aref regs op1))) ( 1 (setf (aref regs ip) (aref regs op1) (aref regs cs) op2)) ( 2 (setf (aref regs op1) (aref regs op2))) ( 3 (setf (aref regs op1) op2)) ( 4 (setf (aref regs op1) (aref mem (segment (aref regs ds) (aref regs op2))))) ( 5 (setf (aref mem (segment (aref regs ds) (aref regs op1))) (aref regs op2))) ( 6 (setf (aref regs op1) (mod (+ (aref regs op1) (aref regs op2)) 256))) ( 7 (setf (aref regs op1) (mod (+ (aref regs op1) op2) 256))) ( 8 (setf (aref regs op1) (logxor (aref regs op1) (aref regs op2)))) ( 9 (setf (aref regs op1) (logxor (aref regs op1) op2))) (10 (setf (aref regs fl) (cmp (aref regs op1) (aref regs op2)))) (11 (setf (aref regs fl) (cmp (aref regs op1) op2))) (12 (when (zerop (aref regs fl)) (setf (aref regs ip) (aref regs op1)))) (13 (when (zerop (aref regs fl)) (setf (aref regs ip) (aref regs op1) (aref regs cs) op2))) ((14 15) (return-from exec-instr :halt))) nil))) (defun dump (mem &key (start 0) (end nil)) (unless end (setf end (length mem))) (flet ((para (addr func) (do ((i 0 (1+ i))) ((>= i 16)) (when (zerop (logand i 3)) (write-char #\space)) (let ((p (+ addr i))) (funcall func (and (>= p start) (< p end) (aref mem p)))))) (hex (x) (if x (format t "~(~2,'0X~)" x) (write-string "**"))) (text (x) (write-char (cond ((null x) #\*) ((and (>= x #x20) (< x #x7f)) (code-char x)) (t #\.))))) (let ((low (logand start -16)) (high (logand (+ end 15) -16))) (do ((i low (+ i 16))) ((>= i high)) (format t ";; ~(~4,'0X~) :" i) (para i #'hex) (write-string " :") (para i #'text) (terpri))))) (defun exec (regs mem &key (low 0) (high (length mem)) (trace nil)) (flet ((segment (seg off) (+ (ash seg 4) off))) (loop (let ((pc (segment (aref regs cs) (aref regs ip)))) (when trace (format t ";; ~{~ r0-r3 = ~(~2,'0X~), ~(~2,'0X~), ~(~2,'0X~), ~(~2,'0X~); ~ cs, ds = ~(~2,'0X~), ~(~2,'0X~); ~ fl = ~(~2,'0X~); ip = ~(~2,'0X~)~}~%" (coerce regs 'list)) (disasm-instr mem pc) (write-string ";;") (terpri)) (when (or (< pc low) (>= pc high)) (return :break))) (let ((result (exec-instr regs mem))) (when result (return result)))))) (defun file-mem (file mem) (with-open-file (out file :direction :output :element-type '(unsigned-byte 8) :if-exists :overwrite :if-does-not-exist :create) (write-sequence mem out))) (defun vigenere (key mem &key (offset 0)) (let ((key (if (listp key) (copy-list key) (coerce key 'list)))) (setf (cdr (last key)) key) (map 'vector #'logxor (nthcdr offset key) mem)))