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