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

(cl:defpackage "COMFY-6502-TESTS"
  (:use "COMMON-LISP" "6502" "COMFY-6502" #+sbcl "SB-RT" #-sbcl "RT")
  (:shadowing-import-from "COMFY-6502" 
			  "COMPILE" "1+" "1-" "+" "-" "IF" "NOT" "LOOP"
			  "BREAK"))

(in-package "COMFY-6502-TESTS")

;;; test emission of code

(defun simple-gen ()
  (init)
  (comfy-6502::gen 1)
  (comfy-6502::gen 2)
  comfy-6502::*mem*)

(deftest simple-gen-1 (init) 0)
(deftest simple-gen-2 (progn (init) (comfy-6502::gen 1)) 1)
(deftest simple-gen-3 (simple-gen) (2 1))

(defgeneric to-opcode (thing)
  (:method ((thing t))
    thing)
  (:method ((thing 6502:symbolic-opcode))
    (cons (opcode thing) 
	       (cl:if (member (address-mode thing) 
			      '(:IMPLIED :ACCUMULATOR :BRANCH-RELATIVE))
		      nil
		      (list (address-mode thing))))))

(defmacro code-result (&body forms)
  `(progn
    (init)
    ,@forms
    (map 'list #'to-opcode comfy-6502:*mem*)))

(defmacro compile-code (comfy-form &optional (win 0) (lose 0))
  `(code-result (comfy-6502:compile ',comfy-form ,win ,lose)))

(defmacro code-result-and-value (&body comfy-forms)
  (let ((result (gensym)))
    `(let (,result)
      (values 
       (code-result (setq ,result (progn ,@comfy-forms)))
       ,result))))


(deftest branch-1 (code-result (comfy-6502::genbr 0))
  ((JMP :ABSOLUTE) (:LONG-BRANCH 2)))
   ; 3                   2        1

(deftest branch-1b (progn
		     (init)
		     (comfy-6502::genbr 0)
		     (map 'list #'to-opcode
			  (relocate comfy-6502::*mem* 97)))
  ((JMP :ABSOLUTE) 100 0))
   ; 97            ; 98 99 

(deftest branch-2 
    ;; conditional jump: win and lose destinations both longer than
    ;; 8-bit branch [case 8, then 7, then 4]
    (code-result (comfy-6502::genbrc '6502:BCC 
				     -1000
				     -2000))

  ;; inverts condition to skip three-byte long jump to win, landing on 
  ;; long jump to lose 
  
  ((BCS) (:BRANCH 4) 
   (JMP :ABSOLUTE) (:LONG-BRANCH 1005) 
   (JMP :ABSOLUTE) (:LONG-BRANCH 2002)))

(deftest branch-3
    ;; conditional jump: win and lose destinations both within 8-bit
    ;; branch [case 5]
    (code-result (comfy-6502::genbrc '6502:BEQ -10 90))
  ;; branch to win, branch with opposite condition to lose
  ((BEQ) (:BRANCH 13) (BNE) (:BRANCH -89)))

(deftest branch-4
    ;; conditional jump: win is current location, lose within 8-bit branch
    (code-result (comfy-6502::genbrc 'BVC 0 90))
  ;; invert condition to branch to lose, fall through to win
  ((BVS) (:BRANCH -89)))

(deftest branch-5
    ;; conditional jump: win is within 8-bit branch, lose is current location
    (code-result (comfy-6502::genbrc 'BPL -10 0))
    ;; short branch with win condition, fall through to lose
  ((BPL) (:BRANCH 11)))

(deftest branch-6
    ;; both win and lose are the same and fall through: don't need test
    (code-result-and-value (comfy-6502::genbrc 'BMI 0 0))
  nil 0)

(deftest branch-7
    ;; both win and lose are the same, destination *not* fall through
    (code-result-and-value (comfy-6502::genbrc 'BMI -100 -100))
  nil -100)

(deftest branch-8
    ;; both win and lose are short branches, but only if "win branch"
    ;; is emitted first [case 6]
    (code-result (comfy-6502::genbrc 'BNE -127 -100))
  ((BEQ) (:BRANCH 103) (BNE) (:BRANCH 128)))

#||
(deftest "branch"
    (assert-equal 100 (init))
  (assert-equal 97 (genbr (+ (* 256 111) 222)))
  (assert-equal 97 *f*)
  ;; unconditional jump, two byte address, LSB first
  (assert-equal '[JMP 222 111] (subseq *mem* f))
  ;; conditional jump: win and lose destinations both longer than
  ;; 8-bit branch [case 8, then 7, then 4]
  (assert-equal 89 (genbrc 'BCC (+ (* 256 102) 101) (+ (* 256 202) 201)))
  (assert-equal 89 f)
  ;; inverts condition to skip three-byte long jump to win, landing on 
  ;; long jump to lose [case 5]
  (assert-equal '[BCS 3 JMP 101 102 JMP 201 202] (subvector *mem* f (+ f 8)))

  ;; conditional jump: win and lose destinations both within 8-bit
  ;; branch [case 5]
  (assert-equal 85 (genbrc 'BEQ 97 10))
  (assert-equal 85 f)
  ;; branch to win, branch with opposite condition to lose
  ;; FIXED BUG: I think the BEQ destination is wrong: 87 + 6 = 93, not 97
  ;;; WAS BEQ 6 BNE -79
  ;;; JAO: fixed
  (assert-equal '[BEQ 10 BNE -79]
(subvector *mem* f (+ f 4)))

  ;; conditional jump: win is current location, lose within 8-bit branch
  (assert-equal 83 (genbrc 'BVC 85 10))
  (assert-equal 83 f)
  ;; invert condition to branch to lose, fall through to win
  (assert-equal '[BVS -75] 
(subvector *mem* f (+ f 2)))
  
  ;; conditional jump: win is within 8-bit branch, lose is current location
  (assert-equal 81 (genbrc 'BPL 101 83))
  ;; short branch with win condition, fall through to lose
  ;; 83 + 18 = 101
  (assert-equal '[BPL 18] 
(subvector *mem* f (+ f 2)))
  
  ;; both win and lose are the same and fall through: don't need test
  ;; but what should the return value be? gen routines seem to 
  ;; return f; is that conceptually identical to "win" in all cases?
  (assert-equal 81 (genbrc 'BMI 81 81))
  (assert-equal 81 f)

  ;; both win and lose are the same, destination *not* fall through
  ;; this should be an unconditional branch to win?
  ;; NOT necessarily: return value is continuation
  (assert-equal 100 (genbrc 'BMI 100 100))
  (assert-equal 81 f)

  ;; both win and lose are short branches, but only if "win branch"
  ;; is emitted first [case 6]
  (assert-equal 77 (genbrc 'BNE (+ f 127) (+ f 100)))
  (assert-equal 77 f)
  (assert-equal '[BEQ 102 BNE 127] (subvector *mem* f (+ f 4))))
||#

(deftest compile-cmp-1 (compile-code (seq (l \# 10) (c j 20)))
  ((LDA :IMMEDIATE) (:BYTE 10)
   (CMP :ABSOLUTE-Y) 
   (:ABSOLUTE 20)))

(deftest compile-cmp-1b (compile-code (seq (l \# 10)))
  ((LDA :IMMEDIATE) (:BYTE 10)))

(deftest compile-cmp-1c (compile-code (seq (c j 20)))
  ((CMP :ABSOLUTE-Y) (:ABSOLUTE 20)))

(deftest compile-1b (compile-code (seq))
  ())

(deftest compile-1 (compile-code (seq c=0 v=0 binary decimal enable disable)) 
  ((CLC) (CLV) (CLD) (SED) (CLI) (SEI)))

(deftest compile-2 (compile-code (not (loop (li s) ~=0? pop)))
  ;; clear the stack
  ((TSX) (BEQ) (:BRANCH 5) (PLA) (JMP :ABSOLUTE) (:LONG-BRANCH -5)))

(deftest compile-3 (progn
		     (defparameter *n* 32)  ; address of counter
		     (defparameter *len* 2) ; number of bytes
		     (compile-code (seq (li \# 0)
					c=1     ; initial (+ \# 0) will add 1
					(while c=1?
					  (seq (ci \# (lisp *len*))
					       LLT ; wins if X < #*len* unsign
					       (l i (lisp *n*))
					       (+ \# 0) 
					       (st i (lisp *n*)) 
					       i+1))) 
				   0 -10))
  ((LDX :IMMEDIATE) (:BYTE 0)    ;; [19] 
   (SEC)                 ;; [17]
   (BCC) (:BRANCH 15)    ;; [16] if done incrementing, WIN -> 0
   (CPX :IMMEDIATE) (:BYTE 2)    ;; [14]
   (BCS) (:BRANCH 21)    ;; [12] X>=#*len* means *n* overflowed: LOSE -> 110
   (LDA :ZERO-PAGE-X) (:ZERO-PAGE 32) ;; [10]
   (ADC :IMMEDIATE) (:BYTE 0)    ;; [8]
   (STA :ZERO-PAGE-X) (:ZERO-PAGE 32) ;; [6]
   (INX)                 ;; [4]
   (JMP :ABSOLUTE) (:LONG-BRANCH -14))) ;; [3]

;; same tests as compile-3, but put in a neat extra inversion of the
;; CPX test...comfy takes it!

(deftest compile-3b (progn
		      (defparameter *n* 32)
		      (defparameter *len* 2) ; number of bytes
		      (compile-code (seq (li \# 0)
					 c=1    ; initial (+ \# 0) will add 1
					 (while c=1?
					   (seq (ci \# (lisp *len*))
						(not LGE) ; lose if X >= #*len*
						(l i (lisp *n*))
						(+ \# 0) 
						(st i (lisp *n*))
						i+1))) 
				    0 -10))
  ((LDX :IMMEDIATE) (:BYTE 0)    ;; [19] 
   (SEC)                 ;; [17]
   (BCC) (:BRANCH 15)    ;; [16] if done incrementing, WIN -> 0
   (CPX :IMMEDIATE) (:BYTE 2)    ;; [14]
   (BCS) (:BRANCH 21)    ;; [12] *len*-byte quantity overflowed: LOSE -> -10
   (LDA :ZERO-PAGE-X) (:ZERO-PAGE 32) ;; [10]
   (ADC :IMMEDIATE) (:BYTE 0)    ;; [8]
   (STA :ZERO-PAGE-X) (:ZERO-PAGE 32) ;; [6]
   (INX)                 ;; [4]
   (JMP :ABSOLUTE)       ;; [3]
   (:LONG-BRANCH -14)))  ;; [2] --> BCC

(deftest alt-1 (comfy-macroexpand '(alt (seq <0? (1+ *m*))
					(seq (1- *b*) =0?)))
  (not (seq (not (seq <0? (1+ *m*)))
	    (not (seq (1- *b*) =0?)))))

(deftest compile-4 (progn
		     (defparameter *m* 10)
		     (defparameter *b* 11)
		     (compile-code (alt (seq <0? (1+ (lisp *m*)))
					(seq (1- (lisp *b*)) =0?))
				   -10 -20))
  ((BPL) (:BRANCH 6)                 ; [13] [first ALT clause loses, try second
   (INC :ZERO-PAGE) (:ZERO-PAGE 10)  ; [11] first ALT clause wins, try second
   (JMP :ABSOLUTE)  (:LONG-BRANCH 18) ; [9] WIN->-10 (first alt won...)
   ;; second clause of alt
   (DEC :ZERO-PAGE)  (:ZERO-PAGE 11) ; [6] (1- *b*) 
   (BEQ)             (:BRANCH 13)    ; [4] WIN->0:  second clause won
   (BNE)             (:BRANCH 21)))  ; [2] LOSE->-20: all alt clauses lost 

(deftest fori-1 (progn 
		  (defparameter *code* 11)
		  (compile-code (fori (\# 6) (\# 12) 
				      (l i (lisp *code*))
				      (lxor \# 127)
				      (st i (lisp *code*))) -10 -20))
  ((LDX :IMMEDIATE) (:BYTE 6)     ; [16]
   (CPX :IMMEDIATE) (:BYTE 12)     ; [14] 
   (BCS) (:BRANCH 21)        ; [12] BCS -10 --> win
   (LDA :ZERO-PAGE-X) (:ZERO-PAGE 11) ; [10] (l i *code*)
   (EOR :IMMEDIATE)  (:BYTE 127)     ; [8] (lxor \# 127)
   (STA :ZERO-PAGE-X) (:ZERO-PAGE 11) ; [6] (st i *code*)
   (INX)                     ; [4]
   (JMP :ABSOLUTE) (:LONG-BRANCH -12))) ; [3]

(deftest upc-example 
    (code-result
;;      (defparameter *upctable* 
;;	(compile '(seq 13 25 19 61 35 49 47 59 55 11) 0 0))
      (equ code 13)  ; buffer 13..25
      (equ mq   12)
      (equ digit 26) ; buffer 26..39
      (comfy-6502:compile  
       '(alt
	 (seq (fori (\# 6) (\# 12) ; complement patterns of right 6 upc digits.
	       (l i code)
	       (lxor \# 127)
	       (st i code))
	  (fori (\# 0) (\# 12)
	   (l i code)
	   (not
	    (forj (\# 0) (\# 10)
		  (c j upc-table)
		  ~=?))             ; fail if equal.
	   (stj i digit))            ; store index of upctable.
	  decimal                         ; set decimal arithmetic mode.
	  (l \# 0)                        ; clear ac.
	  (fori (\# 0) (\# 12)            ; add up the even digits.
	   (+ i digit)               ; loop control clears carry!
	   i+1)                      ; only every other one.
	  (st mq)                         ; save partial sum.
	  c=0                             ; clear the carry.
	  (2 (+ mq))                      ; multiply by 3.
	  (fori (\# 1) (\# 12)            ; add up the odd digits.
	   (+ i digit)               ; loop control clears carry.
	   i+1)                      ; only every other one.
	  (lxor \# 15)                    ; select low decimal digit.
	  =0?                            ; fails if non-zero.
	  return)
	 (seq trap                          ; signal failure.
	  return)) -10 -20))
  ((LDX :IMMEDIATE) (:byte 6)              ;  [2] (fori (\# 6)
   (CPX :IMMEDIATE) (:byte 12)             ;  [4]       (\# 12) ...
   (BCS) (:BRANCH 11)              ;  [6] --> [18] seq2
   (LDA :ZERO-PAGE-X) (:ZERO-PAGE 13) ;  [8]
   (EOR :IMMEDIATE) (:byte 127)            ; [10]
   (STA :ZERO-PAGE-X) (:ZERO-PAGE 13)          ; [12]
   (INX)                           ; [14]
   (JMP :ABSOLUTE) (:LONG-BRANCH -12)  ; [15] -> CPX #12
   (LDX :IMMEDIATE) (:byte 0)              ; [18] seq2: (fori (\# 0) 
   (CPX :IMMEDIATE) (:byte 12)             ; [20]             (\# 12) ...
   (BCS) (:BRANCH 24)              ; [22] --> [47] seq3
   (LDA :ZERO-PAGE-X) (:ZERO-PAGE 13) ; [24]
   (LDY :IMMEDIATE) (:byte 0)              ; [26] (forj (\# 0)
   (CPY :IMMEDIATE) (:byte 10)             ; [28]       (\# 10)
   (BCS) (:BRANCH 57)                        ; [30] --> [88] FAIL
   (CMP :ABSOLUTE-Y) (:ABSOLUTE UPC-TABLE)  ; [32]
   (BEQ) (:BRANCH 5)               ; [35] --> [41] seq3b
   (INY)                           ; [37]
   (JMP :ABSOLUTE) (:LONG-BRANCH -11) ; [38] --> CPY #10
   (STY :ZERO-PAGE-X) (:ZERO-PAGE 26) ; [41]
   (INX)                           ; [43]
   (JMP :ABSOLUTE) (:LONG-BRANCH -25)    ; [44] --> CPX #12
   (SED)                           ; [47] seq3: decimal
   (LDA :IMMEDIATE) (:byte 0)              ; [48]
   (LDX :IMMEDIATE) (:byte 0)              ; [50] (fori (\# 0) 
   (CPX :IMMEDIATE) (:byte 12)             ; [52]       (\# 12) ...
   (BCS) (:BRANCH 8)                         ; [54] --> seq4 [63]
   (ADC :ZERO-PAGE-X) (:ZERO-PAGE 26) ; [56]
   (INX)                           ; [58]
   (INX)                           ; [59]
   (JMP :ABSOLUTE) (:LONG-BRANCH -9) ; [60] --> CPX #12
   (STA :ZERO-PAGE) (:ZERO-PAGE 12)  ; [63] seq4: (st *mq*)
   (CLC)                           ; [65]
   (ADC :ZERO-PAGE) (:ZERO-PAGE 12)            ; [66]
   (ADC :ZERO-PAGE) (:ZERO-PAGE 12)            ; [68]
   (LDX :IMMEDIATE) (:byte 1)              ; [70] (fori (\# 1)
   (CPX :IMMEDIATE) (:byte 12)             ; [72]       (\# 12) ...
   (BCS) (:BRANCH 8)               ; [74] --> seq5: [83]
   (ADC :ZERO-PAGE-X) (:ZERO-PAGE 26) ; [76]
   (INX)                           ; [78]
   (INX)                           ; [79]
   (JMP :ABSOLUTE) (:LONG-BRANCH -9); [80] -> CPX #12
   (EOR :IMMEDIATE) (:byte 15)             ; [83] seq5: (lxor \# 15)
   (BNE) (:BRANCH 2)                         ; [85] -> TRAP at 88
   (RTS)                           ; [87]
   (BRK)                           ; [88]
   (RTS)))                         ; [89]


;;; Test pattern-matching macros similar to Baker's

(deftest match-1 
    (comfy-6502::match '(move ?x ?y) '(move foo bar))
  T ((?x . foo) (?y . bar)))

(deftest match-2 
    (comfy-6502::match '(a b ?c) '(a b foo))
  T ((?c . foo)))

(deftest match-3
    (comfy-6502::match '(a b ?c) '(a b foo bar))
  nil nil)

(deftest match-4
    (comfy-6502::match '(a b . ?c) '(a b foo))
  t ((?c . (foo))))

(deftest match-5
    (comfy-6502::match '(a b . ?c) '(a b))
  t ((?c . nil)))

(deftest match-6
    (comfy-6502::match '(a b . ?c) '(a b foo bar))
  t ((?c . (foo bar))))

(deftest match-7
    (comfy-6502::match '(a ?v1 ?v2) '(a b c))
  t ((?v1 . b) (?v2 . c)))

(deftest match-8
    (comfy-6502::match '(a (?v1 . ?v2)) '(a (b . c)))
  t ((?v1 . b) (?v2 . c)))

(deftest match-9 
    (comfy-6502::match '(a (?v1 . ?v2)) '(a (b c d)))
  t ((?v1 . b) (?v2 . (c d))))
   
(deftest match-10
    (comfy-6502::match '(a (quote b) (:in evenp)) '(a b 6))
  T nil)

;; extension to allow capturing the value of tested variables
(deftest match-11
    (comfy-6502::match '(a (quote b) (:in evenp ?c)) '(a b 6))
  T ((?c . 6)))

(deftest match-12
    (comfy-6502::match '(a (quote b) (:in evenp ?c)) '(a b 7))
  nil nil)

;;; problematic...

(deftest match-13
    (comfy-6502::match '(a ?v1 ?v1) '(a b c))
  T ((?v1 . b) (?v1 . c)))

(deftest move-macro-1
    (comfy-macroexpand '(move (x) (y)))
  (seq (l x) (st y)))

(deftest move-macro-2
    (comfy-macroexpand '(move (i@ x) (@j y)))
  (seq (l i@ x) (st @j y)))

(deftest macro-1
    (progn
      (define-cmacro mac1
	((mac1 ?x ?y) (list ?y ?x)))
      (comfy-macroexpand '(mac1 a b)))
  (b a))

(deftest macro-2
    (progn
      (define-cmacro mac1
	((mac1 ?x ?y) (list ?y ?x)))
      (comfy-macroexpand '(mac1 (a c d) b)))
  (b (a c d)))

;;; define in one order [note: my define-cmacro has the reverse
;;; precedence from Baker's elisp implementation: the clauses are 
;;; matched sequentially, preferring the earlier clauses to laters.
;;; This matches Baker only if the (define cmacro ...) forms are 
;;; executed in the reverse order of the corresponding clauses, as
;;; (define cmacro ...) adds a new matcher to the beginning of the
;;; expander function.

(deftest macro-3
    (progn
      (define-cmacro mac2
	((mac2 ?x) (list 'match1 ?x))
	((mac2 ?x ?y) (list 'match2 ?x ?y))
	((mac2 ?x ?y . ?z) (list 'match3 ?x ?y ?z)))
      (list
       (comfy-macroexpand '(mac2 a))
       (comfy-macroexpand '(mac2 a b))
       (comfy-macroexpand '(mac2 a b c))))
  ((match1 a) (match2 a b) (match3 a b (c))))

(deftest macro-4
    (progn
      (define-cmacro mac2
	((mac2 ?x) (list 'match1 ?x))
	((mac2 ?x ?y . ?z) (list 'match3 ?x ?y ?z))
	((mac2 ?x ?y) (list 'match2 ?x ?y)))
      (list
       (comfy-macroexpand '(mac2 a))
       (comfy-macroexpand '(mac2 a b))
       (comfy-macroexpand '(mac2 a b c))))
  ((match1 a) (match3 a b nil) (match3 a b (c))))

(deftest symbol-macro-1
    (progn
      (define-cmacro fake-rr
	  (fake-rr '(7 rl))
	((fake-rr . ?x) (list 7 (cons 'rl ?x))))
      (list
       (comfy-macroexpand 'fake-rr)
       (comfy-macroexpand '(fake-rr loc))
       (comfy-macroexpand '(fake-rr i@ loc))))
  ((7 rl)
   (7 (rl loc))
   (7 (rl i@ loc))))

(deftest repeat-1
    (compile-code (3 (1+ 100)))
  ((INC :ZERO-PAGE) (:ZERO-PAGE 100) 
   (INC :ZERO-PAGE) (:ZERO-PAGE 100) 
   (INC :ZERO-PAGE) (:ZERO-PAGE 100)))

(deftest repeat-2
    (compile-code (3 rl))
  ((ROL) (ROL) (ROL)))

(deftest repeat-3
    (compile-code (3 (rl (:zero-page loc))))
  ((ROL :ZERO-PAGE) (:ZERO-PAGE LOC)
   (ROL :ZERO-PAGE) (:ZERO-PAGE LOC)
   (ROL :ZERO-PAGE) (:ZERO-PAGE LOC)))

(deftest rl-1 
    (compile-code (rl i@ (:zero-page loc)))
  ((ROL :ZP-X-INDIRECT) (:ZERO-PAGE LOC)))

(deftest repeat-4
    (compile-code (3 (rl i@ (:zero-page loc))))
  ((ROL :ZP-X-INDIRECT) (:ZERO-PAGE LOC)
   (ROL :ZP-X-INDIRECT) (:ZERO-PAGE LOC)
   (ROL :ZP-X-INDIRECT) (:ZERO-PAGE LOC)))

(deftest symbol-macro-2
    (progn
      (define-cmacro fake-rr
	  (fake-rr '(7 rl))
	((fake-rr . ?x) (list 7 (cons 'rl ?x))))
      (compile-code (seq fake-rr (fake-rr (:absolute loc)) 
			 (fake-rr i@ (:zero-page loc)))))
  ((ROL) (ROL) (ROL) (ROL) (ROL) (ROL) (ROL)
   (ROL :ABSOLUTE) (:ABSOLUTE LOC)
   (ROL :ABSOLUTE) (:ABSOLUTE LOC)
   (ROL :ABSOLUTE) (:ABSOLUTE LOC)
   (ROL :ABSOLUTE) (:ABSOLUTE LOC)
   (ROL :ABSOLUTE) (:ABSOLUTE LOC)
   (ROL :ABSOLUTE) (:ABSOLUTE LOC)
   (ROL :ABSOLUTE) (:ABSOLUTE LOC)
   (ROL :ZP-X-INDIRECT) (:ZERO-PAGE LOC)
   (ROL :ZP-X-INDIRECT) (:ZERO-PAGE LOC)
   (ROL :ZP-X-INDIRECT) (:ZERO-PAGE LOC)
   (ROL :ZP-X-INDIRECT) (:ZERO-PAGE LOC)
   (ROL :ZP-X-INDIRECT) (:ZERO-PAGE LOC)
   (ROL :ZP-X-INDIRECT) (:ZERO-PAGE LOC)
   (ROL :ZP-X-INDIRECT) (:ZERO-PAGE LOC)))

(deftest equ-1 
    (let ((comfy-6502::*symbol-table* (make-hash-table)))
      (equ n 32)
      (equ len 2)
      (compile-code (seq (ci \# len))))
  ((CPX :IMMEDIATE) (:byte 2)))

(deftest zp-1 
    (compile-code (l i 32))
  ((LDA :ZERO-PAGE-X) (:ZERO-PAGE 32)))

(deftest abs-1
    (compile-code (l i 256))
  ((LDA :ABSOLUTE-X) (:ABSOLUTE 256)))

(deftest lisp-1
	 (progn 
	   (defparameter *len* 2)
	   (compile-code (seq (ci \# (lisp *len*)))))
  ((CPX :IMMEDIATE) (:byte 2)))

(deftest equ-2
    (let ((comfy-6502::*symbol-table* (make-hash-table)))
      (equ n 32)
      (equ len 2)
      (compile-code (seq (l i n))))
  ((LDA :ZERO-PAGE-X) (:ZERO-PAGE 32)))

(deftest lisp-2
	 (progn 
	   (defparameter *n* 32)
	   (compile-code (seq (l i (lisp *n*)))))
  ((LDA :ZERO-PAGE-X) (:ZERO-PAGE 32)))

(deftest equ-3
    (let ((comfy-6502::*symbol-table* (make-hash-table)))
      (equ n 32)
      (equ len 2)
      (compile-code (seq (st i n))))
  ((STA :ZERO-PAGE-X) (:ZERO-PAGE 32)))

(deftest lisp-3
	 (progn 
	   (defparameter *n* 32)
	   (compile-code (seq (st i (lisp *n*)))))
  ((STA :ZERO-PAGE-X) (:ZERO-PAGE 32)))

(deftest compile-3-equ 
	(let ((comfy-6502::*symbol-table* (make-hash-table)))		 
	  (equ n 32)  ; address of counter
	  (equ len 2) ; number of bytes
	  (compile-code 
	    (seq (li \# 0)
		 c=1     ; initial (+ \# 0) will add 1
		 (while c=1?
			(seq (ci \# len)
			     LLT ; wins if X < #*len* unsign
			     (l i n) 
			     (+ \# 0) 
			     (st i n) 
			     i+1))) 
	    0 -10))
  ((LDX :IMMEDIATE) (:byte 0)    ;; [19] 
   (SEC)                 ;; [17]
   (BCC) (:BRANCH 15)    ;; [16] if done incrementing, WIN -> 0
   (CPX :IMMEDIATE) (:byte 2)    ;; [14]
   (BCS) (:BRANCH 21)    ;; [12] X>=#*len* means *n* overflowed: LOSE -> 110
   (LDA :ZERO-PAGE-X) (:ZERO-PAGE 32) ;; [10]
   (ADC :IMMEDIATE) (:byte 0)    ;; [8]
   (STA :ZERO-PAGE-X) (:ZERO-PAGE 32) ;; [6]
   (INX)                 ;; [4]
   (JMP :ABSOLUTE) (:LONG-BRANCH -14))) ;; [3]

;;; tests for "declaration" behavior: allow a value ':ZERO-PAGE or '(:ZERO-PAGE) or
;;; '(:ZERO-PAGE NIL) to emit a (:ZERO-PAGE <symbol>) address

(deftest zp-assert-1
    (compile-code (l i (:zero-page n)))
  ((LDA :ZERO-PAGE-X) (:ZERO-PAGE N)))

(deftest declare-1
    (let ((comfy-6502::*symbol-table* (make-hash-table)))
      (equ n :zero-page)
      (compile-code (seq (l i n))))
  ((LDA :ZERO-PAGE-X) (:ZERO-PAGE N)))

;;; test for catching various errors

(deftest zp-error-1
    (compile-code (l i 256))
  ((LDA :ABSOLUTE-X) (:ABSOLUTE 256)))

(deftest bad-if-1
    (multiple-value-bind (success error)
	(ignore-errors (compile-code (if =0?)))
      (list success (eq (class-of error) (find-class 'if-error))
	    (problem error)))
  (nil t "lacking win-form"))

(deftest bad-if-2
    (multiple-value-bind (success error)
	(ignore-errors (compile-code (if =0? return)))
      (list success (eq (class-of error) (find-class 'if-error))
	    (problem error)))
  (nil t "lacking lose-form"))

(deftest bad-if-3
    (multiple-value-bind (success error)
	(ignore-errors (compile-code (if)))
      (list success (eq (class-of error) (find-class 'if-error))
	    (problem error)))
  (nil t "lacking win-form"))

(deftest bad-if-4
    (multiple-value-bind (success error)
	(ignore-errors (compile-code (if test then else extra)))
      (list success (eq (class-of error) (find-class 'if-error))
	    (problem error)))
  (nil t "too many forms"))

(deftest bad-while-1
    (multiple-value-bind (success error)
	(ignore-errors (compile-code (while =0?)))
      (list success (eq (class-of error) (find-class 'while-error))
	    (problem error)))
  (nil t "lacking win-form"))

(deftest bad-while-2
    (multiple-value-bind (success error)
	(ignore-errors (compile-code (while)))
      (list success (eq (class-of error) (find-class 'while-error))
	    (problem error)))
  (nil t "lacking test-form"))

(deftest bad-while-3
    (multiple-value-bind (success error)
	(ignore-errors (compile-code (while a b c)))
      (list success (eq (class-of error) (find-class 'while-error))
	    (problem error)))
  (nil t "too many forms"))

(deftest bad-opcode-1
    (multiple-value-bind (success error)
	(ignore-errors (compile-code (if bogus-test? return
					 (1- 100))))
      (list success (eq (class-of error) (find-class 'opcode-error))
	    (problem error)))
  (nil t "not an implied opcode"))

(deftest bad-accum-1
    (multiple-value-bind (success error)
	(ignore-errors (compile-code (1+ a)))
      (list success (eq (class-of error) (find-class 'opcode-error))
	    (problem error)))
  (nil t "does not support ACCUMULATOR mode"))

(deftest bad-implied-1
    (multiple-value-bind (success error)
	(ignore-errors (compile-code INC))
      (list success (eq (class-of error) (find-class 'opcode-error))
	    (problem error)))
  (nil t "does not support IMPLIED mode"))


;;; example of Apple II "Red Book" tone routine.

(deftest redbook-tone
    (let ((comfy-6502::*symbol-table* (make-hash-table))
	  (comfy-6502::*optimize-loop-branches* nil))
      (equ speaker #xc030)
      (equ duration 1)
      (equ pitch 0)
      (comfy-6502-tests::compile-code
       (comfy-6502:loop 
	;; repeat until some clause loses: actually, only exit is
	;; through return, so each clause should be ensured of winning.
	(li pitch)
	(l speaker)
	(not (comfy-6502:loop  ;; repeat until whap time (pitch counter expires)
	      j-1
	      (if =0? ; duration tick finished?
		  (not (seq (1- duration) ; yes, count down duration
			    =0? ;; duration expired? 
			    ;; (failure skips return but seq protected by
			    ;; NOT to avoid exiting and WHAPping)
			    return))
		  (seq i-1 ~=0?))))))) ; no, continue counting pitch
  (; reload-pitch
   (LDX :ZERO-PAGE) (:ZERO-PAGE 0) 
   (LDA :ABSOLUTE) (:ABSOLUTE 49200) 
   ;; spin
   (DEY) 
   (BEQ) (:BRANCH 6) ; duration-tick
   (DEX) 
   (BNE) (:BRANCH 8) ; goto spin
   (BEQ) (:BRANCH 9) ; goto reload-pitch
   ;; duration-tick
   (DEC :ZERO-PAGE) (:ZERO-PAGE 1) 
   (BNE) (:BRANCH 2) ; goto-spin
   (RTS) 
   ;; goto spin
   (JMP :ABSOLUTE) (:LONG-BRANCH -14) 
   ;; goto reload-pitch
   (JMP :ABSOLUTE) (:LONG-BRANCH -22)))

;; with optimizations enabled

(deftest redbook-tone-opt-branches
    ;; redirect branches, but leave redundant JMPs
    (let ((comfy-6502::*symbol-table* (make-hash-table))
	  (comfy-6502::*excise-loop-jump* nil))
      (equ speaker #xc030)
      (equ duration 1)
      (equ pitch 0)
      (comfy-6502-tests::compile-code
       (comfy-6502:loop 
	;; repeat until some clause loses: actually, only exit is
	;; through return, so each clause should be ensured of winning.
	(li pitch)
	(l speaker)
	(not (comfy-6502:loop  ;; repeat until whap time (pitch counter expires)
	      j-1
	      (if =0? ; duration tick finished?
		  (not (seq (1- duration) ; yes, count down duration
			    =0? ;; duration expired? 
			    ;; (failure skips return but seq protected by
			    ;; NOT to avoid exiting and WHAPping)
			    return))
		  (seq i-1 ~=0?))))))) ; no, continue counting pitch
  (; reload-pitch
   (LDX :ZERO-PAGE) (:ZERO-PAGE 0) 
   (LDA :ABSOLUTE) (:ABSOLUTE 49200) 
   ;; spin
   (DEY) 
   (BEQ) (:BRANCH 6) ; duration-tick
   (DEX) 
   (BNE) (:BRANCH -5) ; SHORTENED spin
   (BEQ) (:BRANCH -12) ; SHORTENED reload-pitch
   ;; duration-tick
   (DEC :ZERO-PAGE) (:ZERO-PAGE 1) 
   (BNE) (:BRANCH -11) ; SHORTENED spin
   (RTS) 
   ;; goto spin
   (JMP :ABSOLUTE) (:LONG-BRANCH -14) ;; EXCISEABLE 
   ;; goto reload-pitch
   (JMP :ABSOLUTE) (:LONG-BRANCH -22))) ;; EXCISEABLE

(deftest redbook-tone-opt ; "full" optimizations
    ;; expected to fail under comfy-6502.lisp 1.9
    (let ((comfy-6502::*symbol-table* (make-hash-table)))
      (equ speaker #xc030)
      (equ duration 1)
      (equ pitch 0)
      (comfy-6502-tests::compile-code
       (comfy-6502:loop 
	;; repeat until some clause loses: actually, only exit is
	;; through return, so each clause should be ensured of winning.
	(li pitch)
	(l speaker)
	(not (comfy-6502:loop  ;; repeat until whap time (pitch counter expires)
	      j-1
	      (if =0? ; duration tick finished?
		  (not (seq (1- duration) ; yes, count down duration
			    =0? ;; duration expired? 
			    ;; (failure skips return but seq protected by
			    ;; NOT to avoid exiting and WHAPping)
			    return))
		  (seq i-1 ~=0?))))))) ; no, continue counting pitch
  (; reload-pitch
   (LDX :ZERO-PAGE) (:ZERO-PAGE 0) 
   (LDA :ABSOLUTE) (:ABSOLUTE 49200) 
   ;; spin
   (DEY) 
   (BEQ) (:BRANCH 6) ; duration-tick
   (DEX) 
   (BNE) (:BRANCH -5) ; SHORTENED spin
   (BEQ) (:BRANCH -12) ; SHORTENED reload-pitch
   ;; duration-tick
   (DEC :ZERO-PAGE) (:ZERO-PAGE 1) 
   (BNE) (:BRANCH -11) ; SHORTENED spin
   (RTS)))  ;; without JMP elimination, there are redundant
;; (JMP :ABSOLUTE) (:LONG-BRANCH -14)
;; (JMP :ABSOLUTE) (:LONG-BRANCH -22)

;; that one actually disagrees with the logic of the original
;;

(deftest redbook-tone-2
    (let ((comfy-6502::*symbol-table* (make-hash-table))
	  (comfy-6502::*optimize-loop-branches* nil))
      (equ speaker #xc030)
      (equ duration 1)
      (equ pitch 0)
      (comfy-6502-tests::compile-code
       (alt (loop (seq (li pitch) (l speaker)) 
	       (not (while 
			(seq j-1 (not (seq =0? (1- duration) =0?)))
		      (seq i-1 (not =0?)))))
	    return)))
  (; reload
    (LDX :ZERO-PAGE) (:ZERO-PAGE 0) 
    (LDA :ABSOLUTE) (:ABSOLUTE 49200) 
    ; spin
    (DEY) 
    (BNE) (:BRANCH 5) ; not-duration
    ; duration-tick
    (DEC :ZERO-PAGE) (:ZERO-PAGE 1) 
    (BEQ) (:BRANCH 10) ; exit
    ; not-duration
    (DEX) 
    (BEQ) (:BRANCH 4) ; goto-reload
    ; goto-spin
    (JMP :ABSOLUTE) (:LONG-BRANCH -11) 
    ; goto-reload
    (JMP :ABSOLUTE) (:LONG-BRANCH -19) ; reload
    ; exit
    (RTS)))

(deftest redbook-tone-2-opt
    (let ((comfy-6502::*symbol-table* (make-hash-table)))
      (equ speaker #xc030)
      (equ duration 1)
      (equ pitch 0)
      (comfy-6502-tests::compile-code
       (alt (loop (seq (li pitch) (l speaker)) 
	       (not (while 
			(seq j-1 (not (seq =0? (1- duration) =0?)))
		      (seq i-1 (not =0?)))))
	    return)))
  (; reload
    (LDX :ZERO-PAGE) (:ZERO-PAGE 0) 
    (LDA :ABSOLUTE) (:ABSOLUTE 49200) 
    ; spin
    (DEY) 
    (BNE) (:BRANCH 5) ; not-duration
    ; duration-tick
    (DEC :ZERO-PAGE) (:ZERO-PAGE 1) 
    (BEQ) (:BRANCH 10) ; exit
    ; not-duration
    (DEX) 
    (BEQ) (:BRANCH -14) ; SHORTENED reload
    ; goto-spin
    (JMP :ABSOLUTE) (:LONG-BRANCH -11) 
    ; goto-reload
    (JMP :ABSOLUTE) (:LONG-BRANCH -19) ; reload
    ; exit
    (RTS)))
      

;;; test "conventional" aliases: 6502 instruction names

;; cf. compile-1
(deftest alias-1 (compile-code (seq CLC CLV CLD SED CLI SEI)) 
  ((CLC) (CLV) (CLD) (SED) (CLI) (SEI)))

;; cf. compile-2
(deftest alias-2 (compile-code (not (loop TSX (not zero?) PLA)))
  ;; clear the stack
  ((TSX) (BEQ) (:BRANCH 5) (PLA) (JMP :ABSOLUTE) (:LONG-BRANCH -5)))

;; cf. compile-3
(deftest alias-3 (progn
		   (defparameter *n* 32)  ; address of counter
		   (defparameter *len* 2) ; number of bytes
		   (compile-code (seq (LDX \# 0)
				      SEC     ; initial (ADC \# 0) will add 1
				      (while carry?
					(seq (CPX \# (lisp *len*))
					     LLT ; wins if X < #*len* unsign
					     (LDA X (lisp *n*))
					     (ADC \# 0) 
					     (STA X (lisp *n*)) 
					     INX))) 
				 0 -10))
  ((LDX :IMMEDIATE) (:BYTE 0)    ;; [19] 
   (SEC)                 ;; [17]
   (BCC) (:BRANCH 15)    ;; [16] if done incrementing, WIN -> 0
   (CPX :IMMEDIATE) (:BYTE 2)    ;; [14]
   (BCS) (:BRANCH 21)    ;; [12] X>=#*len* means *n* overflowed: LOSE -> 110
   (LDA :ZERO-PAGE-X) (:ZERO-PAGE 32) ;; [10]
   (ADC :IMMEDIATE) (:BYTE 0)    ;; [8]
   (STA :ZERO-PAGE-X) (:ZERO-PAGE 32) ;; [6]
   (INX)                 ;; [4]
   (JMP :ABSOLUTE) (:LONG-BRANCH -14))) ;; [3]

;; cf. redbook-tone-2
(deftest redbook-2-alias
    (let ((comfy-6502::*symbol-table* (make-hash-table))
	  (comfy-6502::*optimize-loop-branches* nil))
      (equ speaker #xc030)
      (equ duration 1)
      (equ pitch 0)
      (comfy-6502-tests::compile-code
       (alt (loop (seq (LDX pitch) (LDA speaker)) 
	       (not (while 
			(seq DEY (not (seq zero? (DEC duration) zero?)))
		      (seq DEX (not zero?)))))
	    RTS)))
  (; reload
    (LDX :ZERO-PAGE) (:ZERO-PAGE 0) 
    (LDA :ABSOLUTE) (:ABSOLUTE 49200) 
    ; spin
    (DEY) 
    (BNE) (:BRANCH 5) ; not-duration
    ; duration-tick
    (DEC :ZERO-PAGE) (:ZERO-PAGE 1) 
    (BEQ) (:BRANCH 10) ; exit
    ; not-duration
    (DEX) 
    (BEQ) (:BRANCH 4) ; goto-reload
    ; goto-spin
    (JMP :ABSOLUTE) (:LONG-BRANCH -11) 
    ; goto-reload
    (JMP :ABSOLUTE) (:LONG-BRANCH -19) ; reload
    ; exit
    (RTS)))

(deftest redbook-2-alias-opt
    (let ((comfy-6502::*symbol-table* (make-hash-table)))
      (equ speaker #xc030)
      (equ duration 1)
      (equ pitch 0)
      (comfy-6502-tests::compile-code
       (alt (loop (seq (LDX pitch) (LDA speaker)) 
	       (not (while 
			(seq DEY (not (seq zero? (DEC duration) zero?)))
		      (seq DEX (not zero?)))))
	    RTS)))
  (; reload
    (LDX :ZERO-PAGE) (:ZERO-PAGE 0) 
    (LDA :ABSOLUTE) (:ABSOLUTE 49200) 
    ; spin
    (DEY) 
    (BNE) (:BRANCH 5) ; not-duration
    ; duration-tick
    (DEC :ZERO-PAGE) (:ZERO-PAGE 1) 
    (BEQ) (:BRANCH 10) ; exit
    ; not-duration
    (DEX) 
    (BEQ) (:BRANCH -14) ; SHORTENED reload
    ; goto-spin
    (JMP :ABSOLUTE) (:LONG-BRANCH -11) 
    ; goto-reload
    (JMP :ABSOLUTE) (:LONG-BRANCH -19) ; reload
    ; exit
    (RTS)))

;; cf. zp-1
(deftest alias-4
    (compile-code (LDA X 32))
  ((LDA :ZERO-PAGE-X) (:ZERO-PAGE 32)))

;; cf. equ-1
(deftest alias-5
    (let ((comfy-6502::*symbol-table* (make-hash-table)))
      (equ n 32)
      (equ len 2)
      (compile-code (CPX \# len)))
  ((CPX :IMMEDIATE) (:byte 2)))

;; cf. equ-3
(deftest alias-6
    (let ((comfy-6502::*symbol-table* (make-hash-table)))
      (equ n 32)
      (equ len 2)
      (compile-code (STA X n)))
  ((STA :ZERO-PAGE-X) (:ZERO-PAGE 32)))

;; cf. repeat-1
(deftest alias-7
    (compile-code (2 (INC 100)))
  ((INC :ZERO-PAGE) (:ZERO-PAGE 100) 
   (INC :ZERO-PAGE) (:ZERO-PAGE 100)))

;; cf. repeat-2
(deftest alias-8 
    (compile-code (3 ROL))
  ((ROL) (ROL) (ROL)))

;; cf rl-1
(deftest alias-9
    (compile-code (ROL X@ (:zero-page loc)))
  ((ROL :ZP-X-INDIRECT) (:ZERO-PAGE LOC)))

;;; try out some of the example macros that need address math

(deftest i2-1
    (compile-code (comfy-6502::i2 99))
  ((INC :ZERO-PAGE) (:ZERO-PAGE 99) 
   (BNE) (:BRANCH 3) 
   (INC :ZERO-PAGE) (:ZERO-PAGE 100)))

(deftest i2-2
    (compile-code (comfy-6502::i2 255))
  ((INC :ZERO-PAGE) (:ZERO-PAGE 255) 
   (BNE) (:BRANCH 4) 
   (INC :ABSOLUTE) (:ABSOLUTE 256)))

(deftest i2-3
    (compile-code (comfy-6502::i2 1000))
  ((INC :ABSOLUTE) (:ABSOLUTE 1000) 
   (BNE) (:BRANCH 4) 
   (INC :ABSOLUTE) (:ABSOLUTE 1001)))

;;; not sure if I like this behavior.
(deftest i2-4
    (compile-code (comfy-6502::i2 -1))
  ((INC :ABSOLUTE) (:ABSOLUTE -1) 
   (BNE) (:BRANCH 3) 
   (INC :ZERO-PAGE) (:ZERO-PAGE 0)))

#|| ; doesn't work yet
(deftest i2-5
    (compile-code (comfy-6502::i2 (:ABSOLUTE x)))
  ((INC :ABSOLUTE) (:ABSOLUTE X) 
   (BNE) (:BRANCH 4) 
   (INC :ABSOLUTE) (:ABSOLUTE (1+ (:ABSOLUTE X))))) ; or something like this.
||#

;; some aliases not used in Baker's examples, but that work with
;; his original code.
;; (li a) -> 170 decimal = TAX, (sti a) -> 138 decimal = TXA
;; (lj a) -> 168 decimal = TAY, (stj a) -> 152 decimal = TYA
;; 

(deftest alias-accum
    (compile-code (seq (li a) (sti a) (lj a) (stj a)
		       (LDX A) (STX A) (LDY A) (STY A)))
  ((TAX) (TXA) (TAY) (TYA) (TAX) (TXA) (TAY) (TYA)))

(deftest null-loop ; make sure optimizer doesn't choke on this.
    (compile-code (loop))
  ((JMP :ABSOLUTE) (:LONG-BRANCH -1)))