1 files changed, 174 insertions, 0 deletions
diff --git a/pit/examples/6502.pit b/pit/examples/6502.pit
new file mode 100644
index 0000000..eb5a4e8
--- /dev/null
+++ b/pit/examples/6502.pit
@@ -0,0 +1,174 @@
+;;      (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")))))