blob: eb5a4e8338e9f57a563e17b00248b9c50e0b1038 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
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")))))
|
