zybino/old-code/old-code.rkt
2020-06-09 14:50:42 +12:00

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))))