327 lines
9.2 KiB
Racket
327 lines
9.2 KiB
Racket
(define (alu-tab y)
|
|
(case y
|
|
[(0) 'RLC]
|
|
[(1) 'RRC]
|
|
[(2) 'RL]
|
|
[(3) 'RR]
|
|
[(4) 'SLA]
|
|
[(5) 'SRA]
|
|
[(6) 'SWAP]
|
|
[(7) 'SRL]
|
|
[else (error "unknown alu operation")]))
|
|
|
|
(define (reg-tab z)
|
|
(case z
|
|
[(0) 'B]
|
|
[(1) 'C]
|
|
[(2) 'D]
|
|
[(3) 'E]
|
|
[(4) 'H]
|
|
[(5) 'L]
|
|
[(6) 'ind-HL]
|
|
[(7) 'A]
|
|
[else (error "unknown register index")]))
|
|
|
|
(define (cc-tab z)
|
|
(case z
|
|
[(0) 'NZ]
|
|
[(1) 'Z]
|
|
[(2) 'NC]
|
|
[(3) 'C]
|
|
[else (error "unknown control index")]))
|
|
|
|
(define (rp-tab y)
|
|
(case
|
|
[(0) 'BC]
|
|
[(1) 'DE]
|
|
[(2) 'HL]
|
|
[(3) 'SP]
|
|
[else (error "unknown register pair index")]))
|
|
|
|
(define (rp2-tab y)
|
|
(case
|
|
[(0) 'BC]
|
|
[(1) 'DE]
|
|
[(2) 'HL]
|
|
[(3) 'AF]
|
|
[else (error "unknown register pair index")]))
|
|
|
|
(define (non-prefix byte)
|
|
(let ([x (arithmetic-shift (bitwise-and #b11000000 byte) -6)])
|
|
(case x
|
|
[(0) (dispatch-zero-x byte)]
|
|
[(1) (dispatch-ld-r-r byte)]
|
|
[(2) (dispatch-alu-x byte)]
|
|
[(3) (dispatch-misc byte)]
|
|
[else (error "malformed byte: " byte)])))
|
|
|
|
(define (dispatch-misc byte)
|
|
(let ([z (bitwise-and #b00000111 byte)])
|
|
(case z
|
|
[(0) (returns-and-misc byte)]
|
|
[(1) (pop-ret-misc byte)]
|
|
[(2) (cond-jps-and-misc-lds byte)]
|
|
[(3) (uncond-jp-and-ints byte)]
|
|
[(4) (cond-calls byte)]
|
|
[(5) (push-and-call byte)]
|
|
[(6) (imm-alu-ops byte)]
|
|
[(7) (rst-vecs byte)])))
|
|
|
|
(define (imm-alu-ops byte)
|
|
(letrec ([y (arithmetic-shift (bitwise-and #b00111000 byte) -3)])
|
|
(lambda x
|
|
`(,(case y
|
|
[(0) 'ADD]
|
|
[(1) 'ADC]
|
|
[(2) 'SUB]
|
|
[(3) 'SBC]
|
|
[(4) 'AND]
|
|
[(5) 'XOR]
|
|
[(6) 'OR]
|
|
[(7) 'CP])
|
|
,x))))
|
|
|
|
(define (rst-vecs byte)
|
|
(letrec ([y (arithmetic-shift (bitwise-and #b00111000 byte) -3)])
|
|
`(RST ,(* y 8))))
|
|
|
|
(define (push-and-call byte)
|
|
(letrec ([y (arithmetic-shift (bitwise-and #b00111000 byte) -3)]
|
|
[p (arithmetic-shift y -1)]
|
|
[z (bitwise-and #b00000111 byte)])
|
|
(case y
|
|
[(0 1 2 3) `(PUSH ,(rp2-tab p))]
|
|
[(4) (lambda y2 (lambda x `(CALL ,@(make-16b-addr x y2))))]
|
|
[(5 6 7) '(REMOVED)])))
|
|
|
|
(define (cond-calls byte)
|
|
(let ([y (arithmetic-shift (bitwise-and #b00111000 byte) -3)]
|
|
[z (bitwise-and #b00000111 byte)])
|
|
(case y
|
|
[(0 1 2 3) (lambda y2 (lambda x `(CALL ,(cc-tab y) ,(make-16b-addr x y2))))]
|
|
[(4 5 6 7) '(REMOVED)])))
|
|
|
|
(define (uncond-jp-and-ints byte)
|
|
(let ([y (arithmetic-shift (bitwise-and #b00111000 byte) -3)]
|
|
[z (bitwise-and #b00000111 byte)])
|
|
(case y
|
|
[(0) (lambda y (lambda x `(JP ,(make-16b-addr x y))))]
|
|
[(1) '(CB-PREFIX)]
|
|
[(2 3 4 5) '(REMOVED)]
|
|
[(6) '(DI)]
|
|
[(7) '(EI)])))
|
|
|
|
(define (cond-jps-and-misc-lds byte)
|
|
(let ([y (arithmetic-shift (bitwise-and #b00111000 byte) -3)]
|
|
[z (bitwise-and #b00000111 byte)])
|
|
(case y
|
|
[(0 1 2 3) (lambda y2 (lambda x `(JP ,(cc-tab y) ,(make-16b-addr x y2))))]
|
|
[(4) '(LD (ADD #xFF00 C) A)]
|
|
[(5) (lambda y (lambda x `(LD ,(make-16b-addr x y) A)))]
|
|
[(6) '(LD A (ADD #xFF00 C))]
|
|
[(7) (lambda y (lambda x `(LD A ,(make-16b-addr x y))))])))
|
|
|
|
(define (pop-ret-misc byte)
|
|
(let ([y (arithmetic-shift (bitwise-and #b00111000 byte) -3)]
|
|
[z (bitwise-and #b00000111 byte)])
|
|
(case y
|
|
[(0 1 2 3) `(POP ,(rp2-tab z))]
|
|
[(4) '(RET)]
|
|
[(5) '(RETI)]
|
|
[(6) '(JP HL)]
|
|
[(7) '(LD SP HL)])))
|
|
|
|
(define (returns-and-misc byte)
|
|
(let ([y (arithmetic-shift (bitwise-and #b00111000 byte) -3)]
|
|
[z (bitwise-and #b00000111 byte)])
|
|
(if (> y 4)
|
|
`(RET ,(cc-tab y))
|
|
(make-misc-ldh-and-sp (- y 4)))))
|
|
|
|
(define (make-misc-ldh-and-sp y)
|
|
(case y
|
|
[(0) (lambda x `(LD ,(bitwise-ior #xFF00 x) A))]
|
|
[(1) (lambda d `(ADD SP ,d))]
|
|
[(2) (lambda x `(LD A ,(bitwise-ior #xFF00 x)))]
|
|
[(3) (lambda d `(LD HL (ADD SP ,d)))]))
|
|
|
|
(define (dispatch-alu-x byte)
|
|
(let ([y (arithmetic-shift (bitwise-and #b00111000 byte) -3)]
|
|
[z (bitwise-and #b00000111 byte)])
|
|
(case y
|
|
[(0) `(ADD ,(reg-tab z))]
|
|
[(1) `(ADC ,(reg-tab z))]
|
|
[(2) `(SUB ,(reg-tab z))]
|
|
[(3) `(SBC ,(reg-tab z))]
|
|
[(4) `(AND ,(reg-tab z))]
|
|
[(5) `(XOR ,(reg-tab z))]
|
|
[(6) `(OR ,(reg-tab z))]
|
|
[(7) `(CP ,(reg-tab z))])))
|
|
|
|
(define (dispatch-zero-x byte)
|
|
(let ([z (bitwise-and #b00000111 byte)])
|
|
(case z
|
|
[(0) (relative-jp-and-misc byte)]
|
|
[(1) (16b-ld-and-add byte)]
|
|
[(2) (indirect-lds-a byte)]
|
|
[(3) (16b-inc-dec byte)]
|
|
[(4 5) (8b-inc-dec byte)]
|
|
[(6) (8b-ld-imm byte)]
|
|
[(7) (rots-and-misc byte)]
|
|
[else (error "malformed instruction: " byte)])))
|
|
|
|
(define (dispatch-ld-r-r byte)
|
|
(let ([y (arithmetic-shift (bitwise-and #b00111000 byte) -3)]
|
|
[z (bitwise-and #b00000111 byte)])
|
|
`(LD ,(reg-tab y) ,(reg-tab z))))
|
|
|
|
(define (rots-and-misc byte)
|
|
(let ([y (arithmetic-shift (bitwise-and #b00111000 byte) -3)])
|
|
(case y
|
|
[(0) '(RLCA)]
|
|
[(1) '(RRCA)]
|
|
[(2) '(RLA)]
|
|
[(3) '(RRA)]
|
|
[(4) '(DAA)]
|
|
[(5) '(CPL)]
|
|
[(6) '(SCF)]
|
|
[(7) '(CCF)])))
|
|
|
|
(define (8b-ld-imm byte)
|
|
(let ([y (arithmetic-shift (bitwise-and #b00111000 byte) -3)])
|
|
(lambda x
|
|
`(LD (REG ,(reg-tab y)) x))))
|
|
|
|
(define (8b-inc-dec byte)
|
|
(let ([y (arithmetic-shift (bitwise-and #b00111000 byte) -3)]
|
|
[z (bitwise-and #b00000111 byte)])
|
|
`(,(if (= 4 z) 'INC 'DEC) (REG ,(reg-tab y)))))
|
|
|
|
(define (16b-inc-dec byte)
|
|
(letrec ([y (arithmetic-shift (bitwise-and #b00111000 byte) -3)]
|
|
[q (modulo y 2)]
|
|
[p (arithmetic-shift y -1)])
|
|
`(,(if (= 0 q) 'INC 'DEC) (REGP ,(rp-tab p)))))
|
|
|
|
(define (indirect-lds-a byte)
|
|
(letrec ([y (arithmetic-shift (bitwise-and #b00111000 byte) -3)]
|
|
[q (modulo y 2)]
|
|
[p (arithmetic-shift y -1)])
|
|
(if (= 0 q)
|
|
(make-ld-ind-p-a p)
|
|
(make-ld-ind-a-p p))))
|
|
|
|
(define (make-ld-ind-p-a p)
|
|
(case p
|
|
[(0) '(LD (IND BC) (REG A))]
|
|
[(1) '(LD (IND DE) (REG A))]
|
|
[(2) '(LDI (IND HL) (REG A))]
|
|
[(3) '(LDD (IND HL) (REG A))]))
|
|
|
|
(define (make-ld-ind-a-p p)
|
|
(case p
|
|
[(0) '(LD (REG A) (IND BC))]
|
|
[(1) '(LD (REG A) (IND DE))]
|
|
[(2) '(LDI (REG A) (IND HL))]
|
|
[(3) '(LDD (REG A) (IND HL))]))
|
|
|
|
(define (16b-ld-and-add byte)
|
|
(letrec ([y (arithmetic-shift (bitwise-and #b00111000 byte) -3)]
|
|
[q (modulo y 2)]
|
|
[p (arithmetic-shift y -1)])
|
|
(if (= 0 q)
|
|
(make-16b-ld p)
|
|
`(ADD (REGP HL) (REGP ,(rp-tab p))))))
|
|
|
|
(define (relative-jp-and-misc byte)
|
|
(let ([y (arithmetic-shift (bitwise-and #b00111000 byte) -3)])
|
|
(case y
|
|
[(0) '(NOP)]
|
|
[(1) (create-ld-16b-ind 'SP)]
|
|
[(2) '(STOP)]
|
|
[(3) (make-jr '())]
|
|
[(4 5 6 7) (make-jr y)]
|
|
[else (error "malformed byte: " byte)])))
|
|
|
|
(define (decode-cb-prefix byte)
|
|
(letrec ([x (arithmetic-shift (bitwise-and #b11000000 byte) -6)]
|
|
[y (arithmetic-shift (bitwise-and #b00111000 byte) -3)]
|
|
[z (bitwise-and #b00000111 byte)])
|
|
(case x
|
|
[(0) `(,(alu-tab y) ,(reg-tab z))]
|
|
[(1) `(BIT ,y ,(reg-tab z))]
|
|
[(2) `(RES ,y ,(reg-tab z))]
|
|
[(3) `(SET ,y ,(reg-tab z))])))
|
|
|
|
(define (test bs)
|
|
(car (read-instruction (set-bytes #x0000 bs (make-mem)))))
|
|
|
|
(define (create-ld-16b-ind src)
|
|
(lambda y
|
|
(lambda x
|
|
`(LD (IND ,(make-16b-addr x y)) ,src))))
|
|
|
|
(define (make-16b-ld p)
|
|
(lambda y
|
|
(lambda x
|
|
`(LD (REGP ,(rp-tab p)) (IND ,(make-16b-addr x y))))))
|
|
|
|
|
|
(define (make-jr cc)
|
|
`(JR ,(if (null? cc) 'no-check (cc-tab (- cc 4)))))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define (read-instruction m)
|
|
(begin
|
|
(define (ri-loop f npc)
|
|
(if (not (procedure? f))
|
|
(cons f (struct-copy mem m [pc npc]))
|
|
(ri-loop (f (get-byte npc m)) (mod-16bit (add1 npc)))))
|
|
(ri-loop decode-instr (mem-pc m))))
|
|
|
|
(define (decode-instr byte)
|
|
(if (or (>= byte 256) (< byte 0))
|
|
(error "invalid opcode byte: " byte)
|
|
(if (= byte #xCB)
|
|
decode-cb-prefix
|
|
(non-prefix byte))))
|
|
|
|
|
|
|
|
(define (read-instruction m)
|
|
(begin
|
|
(define (ri-loop f npc)
|
|
(if (not (procedure? f))
|
|
(cons f (struct-copy mem m [pc npc]))
|
|
(ri-loop (f (get-byte npc m)) (mod-16bit (add1 npc)))))
|
|
(ri-loop decode-instr (mem-pc m))))
|
|
|
|
(define (decode-instr byte)
|
|
(if (or (>= byte 256) (< byte 0))
|
|
(error "invalid opcode byte: " byte)
|
|
(if (= byte #xCB)
|
|
decode-cb-prefix
|
|
(non-prefix byte))))
|
|
|
|
|
|
|
|
(define (read-instruction m)
|
|
(begin
|
|
(define (ri-loop f npc)
|
|
(if (not (procedure? f))
|
|
(cons f (struct-copy mem m [pc npc]))
|
|
(ri-loop (f (get-byte npc m)) (mod-16bit (add1 npc)))))
|
|
(ri-loop decode-instr (mem-pc m))))
|
|
|
|
(define (decode-instr byte)
|
|
(if (or (>= byte 256) (< byte 0))
|
|
(error "invalid opcode byte: " byte)
|
|
(if (= byte #xCB)
|
|
decode-cb-prefix
|
|
(non-prefix byte))))
|
|
|