zybino/old-code/old-code.rkt

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