first commit

old-code/decode.rkt

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

old-code/expander.rkt

@@ -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))])

old-code/expr.rkt

@@ -0,0 +1,7 @@
+#lang br
+
+(provide z-ld)
+
+(define-macro-cases z-ld
+   [(_ )]
+                    )

old-code/lexer.rkt

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

old-code/main.rkt

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

old-code/memory.rkt

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

old-code/old-code.rkt

@@ -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))))
+

old-code/parse-only.rkt

@@ -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]))

old-code/parser.rkt

@@ -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

old-code/test.rkt

@@ -0,0 +1,7 @@
+#lang zybino
+
+LD A,8
+LD B,A
+LD C,B
+LD H,16
+LD B,H

old-code/tokenize-only.rkt

@@ -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]))

old-code/tokenizer.rkt

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

vm.rkt

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