@@ -0,0 +1,134 @@ | |||||
#lang racket | |||||
(require "memory.rkt") | |||||
;--------------------- | |||||
; Decode dot ry ky ty | |||||
;--------------------- | |||||
; Functions to decode | |||||
; a byte to an assembly | |||||
; instruction. | |||||
;--------------------- | |||||
(define (inc16b x) | |||||
(mod-16bit (add1 x))) | |||||
(define (alu-op y) | |||||
(case y | |||||
[(0) 'RLC] | |||||
[(1) 'RRC] | |||||
[(2) 'RL] | |||||
[(3) 'RR] | |||||
[(4) 'SLA] | |||||
[(5) 'SRA] | |||||
[(6) 'SWAP] | |||||
[(7) 'SRL])) | |||||
(define (reg-op z) | |||||
(case z | |||||
[(0) 'reg-B] | |||||
[(1) 'reg-C] | |||||
[(2) 'reg-D] | |||||
[(3) 'reg-E] | |||||
[(4) 'reg-H] | |||||
[(5) 'reg-L] | |||||
[(6) 'reg-ind-HL] | |||||
[(7) 'reg-A])) | |||||
(define (cc-tab z) | |||||
(case z | |||||
[(0) 'NZ] | |||||
[(1) 'Z] | |||||
[(2) 'NC] | |||||
[(3) 'C])) | |||||
(define (rp-tab z) | |||||
(case z | |||||
[(0) 'reg-BC] | |||||
[(1) 'reg-DE] | |||||
[(2) 'reg-HL] | |||||
[(3) 'reg-SP])) | |||||
(define (read-word-mem memory) | |||||
(let ([lsb (read-byte-mem memory)] | |||||
[msb (read-byte-mem memory)]) | |||||
(bitwise-ior lsb | |||||
(arithmetic-shift msb 8)))) | |||||
(define (read-byte-mem memory) | |||||
(let ([pc (get-state 'state-PC memory)]) | |||||
(let ([b (get-byte pc 0 memory)]) | |||||
(begin | |||||
(set-state! 'state-PC memory (inc16b pc)) | |||||
b)))) | |||||
(define (read-instruction memory) | |||||
(let ([b1 (read-byte-mem memory)]) | |||||
(if (= #xCB b1) | |||||
; $CB prefix ops | |||||
(letrec ([b2 (read-byte-mem memory)] | |||||
[x (arithmetic-shift (bitwise-and #b11000000 b2) -6)] | |||||
[y (arithmetic-shift (bitwise-and #b00111000 b2) -3)] | |||||
[z (bitwise-and #b00000111 b2)] | |||||
[p (arithmetic-shift y -1)] | |||||
[q (modulo y 2)]) | |||||
(case x | |||||
[(0) `(,(alu-op y) ,(reg-op z))] | |||||
[(1) `(BIT ,y ,(reg-op z))] | |||||
[(2) `(RES ,y ,(reg-op z))] | |||||
[(3) `(SET ,y ,(reg-op z))] | |||||
[else (error "bad instruction")])) | |||||
; No prefix ops | |||||
(letrec ([x (arithmetic-shift (bitwise-and #b11000000 b1) -6)] | |||||
[y (arithmetic-shift (bitwise-and #b00111000 b1) -3)] | |||||
[z (bitwise-and #b00000111 b1)] | |||||
[p (arithmetic-shift y -1)] | |||||
[q (modulo y 2)]) | |||||
(case x | |||||
[(0) | |||||
(case z | |||||
[(0) | |||||
(case y | |||||
[(0) '(NOP)] | |||||
[(1) `(LD-ind ,(read-word-mem memory) reg-SP)] | |||||
[(2) '(STOP)] | |||||
[(3) `(JR expl ,(read-byte-mem memory))] | |||||
[(4 5 6 7) `(JR ,(cc-tab (- y 4)) ,(read-byte-mem memory))] | |||||
[else (error "bad instruction")])] | |||||
[(1) | |||||
(case q | |||||
[(0) `(LD-16b ,(rp-tab p) ,(read-word-memory))] | |||||
[(1) `(ADD-16b reg-HL ,(rp-tab p))] | |||||
[else (error "bad instruction")]) | |||||
] | |||||
[(2) (void)] | |||||
[(3) (void)] | |||||
[(4) (void)] | |||||
[(5) (void)] | |||||
[(6) (void)] | |||||
[(7) (void)])] | |||||
[(1) (void)] | |||||
[(2) (void)] | |||||
[(3) (void)] | |||||
[(4 5 6 7) (void)] | |||||
[else (error "bad instruction")] | |||||
) | |||||
) | |||||
))) | |||||
(define (test1) | |||||
(begin | |||||
(define m (make-memory)) | |||||
(set-state! 'state-PC m #x150) | |||||
(set-byte! #x150 'nil m #x00) | |||||
(read-instruction m))) | |||||
(define (test2) | |||||
(begin | |||||
(define m (make-memory)) | |||||
(set-state! 'state-PC m #x150) | |||||
(set-byte! #x150 'nil m #x08) | |||||
(set-byte! #x151 'nil m #x69) | |||||
(set-byte! #x152 'nil m #xFF) | |||||
(read-instruction m))) | |||||
(provide (all-defined-out)) |
@@ -0,0 +1,23 @@ | |||||
#lang br/quicklang | |||||
(provide (rename-out [z-module-begin #%module-begin]) | |||||
val | |||||
z-ld) | |||||
(define-macro (z-module-begin (z-program LINE ...)) | |||||
#'(#%module-begin | |||||
(define-values (A B C D E F H L) | |||||
(values 0 0 0 0 0 0 0 0)) | |||||
(set! A 8) | |||||
LINE ... | |||||
(displayln | |||||
(format "A: ~a ; F: ~a\nB: ~a ; C: ~a\nD: ~a ; E: ~a\nH: ~a ; L: ~a" | |||||
A F B C D E H L)))) | |||||
(define (val h x) | |||||
(if (symbol? x) | |||||
(hash-ref h x) | |||||
x)) | |||||
(define-macro-cases z-ld | |||||
[(_ (z-r8 S) (_ D)) #'(set! S (val D))]) |
@@ -0,0 +1,7 @@ | |||||
#lang br | |||||
(provide z-ld) | |||||
(define-macro-cases z-ld | |||||
[(_ )] | |||||
) |
@@ -0,0 +1,18 @@ | |||||
#lang br | |||||
(require brag/support) | |||||
(define-lex-abbrev digits (:+ (char-set "0123456789"))) | |||||
(define-lex-abbrev reserved-terms (:or "LD" ",")) | |||||
(define-lex-abbrev register-terms (:or "A" "B" "C" "D" "E" "F" "H" "L")) | |||||
(define basic-lexer | |||||
(lexer-srcloc | |||||
["\n" (token 'NEWLINE lexeme)] | |||||
[whitespace (token lexeme #:skip? #t)] | |||||
[reserved-terms (token lexeme lexeme)] | |||||
[register-terms (token 'REGISTER-ID (string->symbol lexeme))] | |||||
[digits (token 'U8-NUMBER (string->number lexeme))])) | |||||
(provide basic-lexer) |
@@ -0,0 +1,21 @@ | |||||
#lang racket/base | |||||
(require "parser.rkt" "tokenizer.rkt") | |||||
(require syntax/strip-context) | |||||
(module+ reader | |||||
(provide read-syntax get-info)) | |||||
(define (read-syntax path port) | |||||
(define parse-tree (parse path (make-tokenizer port path))) | |||||
(strip-context | |||||
#`(module zybino-mod zybino/expander | |||||
#,parse-tree))) | |||||
(define (get-info port src-mod src-line src-col src-pos) | |||||
(define (handle-query key default) | |||||
(case key | |||||
[(colour-lexer) | |||||
(dynamic-require 'zybino/colourer 'zybino-colourer)] | |||||
[else default])) | |||||
handle-query) |
@@ -0,0 +1,93 @@ | |||||
#lang racket | |||||
(require (for-syntax syntax/parse)) | |||||
;----------------------- | |||||
; Memory Data Structure | |||||
;----------------------- | |||||
; Methods for accessing a 16 bit addressing memory | |||||
; including support for banking (planned) and | |||||
; access controls for ROM (planned) | |||||
;----------------------- | |||||
; Needs: | |||||
; Banking | |||||
; Routes based on memory location | |||||
; Banking based on memory | |||||
; Registers: | |||||
; Fast access | |||||
; Hash? | |||||
; | |||||
(struct memory | |||||
(registers state banks) | |||||
#:transparent) | |||||
(define (make-memory) | |||||
(memory (make-regvec) (make-statevec) (make-bank))) | |||||
(define (make-regvec) | |||||
(make-vector 8)) | |||||
(define (make-statevec) | |||||
(make-vector 2)) | |||||
(define (make-bank [init 0]) | |||||
(make-vector (expt 2 16))) | |||||
(define (deref-state sym) | |||||
(case sym | |||||
[(state-PC) 0] | |||||
[(state-SP) 1] | |||||
[else (error "invalid state:" sym)])) | |||||
(define (deref-reg sym) | |||||
(case sym | |||||
[(reg-A) 0] | |||||
[(reg-F) 1] | |||||
[(reg-B) 2] | |||||
[(reg-C) 3] | |||||
[(reg-D) 4] | |||||
[(reg-E) 5] | |||||
[(reg-H) 6] | |||||
[(reg-L) 7] | |||||
[else (error "invalid register:" sym)])) | |||||
(define (get-reg sym memory) | |||||
(vector-ref (memory-registers memory) (deref-reg sym))) | |||||
(define (get-state sym memory) | |||||
(vector-ref (memory-state memory) (deref-state sym))) | |||||
(define (get-byte addr bank memory) | |||||
(if (and (>= addr 0) | |||||
(< addr 65536)) | |||||
(vector-ref (memory-banks memory) addr) | |||||
(error (format "ERROR: address ~a out of bounds" addr)))) | |||||
(define (set-reg! sym memory val) | |||||
(vector-set! (memory-registers memory) (deref-reg sym) (mod-8bit val))) | |||||
(define (set-state! sym memory val) | |||||
(vector-set! (memory-state memory) (deref-state sym) (mod-16bit val))) | |||||
(define (set-byte! addr bank memory val) | |||||
(if (and (>= addr 0) | |||||
(< addr 65536)) | |||||
(vector-set! (memory-banks memory) addr (mod-8bit val)) | |||||
(error (format "ERROR: address ~a out of bounds" addr)))) | |||||
;---------------------------- | |||||
; define-8bit & define-16bit | |||||
;---------------------------- | |||||
; composes operations with a modulo in order | |||||
; to keep numbers within 8 bits | |||||
;---------------------------- | |||||
(define (mod-8bit x) | |||||
(modulo x 256)) | |||||
(define (mod-16bit x) | |||||
(modulo x 65536)) | |||||
(provide (all-defined-out)) |
@@ -0,0 +1,326 @@ | |||||
(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)))) | |||||
@@ -0,0 +1,17 @@ | |||||
#lang br/quicklang | |||||
(require "parser.rkt" "tokenizer.rkt") | |||||
(define (read-syntax path port) | |||||
(define parse-tree (parse path (make-tokenizer port path))) | |||||
(strip-bindings | |||||
#`(module zybino-parser-mod zybino/parse-only | |||||
#,parse-tree))) | |||||
(module+ reader | |||||
(provide read-syntax)) | |||||
(define-macro (parse-only-mb PARSE-TREE) | |||||
#'(#%module-begin | |||||
'PARSE-TREE)) | |||||
(provide (rename-out [parse-only-mb #%module-begin])) |
@@ -0,0 +1,7 @@ | |||||
#lang brag | |||||
z-program : ([z-op] /NEWLINE)* | |||||
@z-op : z-ld | |||||
z-ld : /"LD" z-r8 /"," (z-r8 | z-n8) | |||||
z-n8 : U8-NUMBER | |||||
z-r8 : REGISTER-ID |
@@ -0,0 +1,7 @@ | |||||
#lang zybino | |||||
LD A,8 | |||||
LD B,A | |||||
LD C,B | |||||
LD H,16 | |||||
LD B,H |
@@ -0,0 +1,17 @@ | |||||
#lang br/quicklang | |||||
(require brag/support "tokenizer.rkt") | |||||
(define (read-syntax path port) | |||||
(define tokens (apply-tokenizer make-tokenizer port)) | |||||
(strip-bindings | |||||
#`(module zybino-tokens-mod zybino/tokenize-only | |||||
#,@tokens))) | |||||
(module+ reader | |||||
(provide read-syntax)) | |||||
(define-macro (tokenize-only-mb TOKEN ...) | |||||
#'(#%module-begin | |||||
(list TOKEN ...))) | |||||
(provide (rename-out [tokenize-only-mb #%module-begin])) |
@@ -0,0 +1,10 @@ | |||||
#lang br | |||||
(require "lexer.rkt" brag/support) | |||||
(define (make-tokenizer ip [path #f]) | |||||
(port-count-lines! ip) | |||||
(lexer-file-path path) | |||||
(define (next-token) (basic-lexer ip)) | |||||
next-token) | |||||
(provide make-tokenizer) |
@@ -0,0 +1,158 @@ | |||||
#lang racket | |||||
(struct mem | |||||
(regs pc sp flags bank)) | |||||
(define (make-mem) | |||||
(mem (make-regs) | |||||
0 | |||||
0 | |||||
0 | |||||
(make-bank))) | |||||
(define (make-regs) | |||||
(make-vector 8 0)) | |||||
(define (get-reg x mem) | |||||
(if (and (< x 8) (>= x 0)) | |||||
(let ([regs (mem-regs mem)]) | |||||
(if (not (= x 6)) | |||||
(vector-ref regs x) | |||||
(let([bank (mem-bank mem)] | |||||
[h (vector-ref regs 4)] | |||||
[l (vector-ref regs 5)]) | |||||
(vector-ref bank (make-16b-addr h l))))) | |||||
(error "unknown register index"))) | |||||
(define (set-reg x val m) | |||||
(if (and (< x 8) (>= x 0)) | |||||
(let ([regs (mem-regs m)]) | |||||
(if (not (= x 6)) | |||||
(let ([newregs (vector-copy regs)]) | |||||
(vector-set! newregs x (mod-8bit val)) | |||||
(struct-copy mem m [regs newregs])) | |||||
(let ([newbank (vector-copy (mem-bank m))] | |||||
[h (vector-ref regs 4)] | |||||
[l (vector-ref regs 5)]) | |||||
(vector-set! newbank (make-16b-addr h l) (mod-8bit val)) | |||||
(struct-copy mem m [bank newbank])))) | |||||
(error "unknown register index"))) | |||||
(define (make-bank) | |||||
(make-vector 65536 #x00)) | |||||
(define (mod-8bit val) | |||||
(modulo val 256)) | |||||
(define (mod-16bit val) | |||||
(modulo val 65536)) | |||||
(define (set-pc addr m) | |||||
(begin | |||||
(struct-copy mem m [pc (mod-16bit addr)]))) | |||||
(define (get-byte addr m) | |||||
(let ([b (mem-bank m)]) | |||||
(if (and (>= addr 0) | |||||
(< addr (vector-length b))) | |||||
(vector-ref b addr) | |||||
(error (format "address ~a out of bounds" addr))))) | |||||
(define (set-byte addr val m) | |||||
(let ([b (mem-bank m)]) | |||||
(if (and (>= addr 0) | |||||
(< addr (vector-length b))) | |||||
(let ([newbank (vector-copy b)]) | |||||
(vector-set! newbank addr (mod-8bit val)) | |||||
(struct-copy mem m [bank newbank])) | |||||
(error (format "address ~a out of bounds" addr))))) | |||||
(define (set-bytes addr bs m) | |||||
(if (null? bs) | |||||
m | |||||
(set-bytes (mod-16bit (add1 addr)) | |||||
(cdr bs) | |||||
(set-byte addr (car bs) m)))) | |||||
(define (inc-sp m) | |||||
(struct-copy mem m [sp (add1 (mem-sp m))])) | |||||
(define (inc-pc m) | |||||
(struct-copy mem m [pc (add1 (mem-pc m))])) | |||||
(define (make-16b-addr x y) | |||||
(bitwise-ior y (arithmetic-shift x 8))) | |||||
(define (8b-ld-reg-imm reg imm) | |||||
(lambda (m) | |||||
(set-reg reg imm m))) | |||||
(define (8b-ld-reg-reg dst src) | |||||
(lambda (m) | |||||
(set-reg dst | |||||
(get-reg src m) | |||||
m))) | |||||
(define (display-byte-hex v) | |||||
(~a #:align 'right #:left-pad-string "0" #:width 2 | |||||
(format "~x" v))) | |||||
(define (display-word-hex v) | |||||
(~a #:align 'right #:left-pad-string "0" #:width 4 | |||||
(format "~x" v))) | |||||
(define (display-bin v) | |||||
(~a #:left-pad-string "0" #:width 8 #:align 'right | |||||
(format "~b" v))) | |||||
(define (print-regs m) | |||||
(letrec ([regs (mem-regs m)] | |||||
[F (display-byte-hex (mem-flags m))] | |||||
[B (display-byte-hex (vector-ref regs 0))] | |||||
[C (display-byte-hex (vector-ref regs 1))] | |||||
[D (display-byte-hex (vector-ref regs 2))] | |||||
[E (display-byte-hex (vector-ref regs 3))] | |||||
[h (vector-ref regs 4)] | |||||
[l (vector-ref regs 5)] | |||||
[H (display-byte-hex (vector-ref regs 4))] | |||||
[L (display-byte-hex (vector-ref regs 5))] | |||||
[HL-ind (display-byte-hex (get-byte (make-16b-addr h l) m))] | |||||
[A (display-byte-hex (vector-ref regs 7))]) | |||||
(displayln (format "BC: $~a~a, DE: $~a~a" B C D E)) | |||||
(displayln (format "HL: $~a~a, AF: $~a~a" H L A F)) | |||||
(displayln (format "(HL): $~a" HL-ind)) | |||||
(void))) | |||||
(define (print-state m) | |||||
(displayln (format "PC: $~a, SP: $~a, Flags: %~a" | |||||
(display-byte-hex (mem-pc m)) | |||||
(display-byte-hex (mem-sp m)) | |||||
(display-bin(mem-flags m))))) | |||||
(define (print-part-bank start count m) | |||||
(define (print-mem v) | |||||
(display (format " $~a" (display-byte-hex v)))) | |||||
(let ([s (display-word-hex start)] | |||||
[e (display-word-hex (mod-16bit (+ start count)))]) | |||||
(display (format "$~a >" s)) | |||||
(let ([splice (vector-take | |||||
(vector-drop (mem-bank m) start) | |||||
count)]) | |||||
(vector-map print-mem splice)) | |||||
(display (format " < $~a\n" e) )) | |||||
(void)) | |||||
(define (run-lines ls) | |||||
(define (run-line-help ls m) | |||||
(if (null? ls) | |||||
m | |||||
(run-line-help (cdr ls) | |||||
((car ls) (inc-pc m))))) | |||||
(let ([fin (run-line-help ls (make-mem))]) | |||||
(begin | |||||
(print-state fin) | |||||
(print-regs fin) | |||||
(print-part-bank #x150 16 fin)))) | |||||
(provide (all-defined-out)) |