;;;
;;; Just playing around
;;;

;;; Begin 6502 disassembler

(in-package :neth)

;;; Just as a side-note, the 6502 instruction set makes more sense if you bit-reverse the instructions.

(defun dis6502-imp (array index base mnemonic)
  (format t "~(~4,'0X: ~2,'0X~)          ~A~%"
	  base (aref array index) mnemonic)
  1)

(defun dis6502-acc (array index base mnemonic)
  (format t "~(~4,'0X: ~2,'0X~)          ~A a~%"
	  base (aref array index) mnemonic)
  1)

(defun dis6502-imm (array index base mnemonic)
  (let ((operand (aref array (+ index 1))))
    (format t "~(~4,'0X: ~2,'0X ~2,'0X~)       ~A #$~(~2,'0X~)~%"
	    base (aref array index) operand mnemonic operand))
  2)

(defun dis6502-zpage (array index base mnemonic)
  (let ((operand (aref array (+ index 1))))
    (format t "~(~4,'0X: ~2,'0X ~2,'0X~)       ~A $~(~2,'0X~)~%"
	    base (aref array index) operand mnemonic operand))
  2)

(defun dis6502-zpagex (array index base mnemonic)
  (let ((operand (aref array (+ index 1))))
    (format t "~(~4,'0X: ~2,'0X ~2,'0X~)       ~A $~(~2,'0X~), X~%"
	    base (aref array index) operand mnemonic operand))
  2)

(defun dis6502-zpagey (array index base mnemonic)
  (let ((operand (aref array (+ index 1))))
    (format t "~(~4,'0X: ~2,'0X ~2,'0X~)       ~A $~(~2,'0X~), Y~%"
	    base (aref array index) operand mnemonic operand))
  2)

(defun dis6502-abs (array index base mnemonic)
  (let ((operand1 (aref array (+ index 1)))
	(operand2 (aref array (+ index 2))))
    (format t "~(~4,'0X: ~2,'0X ~2,'0X ~2,'0X~)    ~A $~(~2,'0X~2,'0X~)~%"
	    base (aref array index) operand1 operand2
	    mnemonic operand2 operand1))
  3)

(defun dis6502-absx (array index base mnemonic)
  (let ((operand1 (aref array (+ index 1)))
	(operand2 (aref array (+ index 2))))
    (format t "~(~4,'0X: ~2,'0X ~2,'0X ~2,'0X~)    ~A $~(~2,'0X~2,'0X~), X~%"
	    base (aref array index) operand1 operand2
	    mnemonic operand2 operand1))
  3)

(defun dis6502-absy (array index base mnemonic)
  (let ((operand1 (aref array (+ index 1)))
	(operand2 (aref array (+ index 2))))
    (format t "~(~4,'0X: ~2,'0X ~2,'0X ~2,'0X~)    ~A $~(~2,'0X~2,'0X~), Y~%"
	    base (aref array index) operand1 operand2
	    mnemonic operand2 operand1))
  3)

(defun dis6502-ind (array index base mnemonic)
  (let ((operand1 (aref array (+ index 1)))
	(operand2 (aref array (+ index 2))))
    (format t "~(~4,'0X: ~2,'0X ~2,'0X ~2,'0X~)    ~A ($~(~2,'0X~2,'0X~))~%"
	    base (aref array index) operand1 operand2
	    mnemonic operand2 operand1))
  3)

(defun dis6502-indx (array index base mnemonic)
  (let ((operand (aref array (+ index 1))))
    (format t "~(~4,'0X: ~2,'0X ~2,'0X~)       ~A ($~(~2,'0X~), X)~%"
	    base (aref array index) operand mnemonic operand))
  2)

(defun dis6502-indy (array index base mnemonic)
  (let ((operand (aref array (+ index 1))))
    (format t "~(~4,'0X: ~2,'0X ~2,'0X~)       ~A ($~(~2,'0X~)), Y~%"
	    base (aref array index) operand mnemonic operand))
  2)

