;;;; -*- mode: Lisp; Syntax: ANSI-Common-Lisp; Package: ("6502-TESTS" ("CL" "6502" "RT")); -*-
;;;;
;;;; 6502-tests.lisp
;;;;
;;;; Uses RT regression test framework

(cl:defpackage "6502-TESTS"
  (:use "COMMON-LISP" "6502" #+sbcl "SB-RT" #-sbcl "RT"))

(in-package "6502-TESTS")

(defmacro def-branch-test (instruction opcode)
  "Define a test for a branch instruction (a symbol) which has
the specified numeric opcode."
  (let ((base-name (symbol-name instruction))
	(sym instruction)
	(code opcode))
    `(progn
       (deftest ,(make-symbol (concatenate 'string base-name "-test-1"))
	   (opcode-to-byte (make-symbolic-opcode ',sym :BRANCH-RELATIVE)) 
	 ,code)
       (deftest ,(make-symbol (concatenate 'string base-name "-test-2"))
	   (opcode-to-byte (make-symbolic-opcode ',sym nil))
	 ,code)
       (deftest ,(make-symbol (concatenate 'string base-name "-test-3"))
	   (handler-case 
	       (opcode-to-byte (make-symbolic-opcode ',sym :IMMEDIATE))
	     (bad-address-mode () :pass)
	     (error () :unexpected-error)
	     (:no-error () :no-error))
	 :pass)
       (deftest ,(make-symbol (concatenate 'string base-name "-test-4"))
	   (handler-case 
	       (opcode-to-byte (make-symbolic-opcode ',sym :BOGUS))
	     (bad-address-mode () :pass)
	     (error () :unexpected-error)
	     (:no-error () :no-error))
	 :pass))))


(def-branch-test BCC 144)
(def-branch-test BCS 176)
(def-branch-test BEQ 240)
(def-branch-test BNE 208)
(def-branch-test BVS 112)
(def-branch-test BVC 80)
(def-branch-test BMI 48)
(def-branch-test BPL 16)

;;; RT apparently doesn't support "suites" of tests

#||
(build-suite "branch-suite" 
     "BCC-test" "BCS-test"
     "BEQ-test" "BNE-test"
     "BVS-test" "BVC-test"
     "BMI-test" "BPL-test")
||#  

(defmacro def-implied-test (instruction opcode)
  "Define a test for an implied-address-mode instruction (a symbol) which has
the specified numeric opcode."
  (let ((base-name (symbol-name instruction))
	(sym instruction)
	(code opcode))
    `(progn
       (deftest ,(make-symbol (concatenate 'string base-name "-test-1"))
	   (opcode-to-byte (make-symbolic-opcode ',sym :IMPLIED))
	 ,code)
       (deftest ,(make-symbol (concatenate 'string base-name "-test-2"))
	   (opcode-to-byte (make-symbolic-opcode ',sym nil))
	 ,code)
       (deftest ,(make-symbol (concatenate 'string base-name "-test-3"))
	   (handler-case 
	       (opcode-to-byte (make-symbolic-opcode ',sym :BRANCH-RELATIVE))
	     (bad-address-mode () :pass)
	     (error () :unexpected-error)
	     (:no-error () :no-error))
	 :pass)
       (deftest ,(make-symbol (concatenate 'string base-name "-test-4"))
	   (handler-case 
	       (opcode-to-byte (make-symbolic-opcode ',sym :IMMEDIATE))
	     (bad-address-mode () :pass)
	     (error () :unexpected-error)
	     (:no-error () :no-error))
	 :pass)
       (deftest ,(make-symbol (concatenate 'string base-name "-test-5"))
	   (handler-case 
	       (opcode-to-byte (make-symbolic-opcode ',sym :BOGUS))
	     (bad-address-mode () :pass)
	     (error () :unexpected-error)
	     (:no-error () :no-error))
	 :pass))))

(def-implied-test BRK 0)
(def-implied-test NOP 234)
(def-implied-test PHP 8)
(def-implied-test PLP 40)
(def-implied-test PHA 72)
(def-implied-test PLA 104)
(def-implied-test CLC 24)
(def-implied-test SEC 56)
(def-implied-test CLV 184)
(def-implied-test CLI 88)
(def-implied-test SEI 120)
(def-implied-test CLD 216)
(def-implied-test SED 248)
(def-implied-test DEX 202)
(def-implied-test DEY 136)
(def-implied-test INX 232)
(def-implied-test INY 200)
(def-implied-test RTS 96)
(def-implied-test RTI 64)
(def-implied-test TAX 170)
(def-implied-test TXA 138)
(def-implied-test TAY 168)
(def-implied-test TYA 152)
(def-implied-test TXS 154)
(def-implied-test TSX 186)

#||
(build-suite "implied-suite"
     "NOP-test" "BRK-test" 
     "PHP-test" "PLP-test"
     "PHA-test" "PLA-test"
     "CLC-test" "SEC-test"
     "CLI-test" "SEI-test"
     "CLD-test" "SED-test"
     "CLV-test" 
     "INX-test" "DEX-test" 
     "INY-test" "DEY-test"
     "RTS-test" "RTI-test" 
     "TXA-test" "TAX-test" 
     "TYA-test" "TAY-test"
     "TXS-test" "TSX-test")
||#

;;; opcodes with multiple valid address modes
;;; define arbitrary order
;;; accumulator, immediate, absolute absolute-x absolute-y
;;; zero-page, zero-page-x, zp-x-indirect, zp-indirect-y
;;; absolute-indirect
;;; numeric means valid opcode, nil means address-mode disallowed

;;; FIXME: add assert-error for BRANCH-RELATIVE, IMPLIED, nil address-mode

(defmacro def-opcode-test (instruction acc imm abs abs-x abs-y
			   zp zp-x zp-x-ind zp-y zp-ind-y
			   abs-ind)
  (let ((base-name (symbol-name instruction))
	(sym instruction)
	(test-counter 0))
    `(progn
       ,@(mapcar (function (lambda (opcode am)
		   `(deftest ,(make-symbol 
			       (concatenate 'string  
					    base-name "-test" 
					    (princ-to-string 
					     (incf test-counter))))
			,@(if opcode 
			      (list 
			       `(opcode-to-byte (make-symbolic-opcode
						 ',sym ,am))
			       opcode)
			      (list
			       `(handler-case 
				    (opcode-to-byte (make-symbolic-opcode 
						     ',sym ,am))
				  (bad-address-mode () :pass)
				  (error () :unexpected-error)
				  (:no-error () :no-error))
			       :pass)))))
		 (list acc imm
		       abs abs-x abs-y 
		       zp zp-x zp-x-ind zp-y zp-ind-y 
		       abs-ind)
		 '(:ACCUMULATOR :IMMEDIATE
		   :ABSOLUTE :ABSOLUTE-X :ABSOLUTE-Y
		   :ZERO-PAGE :ZERO-PAGE-X 
		   :ZP-X-INDIRECT 
		   :ZERO-PAGE-Y :ZP-INDIRECT-Y 
		   :ABSOLUTE-INDIRECT)))))

;;                    acc imm abs abs-x abs-y zp zp-x zp-x-ind zp-y zp-ind-y abs-ind

(def-opcode-test STA  nil nil 141  157   153  133 149    129   nil   145   nil)
(def-opcode-test LDA  nil 169 173  189   185  165 181    161   nil   177   nil)
(def-opcode-test ORA  nil   9  13   29    25    5  21      1   nil    17   nil)
(def-opcode-test ADC  nil 105 109  125   121  101 117     97   nil   113   nil)
(def-opcode-test SBC  nil 233 237  253   249  229 245    225   nil   241   nil)
(def-opcode-test EOR  nil  73  77   93    89   69  85     65   nil    81   nil)
(def-opcode-test CMP  nil 201 205  221   217  197 213    193   nil   209   nil)
(def-opcode-test AND  nil  41  45   61    57   37  53     33   nil    49   nil)

#||
(build-suite "accum-suite"
     "STA-test" "LDA-test"
     "ADC-test" "SBC-test"
     "ORA-test" "EOR-test" "AND-test" 
     "CMP-test")
||#

;;                    acc imm abs abs-x abs-y zp zp-x zp-x-ind zp-y zp-ind-y abs-ind
(def-opcode-test ASL   10 nil  14   30   nil   6   22    nil   nil   nil   nil)
(def-opcode-test LSR   74 nil  78   94   nil  70   86    nil   nil   nil   nil)
(def-opcode-test ROR  106 nil 110  126   nil 102  118    nil   nil   nil   nil)
(def-opcode-test ROL   42 nil  46   62   nil  38   54    nil   nil   nil   nil)

#||
(build-suite "rotate-suite"
     "ASL-test" "LSR-test"
     "ROL-test" "ROR-test")
||#

;;                    acc imm abs abs-x abs-y zp zp-x zp-x-ind zp-y zp-ind-y abs-ind
(def-opcode-test INC  nil nil 238  254   nil 230  246    nil   nil   nil   nil)
(def-opcode-test DEC  nil nil 206  222   nil 198  214    nil   nil   nil   nil)

(def-opcode-test BIT  nil nil  44  nil   nil  36  nil    nil   nil   nil   nil)

#||
(build-suite "inc/dec/bit-suite"
     "INC-test"
     "DEC-test"
     "BIT-test")
||#

;;                    acc imm abs abs-x abs-y zp zp-x zp-x-ind zp-y zp-ind-y abs-ind
(def-opcode-test JMP  nil nil  76  nil   nil nil  nil    nil   nil   nil   108)
(def-opcode-test JSR  nil nil  32  nil   nil nil  nil    nil   nil   nil   nil)

#||
(build-suite "jump-suite"
     "JSR-test"
     "JMP-test")
||#

;;                    acc imm abs abs-x abs-y zp zp-x zp-x-ind zp-y zp-ind-y abs-ind
(def-opcode-test LDX  nil 162 174  nil   190 166  nil    nil   182   nil   nil)
(def-opcode-test STX  nil nil 142  nil   nil 134  nil    nil   150   nil   nil)
(def-opcode-test LDY  nil 160 172  188   nil 164  180    nil   nil   nil   nil)
(def-opcode-test STY  nil nil 140  nil   nil 132  148    nil   nil   nil   nil)

(def-opcode-test CPX  nil 224 236  nil   nil 228  nil    nil   nil   nil   nil)
(def-opcode-test CPY  nil 192 204  nil   nil 196  nil    nil   nil   nil   nil)

#||
(build-suite "index-suite"
     "LDX-test" "LDY-test"
     "STX-test" "STY-test"
     "CPX-test" "CPY-test")
||#

#||
;; used by suites, unless the suite is built again.

;; suite-of-suites, requires modifications to elk-test.el

(build-suite "6502-opcode-suite" 
     "branch-suite" "implied-suite" "accum-suite" "rotate-suite"
     "inc/dec/bit-suite" "jump-suite" "index-suite")

||#