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