;;      (implicit )
;;      (accumulator )
;;      (immediate )
;;      (zeropage )
;;      (zeropage-x )
;;      (zeropage-y )
;;      (relative )
;;      (absolute )
;;      (absolute-x )
;;      (absolute-y )
;;      (indirect )
;;      (indexed-indirect )
;;      (indirect-indexed )

(defun! 6502/ensure-u8 (x)
  (if (and (>= x 0) (<= x 0xff))
    (list x)
    (error! "operand out of range")))

(defun! 6502/ensure-i8 (x)
  (cond 
    ((and (>= x 0) (<= x 127)) (list x))
    ((and (>= x -128) (< x 0)) (list (+ 0xff x)))
    (error! "operand out of range")))

(defun! 6502/ensure-u16 (x)
  (if (and (>= (car x) 0) (<= (car x) 0xffff))
    (list (bitwise/and 0xff x) (bitwise/and 0xff (bitwise/rshift x 8)))
    (error! "operand out of range")))

(defun! 6502/identify-operand (x)
  (cond
    ((equal? x nil) (cons 'implicit nil)) ;; (<op> )
    ((equal? x '(a)) (cons 'accumulator nil)) ;; (<op> a)
    ((integer? (car x)) (cons 'immediate (6502/ensure-u8 (car x)))) ;; (<op> 0x0f)
    ((equal? (caar x) 'zeropage) ;; (<op> (zeropage 0x0f x))
      (let ((zp (car x)))
        (let ((a (6502/ensure-u8 (cadr zp))))
          (case (caddr zp)
            (x (cons 'zeropage-x a))
            (y (cons 'zeropage-y a))
            (nil (cons 'zeropage a))
            (t (error! "unknown zeropage offset register"))))))
    ((equal? (caar x) 'relative) ;; (<op> (relative 0x0f))
      (cons 'relative (6502/ensure-i8 (cadar x))))
    ((equal? (caar x) 'absolute) ;; (<op> (absolute 0x0f x))
      (let ((ab (car x)))
        (let ((a (6502/ensure-u16 (cadr ab))))
          (case (caddr ab)
            (x (cons 'absolute-x a))
            (y (cons 'absolute-y a))
            (nil (cons 'absolute a))
            (t (error! "unknown absolute offset register"))))))
    ((equal? (caar x) 'indirect)
      (cons 'indirect (6502/ensure-u16 (cadar x))))
    ((and (equal? (caar x) 'indexed-indirect) (equal? (caddar x) 'x))
      (cons 'indexed-indirect (6502/ensure-u16 (cadar x))))
    ((and (equal? (caar x) 'indirect-indexed) (equal? (caddar x) 'y))
      (cons 'indexed-indirect (6502/ensure-u16 (cadar y))))
    (t (error! "unknown operand"))))

(defun! 6502/single (op)
  (case op
    ;; conditional branches
    (bpl 0x10)
    (bmi 0x30)
    (bvc 0x50)
    (bvs 0x70)
    (bcc 0x90)
    (bcs 0xb0)
    (bne 0xd0)
    (beq 0xf0)
    ;; other instructions
    (brk 0x00)
    (jsr 0x20)
    (rti 0x40)
    (rts 0x60)
    ;; other single-byte instructions
    (php 0x08)
    (clc 0x18)
    (plp 0x28)
    (sec 0x38)
    (pha 0x48)
    (cli 0x58)
    (pla 0x68)
    (sei 0x78)
    (dey 0x88)
    (tya 0x98)
    (tay 0xa8)
    (clv 0xb8)
    (iny 0xc8)
    (cld 0xd8)
    (inx 0xe8)
    (sed 0xf8)
    (txa 0x8a)
    (txs 0x9a)
    (tax 0xaa)
    (tsx 0xba)
    (dex 0xca)
    (nop 0xea)
    (t (error! "invalid single-byte instruction"))))

(defun! 6502/grouped (group opbits amodebits)
  (bitwise/or
    (bitwise/lshift (bitwise/and 0b111 opbits) 5)
    (bitwise/lshift (bitwise/and 0b111 amodebits) 2)
    group))

(defun! 6502/group1 (op amode)
  (6502/grouped 0b01
    (case op
      (ora 0b000)
      (and 0b001)
      (eor 0b010)
      (adc 0b011)
      (sta 0b100)
      (lda 0b101)
      (cmp 0b110)
      (sbc 0b111)
      (t (error! "invalid group 1 opcode")))
    (case amode
      (indexed-indirect 0b000)
      (zeropage 0b001)
      (immediate 0b010)
      (absolute 0b011)
      (indirect-indexed 0b100)
      (zeropage-x 0b101)
      (absolute-y 0b110)
      (absolute-x 0b111)
      (t (error! "invalid addressing mode for group 1")))))

(defun! 6502/group2 (op amode)
  (6502/grouped 0b10
    (case op
      (asl 0b000)
      (rol 0b001)
      (lsr 0b010)
      (ror 0b011)
      (stx 0b100)
      (ldx 0b101)
      (dec 0b110)
      (inc 0b111)
      (t (error! "invalid group 2 opcode")))
    (cond
      ((and (or (equal? op 'stx) (equal? op 'ldx)) (equal? amode 'zeropage-y)) 0b101)
      ((and (equal? op 'ldx) (equal? amode 'absolute-y)) 0b111)
      (t
        (case amode
          (immediate 0b000)
          (zeropage 0b001)
          (accumulator 0b010)
          (absolute 0b011)
          (zeropage-x 0b101)
          (absolute-x 0b111)
          (t (error! "invalid addressing mode for group 2")))))))

(defun! 6502/group3 (op amode)
  (6502/grouped 0b00
    (case op
      (bit 0b001)
      (jmp 0b010)
      (jmp-abs 0b011)
      (sty 0b100)
      (ldy 0b101)
      (cpy 0b110)
      (cpx 0b111)
      (t (error! "invalid group 3 opcode")))
    (case amode
      (immediate 0b000)
      (zeropage 0b001)
      (absolute 0b011)
      (zeropage-x 0b101)
      (absolute-x 0b111)
      (t (error! "invalid addressing mode for group 3")))))