DCPU-16 Lisp implementation

gistfile1.lisp

(defpackage #:dcpu-16
  (:use #:cl)
  (:export
   #: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 http://0x10c.com/doc/dcpu-16.txt

(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)))
       (multiple-value-prog1
           (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))
          (t
           (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))
                 operand-1))

(defun execute-bor (operand-1 operand-2)
  (operand-write (logior (operand-read operand-1) (operand-read operand-2))
                 operand-1))

(defun execute-xor (operand-1 operand-2)
  (operand-write (logxor (operand-read operand-1) (operand-read operand-2))
                 operand-1))

(defun execute-ife (operand-1 operand-2)
  (when (/= (operand-read operand-1) (operand-read operand-2))
    (skip-next-instruction)))

(defun execute-ifn (operand-1 operand-2)
  (when (= (operand-read operand-1) (operand-read operand-2))
    (skip-next-instruction)))

(defun execute-ifg (operand-1 operand-2)
  (when (<= (operand-read operand-1) (operand-read operand-2))
    (skip-next-instruction)))

(defun execute-ifb (operand-1 operand-2)
  (when (zerop (logand (operand-read operand-1) (operand-read operand-2)))
    (skip-next-instruction)))

(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
                 (find-non-basic-opcode-by-bits
                  (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
                       #'execute-non-basic-instruction))

(defun execute-basic-instruction (opcode operand-1 operand-2)
  (cond (*skip-instruction*
         (reset-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*
         (reset-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)
    (loop
     (execute-instruction)
     (if (= last-pc (get-pc))
         (return)
         (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
      (loop
       (print-debug-info)
       (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))
     ',aliases))

(define-debug-command (p step) ()
  (execute-instruction))

(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))
  (saving-pc
    (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~]~%"
          *cycles-count*
          (saving-pc (current-instruction))
          *skip-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
                       #'current-non-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))
  ram)

;;; Assembler

(defun make-labels-map ()
  "Return an empty labels-map.  A labels-map maps labels to
offsets."
  '())

(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
words."
  (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)))
            opcode))
    (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*
  (make-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
otherwise."
  (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))
  0)

(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))
  1)

(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))
  expr)

(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))
  1)

(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)
  word)

(defmethod operand-write-1 (value (operand literal-operand) word)
  (declare (ignore value word)))

(defmethod operand-length ((operand literal-operand))
  1)

(defmethod operand-format-1 ((operand literal-operand) word)
  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*
  (make-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))
         1)
      (+ (instruction-operand-length (instruction-a instruction))
         1)))

(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)
                          offset))
                   (t
                    (iter (cdr subprogram)
                          labels-map
                          (+ 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)
    loop
    (set (+ #x2000 i) (a))
    (sub i 1)
    (ifn i 0)
    (set pc loop)
            
    (set x #x04)
    (jsr test-sub)
    (set pc crash)
    test-sub
    (shl x 4)
    (set pc pop)
            
    crash
    (set pc crash)))