zybino/vm.rkt

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