Create a gist now

Instantly share code, notes, and snippets.

DCPU-16 Lisp implementation
(defpackage #:dcpu-16
(:use #:cl)
#:make-ram #:ram-read #:ram-write #:ram-size
#:execute #:debug
#:load-program #:assemble-program
#:set #:add #:sub #:mul
#:div #:mod #:shl #:shr
#:and #:bor #:xor #:ife
#:ifn #:ifg #:ifb #:jsr
(in-package #:dcpu-16)
;;;; DCPU-16
;;; Implementation of
(deftype word () '(unsigned-byte 16))
;;; Memory
(defun make-ram (&optional (size #x10000))
"Return a new memory object with SIZE words. All words are
initially set to zero."
(make-array size
:element-type 'word
:initial-element 0))
(defun ram-read (n ram)
"Read the Nth word in RAM and return it."
(aref ram n))
(defun ram-write (value n ram)
"Write the VALUE to the Nth word in RAM."
(setf (aref ram n)
(logand value #xFFFF)))
(defun ram-size (ram)
"Return the size of the RAM in words."
(array-dimension ram 0))
;;; Registers
(defun make-register-file ()
"Return a new register file, i.e. storage for the DCPU-16's
registers. Registers are all initially set to zero."
(make-array 11
:element-type 'word
:initial-element 0))
(defun reg-index (name)
"Return the index of the register named NAME in the register file."
(position name '(a b c x y z i j pc sp o)))
(defun reg-read (name file)
"Read the value of the register named NAME in FILE."
(aref file (reg-index name)))
(defun reg-write (value name file)
"Write VALUE to the register named NAME in FILE."
(setf (aref file (reg-index name))
(logand value #xFFFF)))
;;; Instruction execution and debugging
(defvar *register-file* nil)
(defvar *ram* nil)
(defvar *cycles-count* nil)
(defvar *skip-instruction* nil)
(defun set-o (value)
(reg-write value 'o *register-file*))
(defun get-pc ()
(reg-read 'pc *register-file*))
(defun set-pc (value)
(reg-write value 'pc *register-file*))
(defmacro saving-pc (&body forms)
(let ((pc (gensym)))
`(let ((,pc (get-pc)))
(progn ,@forms)
(set-pc ,pc)))))
(defun get-sp ()
(reg-read 'sp *register-file*))
(defun set-sp (value)
(reg-write value 'sp *register-file*))
(defun skip-next-instruction ()
(incf *cycles-count*)
(setf *skip-instruction* t))
(defun reset-skip-instruction ()
(setf *skip-instruction* nil))
(defun consume-word ()
(let ((pc (get-pc)))
(set-pc (1+ pc))
(ram-read pc *ram*)))
(defun execute-set (operand-1 operand-2)
(operand-write (operand-read operand-2) operand-1))
(defun execute-add (operand-1 operand-2)
(let ((sum (+ (operand-read operand-1) (operand-read operand-2))))
(set-o (if (> sum #xFFFF) 1 0))
(operand-write sum operand-1)))
(defun execute-sub (operand-1 operand-2)
(let ((diff (- (operand-read operand-1) (operand-read operand-2))))
(set-o (if (< diff 0) #xFFFF 0))
(operand-write diff operand-1)))
(defun execute-mul (operand-1 operand-2)
(let ((prod (* (operand-read operand-1) (operand-read operand-2))))
(set-o (ash prod -16))
(operand-write prod operand-1)))
(defun execute-div (operand-1 operand-2)
(let ((a (operand-read operand-1))
(b (operand-read operand-2)))
(cond ((zerop b)
(set-o 0)
(operand-write 0 operand-1))
(set-o (floor (ash a 16) b))
(operand-write (floor a b) operand-1)))))
(defun execute-mod (operand-1 operand-2)
(let ((a (operand-read operand-1))
(b (operand-read operand-2)))
(if (zerop b)
(operand-write 0 operand-1)
(operand-write (mod a b) operand-1))))
(defun execute-shl (operand-1 operand-2)
(let ((shifted (ash (operand-read operand-1) (operand-read operand-2))))
(set-o (ash shifted -16))
(operand-write shifted operand-1)))
(defun execute-shr (operand-1 operand-2)
(let ((a (operand-read operand-1))
(b (operand-read operand-2)))
(set-o (ash (ash a 16) (- b)))
(operand-write (ash a (- b)) operand-1)))
(defun execute-and (operand-1 operand-2)
(operand-write (logand (operand-read operand-1) (operand-read operand-2))
(defun execute-bor (operand-1 operand-2)
(operand-write (logior (operand-read operand-1) (operand-read operand-2))
(defun execute-xor (operand-1 operand-2)
(operand-write (logxor (operand-read operand-1) (operand-read operand-2))
(defun execute-ife (operand-1 operand-2)
(when (/= (operand-read operand-1) (operand-read operand-2))
(defun execute-ifn (operand-1 operand-2)
(when (= (operand-read operand-1) (operand-read operand-2))
(defun execute-ifg (operand-1 operand-2)
(when (<= (operand-read operand-1) (operand-read operand-2))
(defun execute-ifb (operand-1 operand-2)
(when (zerop (logand (operand-read operand-1) (operand-read operand-2)))
(defun execute-jsr (operand-1)
(let ((sp (get-sp)))
(set-sp (1- sp))
(ram-write (get-pc) (1- sp) *ram*)
(set-pc (operand-read operand-1))))
(defun process-instruction (basic-function non-basic-function)
(let* ((word (consume-word))
(bits (extract-basic-opcode-bits word)))
(if (zerop bits)
(funcall non-basic-function
(extract-non-basic-opcode-bits word))
(read-operand word 10))
(funcall basic-function
(find-basic-opcode-by-bits bits)
(read-operand word 4)
(read-operand word 10)))))
(defun extract-basic-opcode-bits (word)
(logand word #x0F))
(defun extract-non-basic-opcode-bits (word)
(logand (ash word -4) #x3F))
(defun extract-operand-bits (word base)
(logand (ash word (- base)) #x3F))
(defun execute-instruction ()
(process-instruction #'execute-basic-instruction
(defun execute-basic-instruction (opcode operand-1 operand-2)
(cond (*skip-instruction*
(t (funcall (opcode-execute-function opcode) operand-1 operand-2)
(incf *cycles-count* (opcode-cycles-count opcode))
(incf *cycles-count* (operand-cycles-count (car operand-1)))
(incf *cycles-count* (operand-cycles-count (car operand-2))))))
(defun execute-non-basic-instruction (opcode operand-1)
(cond (*skip-instruction*
(t (funcall (opcode-execute-function opcode) operand-1)
(incf *cycles-count* (opcode-cycles-count opcode))
(incf *cycles-count* (operand-cycles-count (car operand-1))))))
(defun read-operand (word base)
(let* ((bits (extract-operand-bits word base))
(operand (find-operand-by-bits bits)))
(cons operand
(ecase (operand-length operand)
(0 nil)
(1 (consume-word))))))
(defun operand-read (operand-and-word)
(operand-read-1 (car operand-and-word) (cdr operand-and-word)))
(defun operand-write (value operand-and-word)
(operand-write-1 value (car operand-and-word) (cdr operand-and-word)))
(defun operand-format (operand-and-word)
(operand-format-1 (car operand-and-word) (cdr operand-and-word)))
(defun execute (ram)
(let ((*register-file* (make-register-file))
(*ram* ram)
(*cycles-count* 0)
(*skip-instruction* nil)
(last-pc -1))
(set-sp #xFFFF)
(if (= last-pc (get-pc))
(setf last-pc (get-pc))))))
(defun debug (ram)
(let ((*register-file* (make-register-file))
(*ram* ram)
(*cycles-count* 0)
(*skip-instruction* nil))
(set-sp #xFFFF)
(catch 'debug-exit
(let ((command (prompt-debug-command)))
(when (consp command)
(apply (command-function (car command))
(cdr command))))))))
(defun command-function (command)
(or (get command 'debug-function)
(unknown-command command)))
(defun unknown-command (command)
(lambda (&rest args)
(format t "Unknown command ~S (with args ~S).~%" command args)))
(defmacro define-debug-command ((&rest aliases) (&rest params) &body forms)
`(let ((fn (lambda (,@params) ,@forms)))
(dolist (alias ',aliases)
(setf (get alias 'debug-function) fn))
(define-debug-command (p step) ()
(define-debug-command (d words) (offset)
(print-words (ram-words offset *ram*) offset))
(define-debug-command (g step-until) (&optional offset)
(loop for pc = (get-pc)
and last-pc = -1 then pc
until (or (= pc last-pc) (and offset (= pc offset)))
do (execute-instruction)))
(define-debug-command (u disasm) (&optional (n 2))
(loop repeat n
do (format t "~4,'0X: ~A~%" (get-pc) (current-instruction)))))
(define-debug-command (q bye quit) ()
(throw 'debug-exit nil))
(defun print-debug-info ()
(print-register-file *register-file*)
(format t "Cycles: ~D Instruction: ~A ~:[~;SKIPPING~]~%"
(saving-pc (current-instruction))
(defun print-words (words &optional (base-offset 0))
(loop for i from 0
for word = (pop words)
while word
do (when (zerop (mod i 8))
(format t "~&~4,'0X: " (+ base-offset i)))
(format t "~4,'0X " word)
finally (terpri)))
(defun ram-words (offset ram)
(loop repeat 16
for i from offset
when (< i (ram-size ram))
collect (ram-read i ram)))
(defun print-register-file (file)
(loop for reg in '(a b c x y z i j pc sp o)
do (format t "~A: ~4,'0X " reg (reg-read reg file))))
(defun prompt-debug-command ()
(format t "> ")
(read (make-concatenated-stream
(make-string-input-stream "(")
(make-string-input-stream (read-line))
(make-string-input-stream ")"))))
(defun current-instruction ()
(process-instruction #'current-basic-instruction
(defun current-basic-instruction (opcode operand-1 operand-2)
(list (opcode-mnemonic opcode)
(operand-format operand-1)
(operand-format operand-2)))
(defun current-non-basic-instruction (opcode operand-1)
(list (opcode-mnemonic opcode)
(operand-format operand-1)))
(defun load-program (words ram &optional (offset 0))
(dolist (word words)
(ram-write word offset ram)
(incf offset))
;;; Assembler
(defun make-labels-map ()
"Return an empty labels-map. A labels-map maps labels to
(defun extend-labels-map (label offset labels-map)
"Extend a LABELS-MAP with a LABEL-OFFSET mapping."
(acons label offset labels-map))
(defun lookup-label-offset (label labels-map)
"Map a LABEL to its offset. If no such mapping exists, return NIL."
(cdr (assoc label labels-map)))
(defun subst-offsets-for-labels (instructions labels-map)
"Replace the labels referenced in the list of INSTRUCTIONS with
their corresponding offsets in accordance with LABELS-MAP."
(sublis labels-map instructions))
(defun instruction-op (instruction)
"Return the instruction's operator."
(car instruction))
(defun instruction-a (instruction)
"Return the instruction's first operand."
(cadr instruction))
(defun instruction-b (instruction)
"Return the instruction's second operand."
(caddr instruction))
(defun assemble-instruction (instruction)
"Assemble a single instruction, returning the corresponding list of
(if (basic-instruction-p instruction)
(assemble-basic-instruction instruction)
(assemble-non-basic-instruction instruction)))
(defun assemble-basic-instruction (instruction)
"Assemble a basic instruction, returning a list of words."
(append (list (basic-instruction-word instruction))
(instruction-operand-words (instruction-a instruction))
(instruction-operand-words (instruction-b instruction))))
(defun basic-instruction-word (instruction)
"Return the basic instruction's first word."
(logior (ash (basic-instruction-opcode-bits (instruction-op instruction)) 0)
(ash (instruction-operand-bits (instruction-a instruction)) 4)
(ash (instruction-operand-bits (instruction-b instruction)) 10)))
(defun assemble-non-basic-instruction (instruction)
"Assemble a non-basic instruction, returning a list of words."
(append (list (non-basic-instruction-word instruction))
(instruction-operand-words (instruction-a instruction))))
(defun non-basic-instruction-word (instruction)
"Return the non-basic instruction's first word."
(logior (ash 0 0)
(ash (non-basic-instruction-opcode-bits (instruction-op instruction)) 4)
(ash (instruction-operand-bits (instruction-a instruction)) 10)))
(defclass opcode ()
((mnemonic :initarg :mnemonic :reader opcode-mnemonic)
(bits :initarg :bits :reader opcode-bits)
(cycles-count :initarg :cycles-count :reader opcode-cycles-count)
(execute-function :initarg :execute-function :reader opcode-execute-function)))
(defclass basic-opcode (opcode)
(defclass non-basic-opcode (opcode)
(defclass opcode-index ()
((by-mnemonic :initarg :by-mnemonic :reader opcode-index-by-mnemonic)
(basic-by-bits :initarg :basic-by-bits :reader opcode-index-basic-by-bits)
(non-basic-by-bits :initarg :non-basic-by-bits :reader opcode-index-non-basic-by-bits)))
(defun make-opcode-index (opcodes)
(let ((by-mnemonic (make-hash-table))
(basic-by-bits (make-hash-table))
(non-basic-by-bits (make-hash-table)))
(dolist (opcode opcodes)
(setf (gethash (opcode-mnemonic opcode) by-mnemonic) opcode)
(setf (gethash (opcode-bits opcode)
(etypecase opcode
(basic-opcode basic-by-bits)
(non-basic-opcode non-basic-by-bits)))
(make-instance 'opcode-index
:by-mnemonic by-mnemonic
:basic-by-bits basic-by-bits
:non-basic-by-bits non-basic-by-bits)))
(defvar *opcode-index*
(list (make-instance 'basic-opcode :mnemonic 'set :bits #x01 :cycles-count 1 :execute-function 'execute-set)
(make-instance 'basic-opcode :mnemonic 'add :bits #x02 :cycles-count 2 :execute-function 'execute-add)
(make-instance 'basic-opcode :mnemonic 'sub :bits #x03 :cycles-count 2 :execute-function 'execute-sub)
(make-instance 'basic-opcode :mnemonic 'mul :bits #x04 :cycles-count 2 :execute-function 'execute-mul)
(make-instance 'basic-opcode :mnemonic 'div :bits #x05 :cycles-count 3 :execute-function 'execute-div)
(make-instance 'basic-opcode :mnemonic 'mod :bits #x06 :cycles-count 3 :execute-function 'execute-mod)
(make-instance 'basic-opcode :mnemonic 'shl :bits #x07 :cycles-count 2 :execute-function 'execute-shl)
(make-instance 'basic-opcode :mnemonic 'shr :bits #x08 :cycles-count 2 :execute-function 'execute-shr)
(make-instance 'basic-opcode :mnemonic 'and :bits #x09 :cycles-count 1 :execute-function 'execute-and)
(make-instance 'basic-opcode :mnemonic 'bor :bits #x0A :cycles-count 1 :execute-function 'execute-bor)
(make-instance 'basic-opcode :mnemonic 'xor :bits #x0B :cycles-count 1 :execute-function 'execute-xor)
(make-instance 'basic-opcode :mnemonic 'ife :bits #x0C :cycles-count 2 :execute-function 'execute-ife)
(make-instance 'basic-opcode :mnemonic 'ifn :bits #x0D :cycles-count 2 :execute-function 'execute-ifn)
(make-instance 'basic-opcode :mnemonic 'ifg :bits #x0E :cycles-count 2 :execute-function 'execute-ifg)
(make-instance 'basic-opcode :mnemonic 'ifb :bits #x0F :cycles-count 2 :execute-function 'execute-ifb)
(make-instance 'non-basic-opcode :mnemonic 'jsr :bits #x01 :cycles-count 2 :execute-function 'execute-jsr))))
(defun find-opcode-by-mnemonic (mnemonic)
(gethash mnemonic (opcode-index-by-mnemonic *opcode-index*)))
(defun find-basic-opcode-by-bits (bits)
(gethash bits (opcode-index-basic-by-bits *opcode-index*)))
(defun find-non-basic-opcode-by-bits (bits)
(gethash bits (opcode-index-non-basic-by-bits *opcode-index*)))
(defun basic-instruction-p (instruction)
"Return true if the instruction is a basic one, and false
(let ((opcode (find-opcode-by-mnemonic (instruction-op instruction))))
(typep opcode 'basic-opcode)))
(defun basic-instruction-opcode-bits (op)
"Return opcode bits for a basic instruction's operator."
(let ((opcode (find-opcode-by-mnemonic op)))
(check-type opcode basic-opcode)
(opcode-bits opcode)))
(defun non-basic-instruction-opcode-bits (op)
"Return the opcode bits for a non-basic instruction's operator."
(let ((opcode (find-opcode-by-mnemonic op)))
(check-type opcode non-basic-opcode)
(opcode-bits opcode)))
(defclass operand ()
((cycles-count :initarg :cycles-count :reader operand-cycles-count)
(bits :initarg :bits :reader operand-bits)))
(defgeneric operand-test-p (expr operand))
(defgeneric operand-words (expr operand))
(defgeneric operand-read-1 (operand word))
(defgeneric operand-write-1 (value operand word))
(defgeneric operand-length (operand))
(defgeneric operand-format-1 (operand word))
(defclass operand-no-words-mixin ()
(defmethod operand-words (expr (operand operand-no-words-mixin))
(declare (ignore expr))
(defmethod operand-length ((operand operand-no-words-mixin))
(defclass operand-symbol-mixin ()
((symbol :initarg :symbol :reader operand-symbol)))
(defmethod operand-test-p (expr (operand operand-symbol-mixin))
(eq expr (operand-symbol operand)))
(defmethod operand-format-1 ((operand operand-symbol-mixin) word)
(declare (ignore word))
(operand-symbol operand))
(defclass register-operand (operand-no-words-mixin operand-symbol-mixin operand)
(:default-initargs :cycles-count 0))
(defmethod operand-read-1 ((operand register-operand) word)
(declare (ignore word))
(reg-read (operand-symbol operand) *register-file*))
(defmethod operand-write-1 (value (operand register-operand) word)
(declare (ignore word))
(reg-write value (operand-symbol operand) *register-file*))
(defclass reg-ref-operand (operand-no-words-mixin operand)
((symbol :initarg :symbol :reader operand-symbol))
(:default-initargs :cycles-count 0))
(defmethod operand-test-p (expr (operand reg-ref-operand))
(and (consp expr)
(eq (car expr) (operand-symbol operand))))
(defmethod operand-read-1 ((operand reg-ref-operand) word)
(declare (ignore word))
(let ((offset (reg-read (operand-symbol operand) *register-file*)))
(ram-read offset *ram*)))
(defmethod operand-write-1 (value (operand reg-ref-operand) word)
(declare (ignore word))
(let ((offset (reg-read (operand-symbol operand) *register-file*)))
(ram-write value offset *ram*)))
(defmethod operand-format-1 ((operand reg-ref-operand) word)
(declare (ignore word))
(list (operand-symbol operand)))
(defclass add-reg-ref-operand (operand)
((symbol :initarg :symbol :reader operand-symbol))
(:default-initargs :cycles-count 1))
(defmethod operand-test-p (expr (operand add-reg-ref-operand))
(and (consp expr)
(eq (car expr) '+)
(or (eq (cadr expr) (operand-symbol operand))
(eq (caddr expr) (operand-symbol operand)))))
(defmethod operand-words (expr (operand add-reg-ref-operand))
(let ((a (cadr expr))
(b (caddr expr)))
(if (integerp a)
(list a)
(list b))))
(defun add-reg-ref-offset (operand word)
(let ((reg (reg-read (operand-symbol operand) *register-file*)))
(logand (+ reg word) #xFFFF)))
(defmethod operand-read-1 ((operand add-reg-ref-operand) word)
(ram-read (add-reg-ref-offset operand word) *ram*))
(defmethod operand-write-1 (value (operand add-reg-ref-operand) word)
(ram-write value (add-reg-ref-offset operand word) *ram*))
(defmethod operand-length ((operand add-reg-ref-operand))
(defmethod operand-format-1 ((operand add-reg-ref-operand) word)
(list '+ (operand-symbol operand) word))
(defclass pop-operand (operand-no-words-mixin operand-symbol-mixin operand)
(:default-initargs :cycles-count 0))
(defmethod operand-read-1 ((operand pop-operand) word)
(declare (ignore word))
(let ((sp (get-sp)))
(set-sp (1+ sp))
(ram-read sp *ram*)))
(defmethod operand-write-1 (value (operand pop-operand) word)
(declare (ignore word))
(let ((sp (get-sp)))
(set-sp (1+ sp))
(ram-write value sp *ram*)))
(defclass peek-operand (operand-no-words-mixin operand-symbol-mixin operand)
(:default-initargs :cycles-count 0))
(defmethod operand-read-1 ((operand peek-operand) word)
(declare (ignore word))
(let ((sp (get-sp)))
(ram-read sp *ram*)))
(defmethod operand-write-1 (value (operand peek-operand) word)
(declare (ignore word))
(let ((sp (get-sp)))
(ram-write value sp *ram*)))
(defclass push-operand (operand-no-words-mixin operand-symbol-mixin operand)
(:default-initargs :cycles-count 0))
(defmethod operand-read-1 ((operand push-operand) word)
(declare (ignore word))
(let ((sp (get-sp)))
(set-sp (1- sp))
(ram-read (1- sp) *ram*)))
(defmethod operand-write-1 (value (operand push-operand) word)
(declare (ignore word))
(let ((sp (get-sp)))
(set-sp (1- sp))
(ram-write value (1- sp) *ram*)))
(defclass ref-operand (operand)
(:default-initargs :cycles-count 1))
(defmethod operand-test-p (expr (operand ref-operand))
(consp expr))
(defmethod operand-words (expr (operand ref-operand))
(defmethod operand-read-1 ((operand ref-operand) word)
(ram-read word *ram*))
(defmethod operand-write-1 (value (operand ref-operand) word)
(ram-write value word *ram*))
(defmethod operand-length ((operand ref-operand))
(defmethod operand-format-1 ((operand ref-operand) word)
(list word))
(defclass literal-operand (operand)
(:default-initargs :cycles-count 1))
(defmethod operand-test-p (expr (operand literal-operand))
(integerp expr))
(defmethod operand-words (expr (operand literal-operand))
(list expr))
(defmethod operand-read-1 ((operand literal-operand) word)
(defmethod operand-write-1 (value (operand literal-operand) word)
(declare (ignore value word)))
(defmethod operand-length ((operand literal-operand))
(defmethod operand-format-1 ((operand literal-operand) word)
;;; Small literal operands are no good at the moment because they
;;; confuse labels mapping.
(defclass small-literal-operand (operand-no-words-mixin operand)
(:default-initargs :cycles-count 0))
(defmethod operand-test-p (expr (operand small-literal-operand))
(and (integerp expr)
(= expr (- (operand-bits operand) #x20))))
(defmethod operand-read-1 ((operand small-literal-operand) word)
(declare (ignore word))
(- (operand-bits operand) #x20))
(defmethod operand-write-1 (value (operand small-literal-operand) word)
(declare (ignore value word)))
(defmethod operand-format-1 ((operand small-literal-operand) word)
(declare (ignore word))
(- (operand-bits operand) #x20))
(defclass operand-index ()
((list :initarg :list :reader operand-index-list)
(by-bits :initarg :by-bits :reader operand-index-by-bits)))
(defun make-operand-index (operands)
(let ((by-bits (make-hash-table)))
(dolist (operand operands)
(setf (gethash (operand-bits operand) by-bits) operand))
(make-instance 'operand-index
:list operands
:by-bits by-bits)))
(defvar *operand-index*
(list (make-instance 'register-operand :symbol 'a :bits #x00)
(make-instance 'register-operand :symbol 'b :bits #x01)
(make-instance 'register-operand :symbol 'c :bits #x02)
(make-instance 'register-operand :symbol 'x :bits #x03)
(make-instance 'register-operand :symbol 'y :bits #x04)
(make-instance 'register-operand :symbol 'z :bits #x05)
(make-instance 'register-operand :symbol 'i :bits #x06)
(make-instance 'register-operand :symbol 'j :bits #x07)
(make-instance 'reg-ref-operand :symbol 'a :bits #x08)
(make-instance 'reg-ref-operand :symbol 'b :bits #x09)
(make-instance 'reg-ref-operand :symbol 'c :bits #x0A)
(make-instance 'reg-ref-operand :symbol 'x :bits #x0B)
(make-instance 'reg-ref-operand :symbol 'y :bits #x0C)
(make-instance 'reg-ref-operand :symbol 'z :bits #x0D)
(make-instance 'reg-ref-operand :symbol 'i :bits #x0E)
(make-instance 'reg-ref-operand :symbol 'j :bits #x0F)
(make-instance 'add-reg-ref-operand :symbol 'a :bits #x10)
(make-instance 'add-reg-ref-operand :symbol 'b :bits #x11)
(make-instance 'add-reg-ref-operand :symbol 'c :bits #x12)
(make-instance 'add-reg-ref-operand :symbol 'x :bits #x13)
(make-instance 'add-reg-ref-operand :symbol 'y :bits #x14)
(make-instance 'add-reg-ref-operand :symbol 'z :bits #x15)
(make-instance 'add-reg-ref-operand :symbol 'i :bits #x16)
(make-instance 'add-reg-ref-operand :symbol 'j :bits #x17)
(make-instance 'pop-operand :symbol 'pop :bits #x18)
(make-instance 'peek-operand :symbol 'peek :bits #x19)
(make-instance 'push-operand :symbol 'push :bits #x1A)
(make-instance 'register-operand :symbol 'sp :bits #x1B)
(make-instance 'register-operand :symbol 'pc :bits #x1C)
(make-instance 'register-operand :symbol 'o :bits #x1D)
(make-instance 'ref-operand :bits #x1E)
(make-instance 'literal-operand :bits #x1F))))
(defun find-operand-for-expression (expr)
(let ((list (operand-index-list *operand-index*)))
(or (find-if (lambda (operand) (operand-test-p expr operand)) list)
(find-if (lambda (operand) (typep operand 'literal-operand)) list))))
(defun find-operand-by-bits (bits)
(or (gethash bits (operand-index-by-bits *operand-index*))
(error "Can't find operand with bits ~S." bits)))
(defun instruction-operand-words (arg)
"Return the list of additional words for an operand."
(operand-words arg (find-operand-for-expression arg)))
(defun instruction-operand-bits (arg)
"Return the bits representing an operand."
(operand-bits (find-operand-for-expression arg)))
(defun instruction-operand-length (arg)
"Return the length of an instruction's operand."
(operand-length (find-operand-for-expression arg)))
(defun instruction-length (instruction)
"Return the length of an instruction, in words."
(if (basic-instruction-p instruction)
(+ (instruction-operand-length (instruction-a instruction))
(instruction-operand-length (instruction-b instruction))
(+ (instruction-operand-length (instruction-a instruction))
(defun assemble-program (program &optional (base-offset 0))
"Assemble a sequence of instructions and labels, returning the
corresponding list of words."
(mappend #'assemble-instruction (program-instructions program base-offset)))
(defun program-instructions (program base-offset)
(subst-offsets-for-labels (remove-labels program)
(build-labels-map program base-offset)))
(defun mappend (function list)
(if (null list)
(append (funcall function (car list))
(mappend function (cdr list)))))
(defun build-labels-map (program base-offset)
"Build up a labels-map for the supplied PROGRAM, with starting
offset of BASE-OFFSET."
(labels ((iter (subprogram labels-map offset)
(cond ((null subprogram) labels-map)
((symbolp (car subprogram))
(iter (cdr subprogram)
(extend-labels-map (car subprogram) offset labels-map)
(iter (cdr subprogram)
(+ offset (instruction-length (car subprogram))))))))
(iter program (make-labels-map) base-offset)))
(defun remove-labels (program)
"Remove labels from a program, returning a list of instructions."
(remove-if #'symbolp program))
;;;; Test vector
(defvar *program*
'((set a #x30)
(set (#x1000) #x20)
(sub a (#x1000))
(ifn a #x10)
(set pc crash)
(set i 10)
(set a #x2000)
(set (+ #x2000 i) (a))
(sub i 1)
(ifn i 0)
(set pc loop)
(set x #x04)
(jsr test-sub)
(set pc crash)
(shl x 4)
(set pc pop)
(set pc crash)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment