Recently Written · git

asm.lisp (9972 bytes)

 ;;; asm.lisp -- layer 2: a two-pass Z80 assembler hosted in SBCL.
 ;;; Source is a list of forms: a bare symbol is a label, a list is an
 ;;; instruction or directive, e.g. (ld a (@ hl)), (jp nz loop), (dw docol).
 ;;; (@ x) marks memory indirection: (@ hl), (@ ix 3) = (ix+3), (@ var) = (var).
 ;;; Immediates are numbers, label symbols, or (+ ...) / (- ...) / (lo x) / (hi x).
 
 (defpackage :z80 (:use :cl) (:export #:assemble #:insn->text))
 (in-package :z80)
 
 (defvar *labels*)
 (defvar *pc*)
 (defvar *out*)
 (defvar *final* nil "True on pass 2, when every label must resolve.")
 
 (defun nm (x) (and (symbolp x) (symbol-name x)))
 (defun is (x name) (equal (nm x) name))
 
 (defparameter +r8+ '("B" "C" "D" "E" "H" "L" nil "A"))
 (defparameter +r16+ '("BC" "DE" "HL" "SP"))
 (defparameter +cc+ '("NZ" "Z" "NC" "C" "PO" "PE" "P" "M"))
 (defparameter +alu+ '("ADD" "ADC" "SUB" "SBC" "AND" "XOR" "OR" "CP"))
 (defparameter +rot+ '("RLC" "RRC" "RL" "RR" "SLA" "SRA" nil "SRL"))
 (defparameter +simple+
   '(("NOP" #x00) ("RLCA" #x07) ("RRCA" #x0F) ("RLA" #x17) ("RRA" #x1F)
     ("CPL" #x2F) ("SCF" #x37) ("CCF" #x3F) ("HALT" #x76) ("DI" #xF3) ("EI" #xFB)
     ("RET" #xC9) ("EXX" #xD9) ("NEG" #xED #x44) ("LDIR" #xED #xB0)
     ("LDDR" #xED #xB8) ("CPIR" #xED #xB1)))
 
 (defun r8 (x)
   "Register code 0-7 of X, (@ hl) being 6, or NIL."
   (cond ((and (consp x) (is (car x) "@") (is (cadr x) "HL") (null (cddr x))) 6)
         ((symbolp x) (position (nm x) +r8+ :test #'equal))))
 (defun r16 (x &optional (list +r16+)) (and (symbolp x) (position (nm x) list :test #'equal)))
 (defun ixd (x) "Displacement of (@ ix d), or NIL."
   (and (consp x) (is (car x) "@") (is (cadr x) "IX") (or (caddr x) 0)))
 (defun mem (x) "Address expression of (@ expr), or NIL."
   (and (consp x) (is (car x) "@") (not (r16 (cadr x) '("HL" "BC" "DE" "SP" "IX"))) (cadr x)))
 (defun imm-p (x) (or (integerp x) (and (symbolp x) (not (r8 x)) (not (r16 x '("BC" "DE" "HL" "SP" "IX" "AF"))))
                      (and (consp x) (not (is (car x) "@")))))
 
 (defun value (x)
   (cond ((integerp x) x)
         ((characterp x) (char-code x))
         ((symbolp x) (or (gethash x *labels*)
                          (if *final* (error "undefined label ~s" x) 0)))
         ((is (car x) "+") (reduce #'+ (mapcar #'value (cdr x))))
         ((is (car x) "-") (apply #'- (mapcar #'value (cdr x))))
         ((is (car x) "LO") (logand (value (cadr x)) 255))
         ((is (car x) "HI") (logand (ash (value (cadr x)) -8) 255))
         (t (error "bad expression ~s" x))))
 
 (defun b (&rest bytes) (dolist (x bytes) (vector-push-extend (logand x 255) *out*) (incf *pc*)))
 (defun w (x) (let ((v (value x))) (b v (ash v -8))))
 (defun d8 (x) (let ((v (value x)))
                 (when (and *final* (not (<= -128 v 127))) (error "displacement ~d out of range" v)) v))
 (defun rel (x) (let ((v (- (value x) (+ *pc* 1))))
                  (when (and *final* (not (<= -128 v 127))) (error "jr to ~s out of range" x)) v))
 
 (defun insn (form)
   (let* ((op (nm (car form))) (x (cadr form)) (y (caddr form)) (n (length (cdr form))))
     (macrolet ((when-match (test &body body) `(when ,test ,@body (return-from insn))))
       (let ((s (assoc op +simple+ :test #'equal)))
         (when-match (and s (= n 0)) (apply #'b (cdr s))))
       (cond
         ((equal op "DB") (when-match t (dolist (v (cdr form)) (if (stringp v) (map nil (lambda (c) (b (char-code c))) v) (b (value v))))))
         ((equal op "DW") (when-match t (mapc #'w (cdr form))))
         ((equal op "LD")
          (let ((rx (r8 x)) (ry (r8 y)))
            (when-match (and rx ry (not (= rx ry 6))) (b (+ #x40 (* 8 rx) ry)))
            (when-match (and rx (ixd y)) (b #xDD (+ #x46 (* 8 rx)) (d8 (ixd y))))
            (when-match (and (ixd x) ry) (b #xDD (+ #x70 ry) (d8 (ixd x))))
            (when-match (and (ixd x) (imm-p y)) (b #xDD #x36 (d8 (ixd x)) (value y)))
            (when-match (and (is x "A") (consp y) (is (car y) "@") (is (cadr y) "BC")) (b #x0A))
            (when-match (and (is x "A") (consp y) (is (cadr y) "DE") (is (car y) "@")) (b #x1A))
            (when-match (and (is y "A") (consp x) (is (cadr x) "BC") (is (car x) "@")) (b #x02))
            (when-match (and (is y "A") (consp x) (is (cadr x) "DE") (is (car x) "@")) (b #x12))
            (when-match (and (is x "A") (mem y)) (b #x3A) (w (mem y)))
            (when-match (and (is y "A") (mem x)) (b #x32) (w (mem x)))
            (when-match (and rx (imm-p y)) (b (+ #x06 (* 8 rx)) (value y)))
            (when-match (and (is x "SP") (is y "HL")) (b #xF9))
            (when-match (and (is x "SP") (is y "IX")) (b #xDD #xF9))
            (when-match (and (is x "IX") (imm-p y)) (b #xDD #x21) (w y))
            (when-match (and (is x "IX") (mem y)) (b #xDD #x2A) (w (mem y)))
            (when-match (and (is y "IX") (mem x)) (b #xDD #x22) (w (mem x)))
            (when-match (and (is x "HL") (mem y)) (b #x2A) (w (mem y)))
            (when-match (and (is y "HL") (mem x)) (b #x22) (w (mem x)))
            (when-match (and (r16 x) (mem y)) (b #xED (+ #x4B (* 16 (r16 x)))) (w (mem y)))
            (when-match (and (r16 y) (mem x)) (b #xED (+ #x43 (* 16 (r16 y)))) (w (mem x)))
            (when-match (and (r16 x) (imm-p y)) (b (+ #x01 (* 16 (r16 x)))) (w y))))
         ((member op '("PUSH" "POP") :test #'equal)
          (let ((base (if (equal op "PUSH") #xC5 #xC1)))
            (when-match (is x "IX") (b #xDD (+ base #x20)))
            (when-match t (b (+ base (* 16 (r16 x '("BC" "DE" "HL" "AF"))))))))
         ((member op +alu+ :test #'equal)
          (let* ((k (position op +alu+ :test #'equal))
                 (src (if (and (= n 2) (is x "A")) y (if (= n 1) x nil))))
            (when-match (and (= n 2) (is x "HL") (r16 y))
              (case k (0 (b (+ #x09 (* 16 (r16 y))))) (1 (b #xED (+ #x4A (* 16 (r16 y)))))
                    (3 (b #xED (+ #x42 (* 16 (r16 y))))) (t (error "bad ~s" form))))
            (when-match (and (= n 2) (is x "IX") (= k 0))
              (b #xDD (+ #x09 (* 16 (r16 y '("BC" "DE" "IX" "SP"))))))
            (when-match (and src (r8 src)) (b (+ #x80 (* 8 k) (r8 src))))
            (when-match (and src (ixd src)) (b #xDD (+ #x86 (* 8 k)) (d8 (ixd src))))
            (when-match (and src (imm-p src)) (b (+ #xC6 (* 8 k)) (value src)))))
         ((member op '("INC" "DEC") :test #'equal)
          (let ((dec (equal op "DEC")))
            (when-match (is x "IX") (b #xDD (if dec #x2B #x23)))
            (when-match (ixd x) (b #xDD (if dec #x35 #x34) (d8 (ixd x))))
            (when-match (r8 x) (b (+ (if dec 5 4) (* 8 (r8 x)))))
            (when-match (r16 x) (b (+ (if dec #x0B #x03) (* 16 (r16 x)))))))
         ((equal op "JP")
          (when-match (and (consp x) (is (cadr x) "HL")) (b #xE9))
          (when-match (and (consp x) (is (cadr x) "IX")) (b #xDD #xE9))
          (when-match (= n 2) (b (+ #xC2 (* 8 (r16 x +cc+)))) (w y))
          (when-match t (b #xC3) (w x)))
         ((equal op "CALL")
          (when-match (= n 2) (b (+ #xC4 (* 8 (r16 x +cc+)))) (w y))
          (when-match t (b #xCD) (w x)))
         ((equal op "RET") (when-match t (b (+ #xC0 (* 8 (r16 x +cc+))))))
         ((equal op "JR")
          (when-match (= n 2) (b (+ #x20 (* 8 (r16 x '("NZ" "Z" "NC" "C"))))) (b (rel y)))
          (when-match t (b #x18) (b (rel x))))
         ((equal op "DJNZ") (when-match t (b #x10) (b (rel x))))
         ((equal op "RST") (when-match t (b (+ #xC7 (value x)))))
         ((equal op "EX")
          (when-match (is x "DE") (b #xEB))
          (when-match (and (consp x) (is y "HL")) (b #xE3))
          (when-match (and (consp x) (is y "IX")) (b #xDD #xE3))
          (when-match (is x "AF") (b #x08)))
         ((equal op "IN") (when-match (is x "A") (b #xDB (value (mem y)))))
         ((equal op "OUT") (when-match (is y "A") (b #xD3 (value (mem x)))))
         ((member op +rot+ :test #'equal)
          (when-match (r8 x) (b #xCB (+ (* 8 (position op +rot+ :test #'equal)) (r8 x)))))
         ((member op '("BIT" "RES" "SET") :test #'equal)
          (when-match (r8 y) (b #xCB (+ (* 64 (1+ (position op '("BIT" "RES" "SET") :test #'equal)))
                                        (* 8 (value x)) (r8 y))))))
       (error "cannot assemble ~s" form))))
 
 (defun assemble (forms)
   "Assemble FORMS at address 0. Return the byte vector and the label table."
   (let ((*labels* (make-hash-table)))
     (dolist (*final* '(nil t))
       (let ((*pc* 0) (*out* (make-array 0 :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0)))
         (dolist (f forms)
           (cond ((symbolp f)
                  (when (and (not *final*) (gethash f *labels*)) (error "duplicate label ~s" f))
                  (setf (gethash f *labels*) *pc*))
                 ((is (car f) "EQU") (setf (gethash (cadr f) *labels*) (value (caddr f))))
                 (t (insn f))))
         (when *final* (return-from assemble (values (coerce *out* '(simple-array (unsigned-byte 8) (*))) *labels*)))))))
 
 ;;; Standard-syntax printer, so the reference assembler can check our bytes.
 (defun opnd->text (x)
   (cond ((and (consp x) (is (car x) "@"))
          (if (and (is (cadr x) "IX") (cddr x)) (format nil "(ix+~d)" (caddr x)) (format nil "(~a)" (opnd->text (cadr x)))))
         ((consp x) (format nil "~{~a~^~a~}" (cdr (loop for a in (cdr x) collect (car x) collect (opnd->text a)))))
         ((stringp x) (format nil "'~a'" x))
         ((is x "AF") "af")
         ((symbolp x) (string-downcase (nm x)))
         (t (princ-to-string x))))
 (defun insn->text (form)
   (let ((op (string-downcase (nm (car form)))))
     (cond ((and (equal op "ex") (is (cadr form) "AF")) "ex af,af'")
           ((member op '("add" "adc" "sbc") :test #'equal)
            (format nil "~a ~{~a~^,~}" op (mapcar #'opnd->text (if (= (length form) 2) (list 'a (cadr form)) (cdr form)))))
           ((equal op "dw") (format nil "defw ~{~a~^,~}" (mapcar #'opnd->text (cdr form))))
           ((equal op "db") (format nil "defb ~{~a~^,~}" (mapcar #'opnd->text (cdr form))))
           (t (format nil "~a ~{~a~^,~}" op (mapcar #'opnd->text (cdr form)))))))