Restructure for more reliable reload, modularity

asm.fnl

@@ -1,6 +1,5 @@
 (local lume (require "lume"))
-(local {: stream : kvstream : one} (require "stream"))
+(local {: int8-to-bytes : int16-to-bytes} (require "util"))
-
 (local opcodes {})
 
 ; op mode arg
@@ -33,7 +32,7 @@
     modemap))
 
 (fn without-modes [modemap ...]
-  (let [newmodemap (table.clone modemap)]
+  (let [newmodemap (lume.clone modemap)]
     (each [_ mode (pairs [...])]
       (tset newmodemap mode nil))
     newmodemap))
@@ -89,43 +88,6 @@
     [_] [nil nil]
     _ (error (.. "Unrecognized syntax" (fv op)))))
 
-; dat - anything that takes up space in the assembled output (op, dw, db, etc)
-;   takes the form [:op args]
-; pdat - a parsed dat; takes the form {:type type :addr addr ...}
-(local dat-parser {})
-(fn new-block [] {:type :block :pdats [] :symbols {}})
-
-(fn parse-dats [block dats]
-  (each [_ dat (ipairs dats)]
-    (if (= (type dat) "string")
-      (tset block.symbols dat (+ (length block.pdats) 1))
-      (let [opcode (. dat 1)
-            parser (. dat-parser opcode)
-            pdat
-            (if
-              parser (parser dat block)
-              (. opcodes opcode) (dat-parser.op dat)
-              (error (.. "Unrecognized opcode " (fv opcode))))]
-        (table.insert block.pdats pdat))))
-  block)
-
-(fn dat-parser.op [op]
-  (let [[mode arg] (parse-mode-arg op)]
-    {:type :op :opcode (. op 1) : mode : arg}))
-
-(fn dat-parser.block [block]
-  (let [dats (table.clone block)]
-    (table.remove dats 1)
-    (parse-dats (new-block) dats)))
-
-(fn dat-parser.db [db]       {:type :var :init (. db 2) :size 1})
-(fn dat-parser.dw [dw]       {:type :var :init (. dw 2) :size 2})
-(fn dat-parser.bytes [bytes] {:type :raw :bytes (. bytes 2)})
-(fn dat-parser.ref [ref]     {:type :ref :target (. ref 2)})
-(fn dat-parser.flatten [flat block]
-  (parse-dats block (lume.slice flat 2))
-  nil)
-
 (fn make-env [block parent]
   {:parent parent
    :block block
@@ -153,41 +115,72 @@
 
        (self.parent:lookup-addr name)))})
 