; this just screams to be turned into a whole custom
; typeset with byte-array furbling...
(defun u8->s8 (x)
  (if (logbitp 7 x)
      (- x #x100)
    x))

(defun dis6502-rel (array index base mnemonic)
  (let ((operand (aref array (+ index 1))))
    (format t "~(~4,'0X: ~2,'0X ~2,'0X~)       ~A $~(~4,'0X~)~%"
	    base (aref array index) operand mnemonic
	    (+ base 2 (u8->s8 operand))))
  2)

;;; Decode tables

(declaim (type (simple-array string (256)) *dis6502-mnemonics*))
(defvar *dis6502-mnemonics* (make-array 256 :initial-element "???"))
(declaim (type (simple-array function (256)) *dis6502-opmodes*))
(defvar *dis6502-opmodes* (make-array 256 :initial-element #'dis6502-imp))

(defun dis6502-instr (opcode mnemonic opmode)
  (setf (aref *dis6502-mnemonics* opcode) mnemonic)
  (setf (aref *dis6502-opmodes* opcode) opmode))

; flag instructions
(dis6502-instr #x18 "CLC" #'dis6502-imp)
(dis6502-instr #x38 "SEC" #'dis6502-imp)
(dis6502-instr #x58 "CLI" #'dis6502-imp)
(dis6502-instr #x78 "SEI" #'dis6502-imp)
;; nothing for #x98.
(dis6502-instr #xb8 "CLV" #'dis6502-imp)
(dis6502-instr #xd8 "CLD" #'dis6502-imp)
(dis6502-instr #xf8 "SED" #'dis6502-imp)

; branch instructions
(dotimes (i 8)
	 (dis6502-instr (+ (* i #x20) #x10)
			(elt '("BPL" "BMI" "BVC" "BVS"
			       "BCC" "BCS" "BNE" "BEQ")
			     i)
			#'dis6502-rel))

; "big 8" instructions
(dotimes (i 8)
	 (let ((opmode (elt '((#x09 dis6502-imm)
			      (#x05 dis6502-zpage)
			      (#x15 dis6502-zpagex)
			      (#x0d dis6502-abs)
			      (#x1d dis6502-absx)
			      (#x19 dis6502-absy)
			      (#x01 dis6502-indx)
			      (#x11 dis6502-indy))
			    i)))
	   (dotimes (j 8)
		    ; pick off STA #imm, which is illegal
		    (if (not (and (= i 0)
				  (= j 4)))
			(dis6502-instr (+ (* j #x20) (car opmode))
				       (elt '("ORA" "AND" "EOR" "ADC"
					      "STA" "LDA" "CMP" "SBC")
					    j)
				       (fdefinition (cadr opmode)))))))

; shift/rotate instructions
(dotimes (i 5)
	 (let ((opmode (elt '((#x0a dis6502-acc)
			      (#x06 dis6502-zpage)
			      (#x16 dis6502-zpagex)
			      (#x0e dis6502-abs)
			      (#x1e dis6502-absx))
			    i)))
	   (dotimes (j 4)
		    (dis6502-instr (+ (* j #x20) (car opmode))
				   (elt '("ASL" "ROL" "LSR" "ROR") j)
				   (fdefinition (cadr opmode))))))

; stack instructions
(dis6502-instr #x08 "PHP" #'dis6502-imp)
(dis6502-instr #x28 "PLP" #'dis6502-imp)
(dis6502-instr #x48 "PHA" #'dis6502-imp)
(dis6502-instr #x68 "PLA" #'dis6502-imp)

; reg transfer instructions
(dis6502-instr #xaa "TAX" #'dis6502-imp)
(dis6502-instr #xa8 "TAY" #'dis6502-imp)
(dis6502-instr #xba "TSX" #'dis6502-imp)
(dis6502-instr #x8a "TXA" #'dis6502-imp)
(dis6502-instr #x9a "TXS" #'dis6502-imp)
(dis6502-instr #x98 "TYA" #'dis6502-imp)

; bit test instructions
(dis6502-instr #x24 "BIT" #'dis6502-zpage)
(dis6502-instr #x2c "BIT" #'dis6502-abs)

; inc-dec instructions
(dis6502-instr #xc6 "DEC" #'dis6502-zpage)
(dis6502-instr #xce "DEC" #'dis6502-abs)
(dis6502-instr #xd6 "DEC" #'dis6502-zpagex)
(dis6502-instr #xde "DEC" #'dis6502-absx)

(dis6502-instr #xe6 "INC" #'dis6502-zpage)
(dis6502-instr #xee "INC" #'dis6502-abs)
(dis6502-instr #xf6 "INC" #'dis6502-zpagex)
(dis6502-instr #xfe "INC" #'dis6502-absx)

(dis6502-instr #xe8 "INX" #'dis6502-imp)
(dis6502-instr #xc8 "INY" #'dis6502-imp)
(dis6502-instr #xca "DEX" #'dis6502-imp)
(dis6502-instr #x88 "DEY" #'dis6502-imp)

; load-store instructions
(dis6502-instr #xa2 "LDX" #'dis6502-imm)
(dis6502-instr #xa6 "LDX" #'dis6502-zpage)
(dis6502-instr #xb6 "LDX" #'dis6502-zpagey)
(dis6502-instr #xae "LDX" #'dis6502-abs)
(dis6502-instr #xbe "LDX" #'dis6502-absy)
(dis6502-instr #xa0 "LDY" #'dis6502-imm)
(dis6502-instr #xa4 "LDY" #'dis6502-zpage)
(dis6502-instr #xb4 "LDY" #'dis6502-zpagex)
(dis6502-instr #xac "LDY" #'dis6502-abs)
(dis6502-instr #xbc "LDY" #'dis6502-absx)
(dis6502-instr #x86 "STX" #'dis6502-zpage)
(dis6502-instr #x96 "STX" #'dis6502-zpagey)
(dis6502-instr #x8e "STX" #'dis6502-abs)
(dis6502-instr #x84 "STY" #'dis6502-zpage)
(dis6502-instr #x94 "STY" #'dis6502-zpagex)
(dis6502-instr #x8c "STY" #'dis6502-abs)

; compare instructions
(dotimes (i 3)
	 (let ((opmode (elt '((#xc0 dis6502-imm)
			      (#xc4 dis6502-zpage)
			      (#xcc dis6502-abs))
			    i)))
	   (dotimes (j 2)
		    (dis6502-instr (+ (* j #x20) (car opmode))
				   (elt '("CPY" "CPX") j)
				   (fdefinition (cadr opmode))))))

; misc instructions
(dis6502-instr #x00 "BRK" #'dis6502-imm)
(dis6502-instr #x20 "JSR" #'dis6502-abs)
(dis6502-instr #x40 "RTI" #'dis6502-imp)
(dis6502-instr #x4c "JMP" #'dis6502-abs)
(dis6502-instr #x60 "RTS" #'dis6502-imp)
(dis6502-instr #x6c "JMP" #'dis6502-ind)
(dis6502-instr #xea "NOP" #'dis6502-imp)

;;; Disassembly routines

(defun dis6502-one-instr (array index base)
  (let ((opcode (aref array index)))
    (funcall (aref *dis6502-opmodes* opcode)
	     array index base (aref *dis6502-mnemonics* opcode))))

(defun dis6502-n-instrs (array index base n)
  (dotimes (i n)
	   (let ((size (dis6502-one-instr array index base)))
	     (setf index (+ index size))
	     (setf base (+ base size)))))

;;; EOF