-(fn lo [v] (bit.band v 0xff))
+(fn program []
-(fn hi [v] (bit.band (bit.rshift v 8) 0xff))
+  ; dat - anything that takes up space in the assembled output (op, dw, db, etc)
-(fn int8-to-bytes [i]
+  ;   takes the form [:op args]
-  (string.char (lo i)))
+  ; pdat - a parsed dat; takes the form {:type type :addr addr ...}
-(fn int16-to-bytes [i]
+  (local dat-parser {})
-  (string.char (lo i) (hi i)))
+  (fn new-block [] {:type :block :pdats [] :symbols {}})
 
-(local pdat-processor {
+  (fn parse-dats [block dats]
+    (each [_ dat (ipairs dats)]
+      (if (= (type dat) "string")
+        (tset block.symbols dat (+ (length block.pdats) 1))
+        (let [opcode (. dat 1)
+              parser (. dat-parser opcode)
+              pdat
+              (if
+                parser (parser dat block)
+                (. opcodes opcode) (dat-parser.op dat)
+                (error (.. "Unrecognized opcode " (fv opcode))))]
+          (table.insert block.pdats pdat))))
+    block)
+
+  (fn dat-parser.op [op]
+    (let [[mode arg] (parse-mode-arg op)]
+      {:type :op :opcode (. op 1) : mode : arg}))
+
+  (fn dat-parser.block [block]
+    (let [dats (lume.clone block)]
+      (table.remove dats 1)
+      (parse-dats (new-block) dats)))
+
+  (fn dat-parser.db [db]       {:type :var :init (. db 2) :size 1})
+  (fn dat-parser.dw [dw]       {:type :var :init (. dw 2) :size 2})
+  (fn dat-parser.bytes [bytes] {:type :raw :bytes (. bytes 2)})
+  (fn dat-parser.ref [ref]     {:type :ref :target (. ref 2)})
+  (fn dat-parser.flatten [flat block]
+    (parse-dats block (lume.slice flat 2))
+    nil)
+
+  (local pdat-processor {
     :op {}
     :var {}
     :ref {}
     :raw {}
     :block {}
-})
+  })
 
-(fn process-pdat [pdat process default ...]
+  (fn process-pdat [pdat process default ...]
     (pp pdat)
     (local processor (. pdat-processor pdat.type process))
     (if processor (processor pdat ...) default))
 
-(fn pdat-processor.op.patch [op env]
+  (fn pdat-processor.op.patch [op env]
     (when (and op.mode (= (op.mode:sub 1 4) :addr))
       (let [zp-mode (.. :zp (op.mode:sub 5))
             abs-mode (.. :abs (op.mode:sub 5))
             is-zp (and ((. opcodes op.opcode) zp-mode) (env:is-zp? op.arg))]
         (set op.mode (if is-zp zp-mode abs-mode)))))
 
-(fn pdat-processor.raw.size [raw] (length raw.bytes))
+  (fn pdat-processor.raw.size [raw] (length raw.bytes))
-(fn pdat-processor.op.size [op] (size op.mode))
+  (fn pdat-processor.op.size [op] (size op.mode))
-(fn pdat-processor.var.size [d] d.size)
+  (fn pdat-processor.var.size [d] d.size)
-(fn pdat-processor.ref.size [r] 2)
+  (fn pdat-processor.ref.size [r] 2)
 
-(fn pdat-processor.op.bytes [op env]
+  (fn pdat-processor.op.bytes [op env]
     (local bytegen (. opcodes op.opcode))
-;   (pp op)
+  ;   (pp op)
     (if bytegen
       (let [opbyte (bytegen op.mode)
             argbytes
@@ -205,23 +198,23 @@
           (.. (int8-to-bytes opbyte) argbytes)
           (error (.. op.opcode " doesn't support mode " op.mode))))
       ""))
-(fn pdat-processor.var.bytes [d env]
+  (fn pdat-processor.var.bytes [d env]
     (match d.size
       1 (int8-to-bytes (or d.init 0))
       2 (int16-to-bytes (or d.init 0))
       n (string.rep "\0" n)))
-(fn pdat-processor.ref.bytes [ref env]
+  (fn pdat-processor.ref.bytes [ref env]
     (int16-to-bytes (env:lookup-addr ref.target)))
 
-(fn pdat-processor.block.symbols [block]
+  (fn pdat-processor.block.symbols [block]
     (lume.keys block.symbols))
 
-(fn pdat-processor.block.patch [block env]
+  (fn pdat-processor.block.patch [block env]
     (local block-env (make-env block env))
     (each [_ pdat (ipairs block.pdats)]
       (process-pdat pdat :patch nil block-env)))
 
-(fn pdat-processor.block.allocate [block addr]
+  (fn pdat-processor.block.allocate [block addr]
     (var size 0)
     (set block.addr addr)
     (each [_ pdat (ipairs block.pdats)]
@@ -233,7 +226,7 @@
       (set size (+ size pdatsize)))
     (set block.size size))
 
-(fn pdat-processor.block.generate [block env]
+  (fn pdat-processor.block.generate [block env]
     (local block-env (make-env block env))
     (var bytes "")
     (each [_ pdat (ipairs block.pdats)]
@@ -244,11 +237,14 @@
       (set bytes (.. bytes pdatbytes)))
     (set block.bytes bytes))
 
-(fn program []
   {:type :program
    :org-to-block {}
    :symbol-to-org {}
    :start-symbol :main
+   : dat-parser
+   : pdat-processor
+   : new-block
+   :parse-dats (fn [self block dats] (parse-dats block dats))
    :dbg
    (fn [self ...]
      (when self.dbgfile
@@ -311,12 +307,12 @@
      (self:pass :generate)
      (when self.dbgfile
        (self.dbgfile:close)
-       (set self.dbgfile nil)))
+       (set self.dbgfile nil))
+     self)
    :upload
    (fn [self machine]
      (each [org block (pairs self.org-to-block)]
        (machine:write org block.bytes)))
   })
 
-{: program : dat-parser : pdat-processor : new-block : parse-dats : lo : hi}
+{:new program}
-

main.lua

@@ -6,11 +6,6 @@ pp = function(x) print(fv(x)) end
 lume = require("lume")
 luars232 = require("luars232")
 
-function reload(modname)
-	package.loaded[modname] = nil
-	return require(modname)
-end
-
 _coroutine_resume = coroutine.resume
 function coroutine.resume(...)
 	local state,result = _coroutine_resume(...)

neut.fnl

@@ -0,0 +1,156 @@
+(local lume (require "lume"))
+(local asm (require "asm"))
+(local VM (require "vm"))
+(local {: lo : hi} (require "util"))
+
+(local prg (asm.new))
+; (prg:debug-to "test.dbg")
+
+(local tiles (prg:org 0x6100))
+(local vm (VM.new prg))
+(local code1 vm.code)
+
+(local mon {
+  :hexout :0xfdda
+  :putchar :0xfded
+  :bell :0xff3a
+})
+
+(fn achar [c] (bit.bor (string.byte c) 0x80))
+(fn astr [s]
+  (-> [(string.byte s 1 -1)]
+    (lume.map #(bit.bor $1 0x80))
+    (-> (table.unpack) (string.char))))
+
+; a handful of debugging words
+(vm:def :.
+  [:lda vm.TOPH :x]
+  [:jsr mon.hexout]
+  [:lda vm.TOP :x]
+  [:jsr mon.hexout]
+  [:lda (achar " ")]
+  [:jsr mon.putchar]
+  (vm:drop))
+
+(vm:def :stacklen
+  (vm:reserve)
+  [:txa] [:lsr :a] [:sta vm.TOP :x]
+  [:lda 0] [:sta vm.TOPH :x])
+
+(vm:word :.s
+  :stacklen (prg:parse-addr vm.TOP) :swap
+  (vm:for :dup :get :. :inc :inc) :drop)
+
+; Graphics routines
+(vm:def :mixed-hires
+  [:sta :0xc050]
+  [:sta :0xc057]
+  [:sta :0xc052])
+
+; starting address:
+; 0x2000 + (x*2) + (y%4 * 0x100) + ((y/4) * 0x28)
+; x between 0-19
+; y between 0-12
+; yx - 16-bit value, low byte x, high byte y
+(code1:append :screeny-lookup [:bytes "\0\040\080"])
+(vm:def :tile>screen ; yx -- p
+  [:lda vm.TOPH :x]         ; a=y
+  [:lsr :a] [:lsr :a]       ; a=y/4
+  [:tay]                    ; y=y/4
+  [:lda 0x03]
+  [:and vm.TOPH :x]         ; a=y%4
+  [:ora 0x20]               ; a=0x20 + y%4
+  [:sta vm.TOPH :x]         ; high byte is set (and y is wiped)
+  [:lda vm.TOP :x]          ; a=x
+  [:asl :a]                 ; a = x*2
+  [:clc]
+  [:adc :screeny-lookup :y] ; a=x*2 + (y/4)*0x28
+  [:sta vm.TOP :x]          ; low byte is set
+)
+
+; note: the graphical tile data must not cross a page boundary!
+; TODO: add support to the assembler for enforcing that
+(fn draw-block []
+  [:block
+    [:clc]
+    [:ldy 8]
+  :loop
+    [:lda [vm.TOP :x]]
+    [:sta [vm.ST1 :x]]
+    [:inc vm.TOP :x]
+    [:lda vm.ST1H :x]
+    [:adc 4]
+    [:sta vm.ST1H :x]
+    [:dey]
+    [:bne :loop]])
+
+(fn draw-vertical-block []
+  [:block
+    (draw-block)
+    [:lda vm.ST1H :x]
+    [:sbc 31] ; with carry clear this is 32
+    [:sta vm.ST1H :x]
+    [:lda vm.ST1 :x]
+    [:ora 0x80]
+    [:sta vm.ST1 :x]
+    (draw-block)])
+
+(vm:def :drawtile ; p gfx --
+  (draw-vertical-block)
+  [:lda vm.ST1H :x]
+  [:sbc 31]
+  [:sta vm.ST1H :x]
+  [:lda vm.ST1 :x]
+  [:sbc 0x7f]
+  [:sta vm.ST1 :x]
+  (draw-vertical-block)
+  (vm:drop) (vm:drop))
+
+(vm:def :cleargfx
+  (vm:push 0x4000)
+  [:block :page
+    [:dec vm.TOPH :x]
+    [:lda 0]
+    [:block :start
+      [:sta [vm.TOP :x]]
+      [:inc vm.TOP :x]
+      [:bne :start]]
+    [:lda vm.TOPH :x]
+    [:cmp 0x20]
+    [:bne :page]]
+  (vm:drop))
+
+(vm:word :drawmaprow ; pscreen pmap -- pmap
+  20 (vm:for
+    :2dup :bget :lookup-tile :drawtile
+    :inc :swap :inc :inc :swap) :swap :drop)
+
+(vm:word :drawmap
+  :lit :map 0x0c00 (vm:until 0x100 :-
+    :dup :tile>screen ; pmap yx pscreen
+    :<rot :drawmaprow :swap ; pmap yx
+  :dup :not) :drop :drop)
+
+(vm:def :lookup-tile ; itile -- ptile
+  ; each tile is 32 bytes; 2^5
+  ; we save some cycles by storing the indices as lllhhhhh, so we don't need to shift them'
+  [:lda vm.TOP :x] [:tay]
+  [:and 0x1f]
+  [:clc] [:adc #(hi tiles.org)]
+  [:sta vm.TOPH :x]
+  [:tya] [:and 0xe0]
+  [:sta vm.TOP :x])
+
+(tiles:append :blanktile [:bytes "\0\0\0\0\0\0\0\0\0\255\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0    \0\0\0\0\0\0"])
+(tiles:append :testtile [:bytes "12345678901234567890123456789012"])
+(tiles:append [:bytes "zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz"])
+;; 19x11 means full map is 209 bytes
+(: (prg:org 0x6800) :append :map [:bytes (string.rep "\0\032\064" 85)])
+(code1:append :main
+  [:jsr :reset]
+  [:jsr :interpret]
+  [:vm :mixed-hires
+    :cleargfx :drawmap
+    :quit])
+
+(prg:assemble)

test.fnl

@@ -1,479 +0,0 @@
-(local lume (require "lume"))
-(local {: program : dat-parser : new-block : parse-dats : lo : hi} (require "asm"))
-(local {: stream : kvstream : one} (require "stream"))
-
-(local prg (program))
-(local code1 (prg:org 0xc00))
-(local tiles (prg:org 0x6100))
-
-(prg:debug-to "test.dbg")
-
-(fn dat-parser.vm [bytecodes]
-  (local block (new-block))
-  (each [_ bytecode (ipairs (lume.slice bytecodes 2))]
-    (if
-      (= (type bytecode) :number)
-      (parse-dats block [[:ref :lit] [:dw bytecode]])
-
-      (= (type bytecode) :string)
-      (parse-dats block [[:ref bytecode]])
-
-      (= (type bytecode) :table)
-      (parse-dats block [bytecode])
-
-      (error (.. "VM can't parse " (fv bytecode)))))
-  block)
-(local mon {
-  :hexout :0xfdda
-  :putchar :0xfded
-  :bell :0xff3a
-})
-
-(local vm {
-  :IP   :0x60
-  :IPH  :0x61
-  :W    :0x62
-  :WH   :0x63
-  :ROFF :0x64
-  :TOP  :0x80
-  :TOPH :0x81
-  :ST1  :0x7e
-  :ST1H :0x7f
-  :ST2  :0x7c
-  :ST2H :0x7d
-  :RSTACK :0x6000
-  :ret (fn [self] [:jmp :next])
-  :reserve (fn [self] [:block [:inx] [:inx]])
-  :push
-  (fn [self v]
-    (local l (bit.band v 0xff))
-    (local h (bit.band (bit.rshift v 8) 0xff))
-    [:block (self:reserve)
-      [:lda l]
-      [:sta self.TOP :x]
-      [:lda h]
-      [:sta self.TOPH :x]
-    ])
-  :drop (fn [self] [:block [:dex] [:dex]])
-  :def
-  (fn [self name ...]
-    (code1:append name [:flatten ...] (self:ret)))
-  :word
-  (fn [self name ...]
-    (code1:append name [:jsr :subroutine] [:vm ...] [:vm :ret]))
-  :inline
-  (fn [self ...]
-    [:block [:jsr :subroutine] [:vm ...] [:vm :restore]])
-  :asm
-  (fn [self ...]
-    [:block [:vm :native] [:block ...] [:jsr :interpret]])
-})
-
-(fn inc16 [l h]
-  [:block
-    [:inc l]
-    [:bne :done]
-    [:inc h]
-   :done
-  ])
-(fn dec16 [l h]
-  [:block
-    [:lda l]
-    [:bne :declow]
-    [:dec h]
-   :declow
-    [:dec l]])
-
-(fn add16 [l h]
-  [:block
-    [:clc]
-    [:adc l]
-    [:sta l]
-    [:bcc :go]
-    [:inc h]
-    :go
-  ])
-(fn inc16-stk [l h]
-  [:block
-    [:inc l :x]
-    [:bne :done]
-    [:inc h :x]
-   :done])
-
-(fn achar [c] (bit.bor (string.byte c) 0x80))
-(fn astr [s]
-  (-> [(string.byte s 1 -1)]
-    (lume.map #(bit.bor $1 0x80))
-    (-> (table.unpack) (string.char))))
-
-(code1:append :next
-  [:ldy 0]
-  [:lda [vm.IP] :y]  [:sta vm.W]
-  (inc16 vm.IP vm.IPH)
-  [:lda [vm.IP] :y] [:sta vm.WH]
-  (inc16 vm.IP vm.IPH)
-
-;   [:lda vm.WH]
-;   [:jsr mon.hexout]
-;   [:lda vm.W]
-;   [:jsr mon.hexout]
-;   [:lda (achar " ")]
-;   [:jsr mon.putchar]
-
-  [:jmp [vm.W]])
-
-(code1:append :reset
-  [:lda #(lo ($1:lookup-addr :quit))]
-  [:sta vm.IP]
-  [:lda #(hi ($1:lookup-addr :quit))]
-  [:sta vm.IPH]
-  [:lda 0]
-  [:sta vm.ROFF]
-  [:ldx 0xfe]
-  [:rts])
-
-(vm:def
- :subroutine ; usage: [jsr :subroutine] followed by bytecode
-  [:ldy vm.ROFF]
-  [:lda vm.IP] [:sta vm.RSTACK :y] [:iny]
-  [:lda vm.IPH] [:sta vm.RSTACK :y] [:iny]
-  [:sty vm.ROFF]
- :interpret ; usage: [jsr :interpret] followed by bytecode
-  [:pla] [:sta vm.IP] [:pla] [:sta vm.IPH]
-  (inc16 vm.IP vm.IPH))
-
-(vm:def :ret
-  [:ldy vm.ROFF]
-  [:dey] [:lda vm.RSTACK :y] [:sta vm.IPH]
-  [:dey] [:lda vm.RSTACK :y] [:sta vm.IP]
-  [:sty vm.ROFF])
-
-(code1:append :native [:jmp [vm.IP]])
-(code1:append :quit [:rts])
-(code1:append :restore
-  [:lda vm.IP]  [:sta vm.W]
-  [:lda vm.IPH] [:sta vm.WH]
-  [:ldy vm.ROFF]
-  [:dey] [:lda vm.RSTACK :y] [:sta vm.IPH]
-  [:dey] [:lda vm.RSTACK :y] [:sta vm.IP]
-  [:sty vm.ROFF]
-  [:jmp [vm.W]])
-
-  (vm:def :mixed-hires
-  [:sta :0xc050]
-  [:sta :0xc057]
-  [:sta :0xc052])
-
-(vm:def :drop (vm:drop))
-
-(vm:def :dup
-  (vm:reserve)
-  [:lda vm.ST1H :x]
-  [:sta vm.TOPH :x]
-  [:lda vm.ST1 :x]
-  [:sta vm.TOP :x])
-
-(vm:def :swap
-  [:lda vm.TOP :x]
-  [:ldy vm.ST1 :x]
-  [:sty vm.TOP :x]
-  [:sta vm.ST1 :x]
-  [:lda vm.TOPH :x]
-  [:ldy vm.ST1H :x]
-  [:sty vm.TOPH :x]
-  [:sta vm.ST1H :x])
-
-(vm:def :over
-  (vm:reserve)
-  [:lda vm.ST2H :x]
-  [:sta vm.TOPH :x]
-  [:lda vm.ST2 :x]
-  [:sta vm.TOP :x])
-(vm:word :2dup :over :over)
-
-(vm:def :>rot ; (a b c -- c a b)
-  [:lda vm.TOP :x] ; a: c (a b c)
-  [:ldy vm.ST2 :x] ; y: a (a b c)
-  [:sta vm.ST2 :x] ; a: c (c b c)
-  [:lda vm.ST1 :x] ; a: b (c b c)
-  [:sta vm.TOP :x] ; a: b (c b b)
-  [:sty vm.ST1 :x] ; y: a (c a b)
-  [:lda vm.TOPH :x] ; a: c (a b c)
-  [:ldy vm.ST2H :x] ; y: a (a b c)
-  [:sta vm.ST2H :x] ; a: c (c b c)
-  [:lda vm.ST1H :x] ; a: b (c b c)
-  [:sta vm.TOPH :x] ; a: b (c b b)
-  [:sty vm.ST1H :x] ; y: a (c a b)
-)
-(vm:def :<rot ; (a b c -- b c a)
-  [:lda vm.TOP :x] ; a: c (a b c)
-  [:ldy vm.ST1 :x] ; y: b (a b c)
-  [:sta vm.ST1 :x] ; a: c (a c c)
-  [:lda vm.ST2 :x] ; a: a (a c c)
-  [:sta vm.TOP :x] ; a: a (a c a)
-  [:sty vm.ST2 :x] ; y: b (b c a)
-  [:lda vm.TOPH :x] ; a: c (a b c)
-  [:ldy vm.ST1H :x] ; y: b (a b c)
-  [:sta vm.ST1H :x] ; a: c (a c c)
-  [:lda vm.ST2H :x] ; a: a (a c c)
-  [:sta vm.TOPH :x] ; a: a (a c a)
-  [:sty vm.ST2H :x] ; y: b (b c a)
-)
-
-(vm:def :get
-  [:lda [vm.TOP :x]]
-  [:tay]
-  (inc16-stk vm.TOP vm.TOPH)
-  [:lda [vm.TOP :x]]
-  [:sta vm.TOPH :x]
-  [:sty vm.TOP :x])
-
-(vm:def :set ; v p --
-  [:lda vm.ST1 :x]
-  [:sta [vm.TOP :x]]
-  (inc16-stk vm.TOP vm.TOPH)
-  [:lda vm.ST1H :x]
-  [:sta [vm.TOP :x]]
-  (vm:drop) (vm:drop))
-
-(vm:def :bget ; p -- b
-  [:lda [vm.TOP :x]] [:sta vm.TOP :x]
-  [:lda 0] [:sta vm.TOPH :x])
-
-(vm:def :bset ; b p --
-  [:lda vm.ST1 :x] [:sta [vm.TOP :x]]
-  (vm:drop) (vm:drop))
-
-(vm:def :lit
-  (vm:reserve) [:ldy 0]
-  [:lda [vm.IP] :y] [:sta vm.TOP :x]
-  (inc16 vm.IP vm.IPH)
-  [:lda [vm.IP] :y] [:sta vm.TOPH :x]
-  (inc16 vm.IP vm.IPH))
-
-(vm:def :>r ; v --
-  [:ldy vm.ROFF]
-  [:lda vm.TOP :x]  [:sta vm.RSTACK :y] [:iny]
-  [:lda vm.TOPH :x] [:sta vm.RSTACK :y] [:iny]
-  [:sty vm.ROFF]
-  (vm:drop))
-
-(vm:def :r> ; -- v
-  (vm:reserve)
-  [:ldy vm.ROFF]
-  [:dey] [:lda vm.RSTACK :y] [:sta vm.TOPH :x]
-  [:dey] [:lda vm.RSTACK :y] [:sta vm.TOP :x]
-  [:sty vm.ROFF])
-
-(vm:def :rtop ; -- v
-  (vm:reserve)
-  [:ldy vm.ROFF]
-  [:dey] [:lda vm.RSTACK :y] [:sta vm.TOPH :x]
-  [:dey] [:lda vm.RSTACK :y] [:sta vm.TOP :x])
-
-(vm:def :rdrop
-  [:ldy vm.ROFF] [:dey] [:dey] [:sty vm.ROFF])
-
-(vm:def :bz ; f --
-  [:block
-    [:lda vm.TOP :x]
-    [:bne :skip]
-    [:lda vm.TOPH :x]
-    [:beq :dojmp]
-   :skip
-    (vm:drop)
-    [:lda 2] (add16 vm.IP vm.IPH) (vm:ret)
-   :dojmp (vm:drop)]
- :jmp
-  ; ugh I don't have enough registers for this; a (one-byte?) relative jump would maybe be better
-  [:ldy 0] [:lda [vm.IP] :y] [:sta vm.W]
-  [:iny] [:lda [vm.IP] :y] [:sta vm.IPH]
-  [:lda vm.W] [:sta vm.IP])
-
-(fn vm.while [self preamble ...]
-  [:block
-    :start
-      [:vm (table.unpack preamble)]
-      [:ref :bz] [:ref :end]
-      [:vm ...]
-      [:ref :jmp] [:ref :start]
-    :end])
-
-(fn vm.until [self ...]
-  [:block :start [:vm ...] [:ref :bz] [:ref :start]])
-
-(fn vm.for [self ...]
-  [:vm :>r (vm:while [:rtop] [:vm ...] :r> :dec :>r) :rdrop])
-
-(vm:def :+ ; a b -- c
-  [:clc]
-  [:lda vm.ST1 :x] [:adc vm.TOP :x] [:sta vm.ST1 :x]
-  [:lda vm.ST1H :x] [:adc vm.TOPH :x] [:sta vm.ST1H :x]
-  (vm:drop))
-
-(vm:def :- ; a b -- c
-  [:sec]
-  [:lda vm.ST1 :x] [:sbc vm.TOP :x] [:sta vm.ST1 :x]
-  [:lda vm.ST1H :x] [:sbc vm.TOPH :x] [:sta vm.ST1H :x]
-  (vm:drop))
-
-(vm:def :inc ; a -- a+1
-  (inc16-stk vm.TOP vm.TOPH))
-
-(vm:def :dec ; a -- a-1
-  [:block
-    [:lda vm.TOP :x]
-    [:bne :declow]
-    [:dec vm.TOPH :x]
-   :declow
-    [:dec vm.TOP :x]])
-
-(vm:def :not ; f - !f
-  [:block
-    [:lda vm.TOP :x]
-    [:bne :zero]
-    [:lda vm.TOPH :x]
-    [:bne :zero]
-    [:lda 0xff] [:sta vm.TOP :x] [:sta vm.TOPH :x] (vm:ret)
-   :zero
-    [:lda 0] [:sta vm.TOP :x] [:sta vm.TOPH :x]])
-
-(vm:def := ; a b -- f
-  [:block
-    [:lda vm.ST1 :x]
-    [:cmp vm.TOP :x]
-    [:bne :noteq]
-    [:lda vm.ST1H :x]
-    [:cmp vm.TOP :x]
-    [:bne :noteq]
-    [:lda 0xff] (vm:drop) [:sta vm.TOP :x] [:sta vm.TOPH :x] (vm:ret)
-   :noteq
-    [:lda 0] (vm:drop) [:sta vm.TOP :x] [:sta vm.TOPH :x]])
-
-(vm:def :.
-  [:lda vm.TOPH :x]
-  [:jsr mon.hexout]
-  [:lda vm.TOP :x]
-  [:jsr mon.hexout]
-  [:lda (achar " ")]
-  [:jsr mon.putchar]
-  (vm:drop))
-
-(vm:def :stacklen
-  (vm:reserve)
-  [:txa] [:lsr :a] [:sta vm.TOP :x]
-  [:lda 0] [:sta vm.TOPH :x])
-
-(vm:word :.s
-  :stacklen (prg:parse-addr vm.TOP) :swap
-  (vm:for :dup :get :. :inc :inc) :drop)
-
-; starting address:
-; 0x2000 + (x*2) + (y%4 * 0x100) + ((y/4) * 0x28)
-; x between 0-19
-; y between 0-12
-; yx - 16-bit value, low byte x, high byte y
-(code1:append :screeny-lookup [:bytes "\0\040\080"])
-(vm:def :tile>screen ; yx -- p
-  [:lda vm.TOPH :x]         ; a=y
-  [:lsr :a] [:lsr :a]       ; a=y/4
-  [:tay]                    ; y=y/4
-  [:lda 0x03]
-  [:and vm.TOPH :x]         ; a=y%4
-  [:ora 0x20]               ; a=0x20 + y%4
-  [:sta vm.TOPH :x]         ; high byte is set (and y is wiped)
-  [:lda vm.TOP :x]          ; a=x
-  [:asl :a]                 ; a = x*2
-  [:clc]
-  [:adc :screeny-lookup :y] ; a=x*2 + (y/4)*0x28
-  [:sta vm.TOP :x]          ; low byte is set
-)
-
-; note: the graphical tile data must not cross a page boundary!
-; TODO: add support to the assembler for enforcing that
-(fn draw-block []
-  [:block
-    [:clc]
-    [:ldy 8]
-  :loop
-    [:lda [vm.TOP :x]]
-    [:sta [vm.ST1 :x]]
-    [:inc vm.TOP :x]
-    [:lda vm.ST1H :x]
-    [:adc 4]
-    [:sta vm.ST1H :x]
-    [:dey]
-    [:bne :loop]])
-
-(fn draw-vertical-block []
-  [:block
-    (draw-block)
-    [:lda vm.ST1H :x]
-    [:sbc 31] ; with carry clear this is 32
-    [:sta vm.ST1H :x]
-    [:lda vm.ST1 :x]
-    [:ora 0x80]
-    [:sta vm.ST1 :x]
-    (draw-block)])
-
-(vm:def :drawtile ; p gfx --
-  (draw-vertical-block)
-  [:lda vm.ST1H :x]
-  [:sbc 31]
-  [:sta vm.ST1H :x]
-  [:lda vm.ST1 :x]
-  [:sbc 0x7f]
-  [:sta vm.ST1 :x]
-  (draw-vertical-block)
-  (vm:drop) (vm:drop))
-
-(vm:def :cleargfx
-  (vm:push 0x4000)
-  [:block :page
-    [:dec vm.TOPH :x]
-    [:lda 0]
-    [:block :start
-      [:sta [vm.TOP :x]]
-      [:inc vm.TOP :x]
-      [:bne :start]]
-    [:lda vm.TOPH :x]
-    [:cmp 0x20]
-    [:bne :page]]
-  (vm:drop))
-
-(vm:word :drawmaprow ; pscreen pmap -- pmap
-  20 (vm:for
-    :2dup :bget :lookup-tile :drawtile
-    :inc :swap :inc :inc :swap) :swap :drop)
-
-(vm:word :drawmap
-  :lit :map 0x0c00 (vm:until 0x100 :-
-    :dup :tile>screen ; pmap yx pscreen
-    :<rot :drawmaprow :swap ; pmap yx
-  :dup :not) :drop :drop)
-
-(vm:def :lookup-tile ; itile -- ptile
-  ; each tile is 32 bytes; 2^5
-  ; we save some cycles by storing the indices as lllhhhhh, so we don't need to shift them'
-  [:lda vm.TOP :x] [:tay]
-  [:and 0x1f]
-  [:clc] [:adc #(hi tiles.org)]
-  [:sta vm.TOPH :x]
-  [:tya] [:and 0xe0]
-  [:sta vm.TOP :x])
-
-(tiles:append :blanktile [:bytes "\0\0\0\0\0\0\0\0\0\255\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0    \0\0\0\0\0\0"])
-(tiles:append :testtile [:bytes "12345678901234567890123456789012"])
-(tiles:append [:bytes "zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz"])
-;; 19x11 means full map is 209 bytes
-(: (prg:org 0x6800) :append :map [:bytes (string.rep "\0\032\064" 85)])
-(code1:append :main
-  [:jsr :reset]
-  [:jsr :interpret]
-  [:vm :mixed-hires
-    :cleargfx :drawmap
-    :quit])
-
-(prg:assemble)
-
-prg

util.fnl

@@ -1,9 +1,40 @@
-(fn table.clone [tbl]
+(local lume (require "lume"))
-  (let [newtbl {}]
+
-    (each [k v (pairs tbl)]
-      (tset newtbl k v))
-    newtbl))
 (fn string.fromhex [str]
   (str:gsub ".." (fn [cc] (string.char (tonumber cc 16)))))
 (fn string.tohex [str]
   (str:gsub "." (fn [c] (string.format "%02X" (string.byte c)))))
+
+(fn lo [v] (bit.band v 0xff))
+(fn hi [v] (bit.band (bit.rshift v 8) 0xff))
+(fn int8-to-bytes [i]
+  (string.char (lo i)))
+(fn int16-to-bytes [i]
+  (string.char (lo i) (hi i)))
+
+(fn reload [modname]
+  (tset package.loaded modname nil)
+  (require modname))
+
+; lume.hotswap really assumes your module is a table
+(fn hotswap [modname]
+  (if (= (type (. package.loaded modname)) :table)
+    (lume.hotswap modname)
+    (reload modname)))
+
+(fn mk-swappable-fn [table k]
+  (fn [...] ((. table k) ...)))
+
+(fn swappable [table]
+  (local s {})
+  (each [k v (pairs table)]
+    (if (= (type v) :function)
+      (tset s k (mk-swappable-fn table k))
+      (tset s k v)))
+  s)
+
+(fn swappable-require [modname]
+  (swappable (require modname)))
+
+{: lo : hi : int8-to-bytes : int16-to-bytes : reload : hotswap : swappable :require swappable-require}
+

vm.fnl

@@ -0,0 +1,337 @@
+(local lume (require "lume"))
+(local {: lo : hi} (require "util"))
+
+(fn inc16-stk [l h]
+  [:block
+    [:inc l :x]
+    [:bne :done]
+    [:inc h :x]
+   :done])
+
+(fn inc16 [l h]
+  [:block
+    [:inc l]
+    [:bne :done]
+    [:inc h]
+   :done
+  ])
+
+(fn dec16 [l h]
+  [:block
+    [:lda l]
+    [:bne :declow]
+    [:dec h]
+   :declow
+    [:dec l]])
+
+(fn add16 [l h]
+  [:block
+    [:clc]
+    [:adc l]
+    [:sta l]
+    [:bcc :go]
+    [:inc h]
+    :go
+  ])
+
+(fn mk-vm [prg options]
+  (local code1 (prg:org 0xc00))
+
+  (fn prg.dat-parser.vm [bytecodes]
+    (local block (prg:new-block))
+    (each [_ bytecode (ipairs (lume.slice bytecodes 2))]
+      (if
+        (= (type bytecode) :number)
+        (prg:parse-dats block [[:ref :lit] [:dw bytecode]])
+
+        (= (type bytecode) :string)
+        (prg:parse-dats block [[:ref bytecode]])
+
+        (= (type bytecode) :table)
+        (prg:parse-dats block [bytecode])
+
+        (error (.. "VM can't parse " (fv bytecode)))))
+    block)
+  (local vm {
+    :IP   :0x60
+    :IPH  :0x61
+    :W    :0x62
+    :WH   :0x63
+    :ROFF :0x64
+    :TOP  :0x80
+    :TOPH :0x81
+    :ST1  :0x7e
+    :ST1H :0x7f
+    :ST2  :0x7c
+    :ST2H :0x7d
+    :RSTACK :0x6000
+    :code code1
+    :ret (fn [self] [:jmp :next])
+    :reserve (fn [self] [:block [:inx] [:inx]])
+    :push
+    (fn [self v]
+      (local l (bit.band v 0xff))
+      (local h (bit.band (bit.rshift v 8) 0xff))
+      [:block (self:reserve)
+        [:lda l]
+        [:sta self.TOP :x]
+        [:lda h]
+        [:sta self.TOPH :x]
+      ])
+    :drop (fn [self] [:block [:dex] [:dex]])
+    :def
+    (fn [self name ...]
+      (code1:append name [:flatten ...] (self:ret)))
+    :word
+    (fn [self name ...]
+      (code1:append name [:jsr :subroutine] [:vm ...] [:vm :ret]))
+    :inline
+    (fn [self ...]
+      [:block [:jsr :subroutine] [:vm ...] [:vm :restore]])
+    :asm
+    (fn [self ...]
+      [:block [:vm :native] [:block ...] [:jsr :interpret]])
+  })
+
+  (code1:append :next
+    [:ldy 0]
+    [:lda [vm.IP] :y]  [:sta vm.W]
+    (inc16 vm.IP vm.IPH)
+    [:lda [vm.IP] :y] [:sta vm.WH]
+    (inc16 vm.IP vm.IPH)
+
+  ;   [:lda vm.WH]
+  ;   [:jsr mon.hexout]
+  ;   [:lda vm.W]
+  ;   [:jsr mon.hexout]
+  ;   [:lda (achar " ")]
+  ;   [:jsr mon.putchar]
+
+    [:jmp [vm.W]])
+
+  (code1:append :reset
+    [:lda #(lo ($1:lookup-addr :quit))]
+    [:sta vm.IP]
+    [:lda #(hi ($1:lookup-addr :quit))]
+    [:sta vm.IPH]
+    [:lda 0]
+    [:sta vm.ROFF]
+    [:ldx 0xfe]
+    [:rts])
+
+  (vm:def
+   :subroutine ; usage: [jsr :subroutine] followed by bytecode
+    [:ldy vm.ROFF]
+    [:lda vm.IP] [:sta vm.RSTACK :y] [:iny]
+    [:lda vm.IPH] [:sta vm.RSTACK :y] [:iny]
+    [:sty vm.ROFF]
+   :interpret ; usage: [jsr :interpret] followed by bytecode
+    [:pla] [:sta vm.IP] [:pla] [:sta vm.IPH]
+    (inc16 vm.IP vm.IPH))
+
+  (vm:def :ret
+    [:ldy vm.ROFF]
+    [:dey] [:lda vm.RSTACK :y] [:sta vm.IPH]
+    [:dey] [:lda vm.RSTACK :y] [:sta vm.IP]
+    [:sty vm.ROFF])
+
+  (code1:append :native [:jmp [vm.IP]])
+  (code1:append :quit [:rts])
+  (code1:append :restore
+    [:lda vm.IP]  [:sta vm.W]
+    [:lda vm.IPH] [:sta vm.WH]
+    [:ldy vm.ROFF]
+    [:dey] [:lda vm.RSTACK :y] [:sta vm.IPH]
+    [:dey] [:lda vm.RSTACK :y] [:sta vm.IP]
+    [:sty vm.ROFF]
+    [:jmp [vm.W]])
+
+
+  (vm:def :drop (vm:drop))
+
+  (vm:def :dup
+    (vm:reserve)
+    [:lda vm.ST1H :x]
+    [:sta vm.TOPH :x]
+    [:lda vm.ST1 :x]
+    [:sta vm.TOP :x])
+
+  (vm:def :swap
+    [:lda vm.TOP :x]
+    [:ldy vm.ST1 :x]
+    [:sty vm.TOP :x]
+    [:sta vm.ST1 :x]
+    [:lda vm.TOPH :x]
+    [:ldy vm.ST1H :x]
+    [:sty vm.TOPH :x]
+    [:sta vm.ST1H :x])
+
+  (vm:def :over
+    (vm:reserve)
+    [:lda vm.ST2H :x]
+    [:sta vm.TOPH :x]
+    [:lda vm.ST2 :x]
+    [:sta vm.TOP :x])
+  (vm:word :2dup :over :over)
+
+  (vm:def :>rot ; (a b c -- c a b)
+    [:lda vm.TOP :x] ; a: c (a b c)
+    [:ldy vm.ST2 :x] ; y: a (a b c)
+    [:sta vm.ST2 :x] ; a: c (c b c)
+    [:lda vm.ST1 :x] ; a: b (c b c)
+    [:sta vm.TOP :x] ; a: b (c b b)
+    [:sty vm.ST1 :x] ; y: a (c a b)
+    [:lda vm.TOPH :x] ; a: c (a b c)
+    [:ldy vm.ST2H :x] ; y: a (a b c)
+    [:sta vm.ST2H :x] ; a: c (c b c)
+    [:lda vm.ST1H :x] ; a: b (c b c)
+    [:sta vm.TOPH :x] ; a: b (c b b)
+    [:sty vm.ST1H :x] ; y: a (c a b)
+  )
+  (vm:def :<rot ; (a b c -- b c a)
+    [:lda vm.TOP :x] ; a: c (a b c)
+    [:ldy vm.ST1 :x] ; y: b (a b c)
+    [:sta vm.ST1 :x] ; a: c (a c c)
+    [:lda vm.ST2 :x] ; a: a (a c c)
+    [:sta vm.TOP :x] ; a: a (a c a)
+    [:sty vm.ST2 :x] ; y: b (b c a)
+    [:lda vm.TOPH :x] ; a: c (a b c)
+    [:ldy vm.ST1H :x] ; y: b (a b c)
+    [:sta vm.ST1H :x] ; a: c (a c c)
+    [:lda vm.ST2H :x] ; a: a (a c c)
+    [:sta vm.TOPH :x] ; a: a (a c a)
+    [:sty vm.ST2H :x] ; y: b (b c a)
+  )
+
+  (vm:def :get
+    [:lda [vm.TOP :x]]
+    [:tay]
+    (inc16-stk vm.TOP vm.TOPH)
+    [:lda [vm.TOP :x]]
+    [:sta vm.TOPH :x]
+    [:sty vm.TOP :x])
+
+  (vm:def :set ; v p --
+    [:lda vm.ST1 :x]
+    [:sta [vm.TOP :x]]
+    (inc16-stk vm.TOP vm.TOPH)
+    [:lda vm.ST1H :x]
+    [:sta [vm.TOP :x]]
+    (vm:drop) (vm:drop))
+
+  (vm:def :bget ; p -- b
+    [:lda [vm.TOP :x]] [:sta vm.TOP :x]
+    [:lda 0] [:sta vm.TOPH :x])
+
+  (vm:def :bset ; b p --
+    [:lda vm.ST1 :x] [:sta [vm.TOP :x]]
+    (vm:drop) (vm:drop))
+
+  (vm:def :lit
+    (vm:reserve) [:ldy 0]
+    [:lda [vm.IP] :y] [:sta vm.TOP :x]
+    (inc16 vm.IP vm.IPH)
+    [:lda [vm.IP] :y] [:sta vm.TOPH :x]
+    (inc16 vm.IP vm.IPH))
+
+  (vm:def :>r ; v --
+    [:ldy vm.ROFF]
+    [:lda vm.TOP :x]  [:sta vm.RSTACK :y] [:iny]
+    [:lda vm.TOPH :x] [:sta vm.RSTACK :y] [:iny]
+    [:sty vm.ROFF]
+    (vm:drop))
+
+  (vm:def :r> ; -- v
+    (vm:reserve)
+    [:ldy vm.ROFF]
+    [:dey] [:lda vm.RSTACK :y] [:sta vm.TOPH :x]
+    [:dey] [:lda vm.RSTACK :y] [:sta vm.TOP :x]
+    [:sty vm.ROFF])
+
+  (vm:def :rtop ; -- v
+    (vm:reserve)
+    [:ldy vm.ROFF]
+    [:dey] [:lda vm.RSTACK :y] [:sta vm.TOPH :x]
+    [:dey] [:lda vm.RSTACK :y] [:sta vm.TOP :x])
+
+  (vm:def :rdrop
+    [:ldy vm.ROFF] [:dey] [:dey] [:sty vm.ROFF])
+
+  (vm:def :bz ; f --
+    [:block
+      [:lda vm.TOP :x]
+      [:bne :skip]
+      [:lda vm.TOPH :x]
+      [:beq :dojmp]
+     :skip
+      (vm:drop)
+      [:lda 2] (add16 vm.IP vm.IPH) (vm:ret)
+     :dojmp (vm:drop)]
+   :jmp
+    ; ugh I don't have enough registers for this; a (one-byte?) relative jump would maybe be better
+    [:ldy 0] [:lda [vm.IP] :y] [:sta vm.W]
+    [:iny] [:lda [vm.IP] :y] [:sta vm.IPH]
+    [:lda vm.W] [:sta vm.IP])
+
+  (fn vm.while [self preamble ...]
+    [:block
+      :start
+        [:vm (table.unpack preamble)]
+        [:ref :bz] [:ref :end]
+        [:vm ...]
+        [:ref :jmp] [:ref :start]
+      :end])
+
+  (fn vm.until [self ...]
+    [:block :start [:vm ...] [:ref :bz] [:ref :start]])
+
+  (fn vm.for [self ...]
+    [:vm :>r (vm:while [:rtop] :r> :dec :>r ...) :rdrop])
+
+  (vm:def :+ ; a b -- c
+    [:clc]
+    [:lda vm.ST1 :x] [:adc vm.TOP :x] [:sta vm.ST1 :x]
+    [:lda vm.ST1H :x] [:adc vm.TOPH :x] [:sta vm.ST1H :x]
+    (vm:drop))
+
+  (vm:def :- ; a b -- c
+    [:sec]
+    [:lda vm.ST1 :x] [:sbc vm.TOP :x] [:sta vm.ST1 :x]
+    [:lda vm.ST1H :x] [:sbc vm.TOPH :x] [:sta vm.ST1H :x]
+    (vm:drop))
+
+  (vm:def :inc ; a -- a+1
+    (inc16-stk vm.TOP vm.TOPH))
+
+  (vm:def :dec ; a -- a-1
+    [:block
+      [:lda vm.TOP :x]
+      [:bne :declow]
+      [:dec vm.TOPH :x]
+     :declow
+      [:dec vm.TOP :x]])
+
+  (vm:def :not ; f - !f
+    [:block
+      [:lda vm.TOP :x]
+      [:bne :zero]
+      [:lda vm.TOPH :x]
+      [:bne :zero]
+      [:lda 0xff] [:sta vm.TOP :x] [:sta vm.TOPH :x] (vm:ret)
+     :zero
+      [:lda 0] [:sta vm.TOP :x] [:sta vm.TOPH :x]])
+
+  (vm:def := ; a b -- f
+    [:block
+      [:lda vm.ST1 :x]
+      [:cmp vm.TOP :x]
+      [:bne :noteq]
+      [:lda vm.ST1H :x]
+      [:cmp vm.TOP :x]
+      [:bne :noteq]
+      [:lda 0xff] (vm:drop) [:sta vm.TOP :x] [:sta vm.TOPH :x] (vm:ret)
+     :noteq
+      [:lda 0] (vm:drop) [:sta vm.TOP :x] [:sta vm.TOPH :x]])
+  vm)
+
+{:new mk-vm}

wrap.fnl

@@ -1,5 +1,5 @@
 (require "lite")
-(require "util")
+(local util (require "util"))
 (local lume (require "lume"))
 (local imgui (require "imgui"))
 (local serial (require "serial"))
@@ -19,12 +19,12 @@
 })
 (command.add #(machine:connected?) {
   "honeylisp:upload" (fn []
-    (local p (reload "test"))
+    (local p (util.reload "neut"))
     (p:upload machine)
     (core.log (string.format "%x" (p:lookup-addr p.start-symbol))))
 })
 (command.add (fn [] true) {
-  "honeylisp:rebuild" #(reload "test")
+  "honeylisp:rebuild" #(util.reload "neut")
 })
 
 (fn selected-symbol []
@@ -52,11 +52,11 @@
         (: :gsub "^data%." "")
         (: :gsub "%.init$" "")))
     (core.log (.. "Hotswapping " modname))
-    (local (mod err) (lume.hotswap modname))
+    (local (mod err) (util.hotswap modname))
     (when (not= err nil) (print err) (error err)))
   "honeylisp:address" (fn []
     (local word (selected-symbol))
-    (local p (require "test"))
+    (local p (require "neut"))
     (core.log (string.format "%s %x" word (or (p:lookup-addr word) -1)))
   )
 })