non-working attempt to lazily expand macros using lua proxy objects

Unfortunately there is no way to override # in luajit, so I can't make
a truly transparent proxy. Unclear if I could get away with a weird
half-object, but it doesn't seem to be working.

asm/6502.fnl

@@ -0,0 +1,125 @@
+(local {: int8-to-bytes : int16-to-bytes} (require "lib.util"))
+
+(local opcodes {})
+
+; op mode arg
+; single-byte ops
+(let [ops
+      {:php 0x08 :plp 0x28 :pha 0x48 :pla 0x68 :dey 0x88 :tay 0xa8 :iny 0xc8 :inx 0xe8
+       :clc 0x18 :sec 0x38 :cli 0x58 :sei 0x78 :tya 0x98 :clv 0xb8 :cld 0xd8 :sed 0xf8
+       :txa 0x8a :txs 0x9a :tax 0xaa :tsx 0xba :dex 0xca :nop 0xea :rti 0x40 :rts 0x60}]
+  (each [opcode byte (pairs ops)]
+    (tset opcodes opcode (fn [mode] (if mode nil byte)))))
+(set opcodes.brk (fn [mode] (if (or (= mode :imm) (= mode nil)) 0x00 nil)))
+
+; branch ops
+(let [ops {:bpl 0x10 :bmi 0x30 :bvc 0x50 :bvs 0x70 :bcc 0x90 :bcs 0xb0 :bne 0xd0 :beq 0xf0}]
+  (each [opcode byte (pairs ops)]
+    (tset opcodes opcode (fn [mode] (if (= mode :rel) byte nil)))))
+(set opcodes.jsr (fn [mode] (if (= mode :abs) 0x20 nil)))
+
+; aaabbbcc ops
+(fn aaabbbcc [aaa cc modemap]
+  (local base (bit.bor cc (bit.lshift aaa 5)))
+  (fn [mode]
+    (local bbb (. modemap mode))
+    (if bbb (bit.bor base (bit.lshift bbb 2)) nil)))
+
+(fn indexed-modes [...]
+  (let [modemap {}]
+    (each [index mode (pairs [...])]
+      (tset modemap mode (- index 1)))
+    modemap))
+
+(fn without-modes [modemap ...]
+  (let [newmodemap (lume.clone modemap)]
+    (each [_ mode (pairs [...])]
+      (tset newmodemap mode nil))
+    newmodemap))
+
+(fn only-modes [modemap ...]
+  (let [newmodemap {}]
+    (each [_ mode (pairs [...])]
+      (tset newmodemap mode (. modemap mode)))
+    newmodemap))
+
+; cc=1 ops
+(let [cc1-modes (indexed-modes :zp-x* :zp :imm :abs :zp*-y :zp-x :abs-y :abs-x)
+      ops {:ora 0 :and 1 :eor 2 :adc 3 :lda 5 :cmp 6 :sbc 7}]
+  (each [opcode aaa (pairs ops)]
+    (tset opcodes opcode (aaabbbcc aaa 1 cc1-modes))
+  (tset opcodes :sta (aaabbbcc 4 1 (without-modes cc1-modes :imm)))))
+; cc=2 ops
+(let [cc2-modes (indexed-modes nil :zp :a :abs nil :zp-x nil :abs-x)]
+  (each [opcode aaa (pairs {:asl 0 :rol 1 :lsr 2 :ror 3})]
+    (tset opcodes opcode (aaabbbcc aaa 2 cc2-modes))
+  (each [opcode aaa (pairs {:dec 6 :inc 7})]
+    (tset opcodes opcode (aaabbbcc aaa 2 (without-modes cc2-modes :a))))))
+(tset opcodes :stx (aaabbbcc 4 2 (indexed-modes nil :zp nil :abs nil nil :zp-y)))
+(tset opcodes :ldx (aaabbbcc 5 2 (indexed-modes :imm :zp nil :abs nil nil :zp-y nil :abs-y)))
+
+; cc=0 ops
+(let [cc0-modes (indexed-modes :imm :zp nil :abs nil :zp-x nil :abs-x)]
+  (tset opcodes :bit (aaabbbcc 1 0 (only-modes cc0-modes :zp :abs)))
+  (tset opcodes :sty (aaabbbcc 4 0 (only-modes cc0-modes :zp :abs :zp-x)))
+  (tset opcodes :ldy (aaabbbcc 5 0 cc0-modes))
+  (each [opcode aaa (pairs {:cpy 6 :cpx 7})]
+    (tset opcodes opcode (aaabbbcc aaa 0 (only-modes cc0-modes :imm :zp :abs)))))
+(tset opcodes :jmp (fn [mode] (match mode :abs 0x4c :abs* 0x6c _ nil)))
+
+(fn parse-mode-arg [op]
+  (match op
+    [_ :a] [:a nil]
+    ([_ imm] ? (or (= (type imm) "number") (= (type imm) "function"))) [:imm imm]
+    ([opcode addr] ? (and (= (type addr) "string") (= (opcode:sub 1 1) "b"))) [:rel addr] ; branch
+    [_ addr :x] [:addr-x addr]
+    [_ [addr] :y] [:zp*-y addr]
+    [_ addr :y] [:addr-y addr]
+    [_ [addr :x]] [:zp-x* addr]
+    ([_ addr] ? (= (type addr) "string")) [:addr addr]
+    [_ [addr]] [:abs* addr]
+    [_] [nil nil]
+    _ (error (.. "Unrecognized syntax" (fv op)))))
+
+(local op-pdat {})
+
+(fn is-zp? [env name]
+  (match (env:lookup-org name)
+    org (< org 0x100)))
+
+(fn op-pdat.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) (is-zp? env op.arg))]
+      (set op.mode (if is-zp zp-mode abs-mode)))))
+
+(fn op-pdat.size [{: mode}]
+  (if
+    (or (= mode nil) (= mode :a)) 1
+    (= (mode:sub 1 3) :abs) 3
+    2))
+
+(fn op-pdat.bytes [op env]
+  (local bytegen (. opcodes op.opcode))
+;   (pp op)
+  (if bytegen
+    (let [opbyte (bytegen op.mode)
+          argbytes
+          (if
+            (and (= op.mode :imm) (= (type op.arg) "function"))
+            (int8-to-bytes (op.arg env))
+
+            (= op.mode :imm) (int8-to-bytes op.arg)
+            (= op.mode :rel)
+              (int8-to-bytes (- (env:lookup-addr op.arg) (+ op.addr 2)))
+            (= (op-pdat.size op) 2) (int8-to-bytes (env:lookup-addr op.arg))
+            (= (op-pdat.size op) 3) (int16-to-bytes (env:lookup-addr op.arg))
+            "")]
+      (if opbyte
+        (.. (int8-to-bytes opbyte) argbytes)
+        (error (.. op.opcode " doesn't support mode " op.mode))))
+    ""))
+
+
+{: opcodes : op-pdat : parse-mode-arg}

asm/65816.fnl

@@ -0,0 +1,146 @@
+(local {: int8-to-bytes : int16-to-bytes : int24-to-bytes} (require "lib.util"))
+
+(local opcodes {})
+
+; http://www.oxyron.de/html/opcodes816.html
+; The 65816 has an opcode for every possible byte. Rather than implementing any kind of tricky encoder logic, we just build a lookup table directly.
+(let [ops [[:brk nil]  [:ora :idx] [:cop :imm]  [:ora :sr]  [:tsb :dp]  [:ora :dp]  [:asl :dp]  [:ora :idl]  ; 0x00-0x07
+           [:php nil]  [:ora :imm] [:asl nil]   [:phd nil]  [:tsb :abs] [:ora :abs] [:asl :abs] [:ora :abl]  ; 0x08-0x0f
+           [:bpl :rel] [:ora :idy] [:ora :idp]  [:ora :isy] [:trb :dp]  [:ora :dpx] [:asl :dpx] [:ora :idly] ; 0x10-0x17
+           [:clc nil]  [:ora :aby] [:inc nil]   [:tcs nil]  [:trb :abs] [:ora :abx] [:asl :abx] [:ora :alx]  ; 0x18-0x1f
+           [:jsr :abs] [:and :idx] [:jsr :abl]  [:and :sr]  [:bit :dp]  [:and :dp]  [:rol :dp]  [:and :idl]  ; 0x20-0x27
+           [:plp nil]  [:and :imm] [:rol nil]   [:pld nil]  [:bit :abs] [:and :abs] [:rol :abs] [:and :abl]  ; 0x28-0x2f
+           [:bmi :rel] [:and :idy] [:and :idp]  [:and :isy] [:bit :dpx] [:and :dpx] [:rol :dpx] [:and :idly] ; 0x30-0x37
+           [:sec nil]  [:and :aby] [:dec nil]   [:tsc nil]  [:bit :abx] [:and :abx] [:rol :abx] [:and :alx]  ; 0x38-0x3f
+           [:rti nil]  [:eor :idx] [:wdm nil]   [:eor :sr]  [:mvp :bm]  [:eor :dp]  [:lsr :dp]  [:eor :idl]  ; 0x40-0x47
+           [:pha nil]  [:eor :imm] [:lsr nil]   [:phk nil]  [:jmp :abs] [:eor :abs] [:lsr :abs] [:eor :abl]  ; 0x48-0x4f
+           [:bvc :rel] [:eor :idy] [:eor :idp]  [:eor :isy] [:mvn :bm]  [:eor :dpx] [:lsr :dpx] [:eor :idly] ; 0x50-0x57
+           [:cli nil]  [:eor :aby] [:phy nil]   [:tcd nil]  [:jmp :abl] [:eor :abx] [:lsr :abx] [:eor :alx]  ; 0x58-0x5f
+           [:rts nil]  [:adc :idx] [:per :rell] [:adc :sr]  [:stz :dp]  [:adc :dp]  [:ror :zp]  [:adc :idl]  ; 0x60-0x67
+           [:pla nil]  [:adc :imm] [:ror nil]   [:rtl nil]  [:jmp :ind] [:adc :abs] [:ror :abs] [:adc :abl]  ; 0x68-0x6f
+           [:bvs :rel] [:adc :idy] [:adc :idp]  [:adc :isy] [:stz :dpx] [:adc :dpx] [:ror :zpx] [:adc :idly] ; 0x70-0x77
+           [:sei nil]  [:adc :aby] [:ply nil]   [:tdc nil]  [:jmp :iax] [:adc :abx] [:ror :abx] [:adc :alx]  ; 0x78-0x7f
+           [:bra :rel] [:sta :idx] [:brl :rell] [:sta :sr]  [:sty :dp]  [:sta :dp]  [:stx :dp]  [:sta :idl]  ; 0x80-0x87
+           [:dey nil]  [:bit :imm] [:txa nil]   [:phb nil]  [:sty :abs] [:sta :abs] [:stx :abs] [:sta :abl]  ; 0x88-0x8f
+           [:bcc :rel] [:sta :idy] [:sta :idp]  [:sta :isy] [:sty :dpx] [:sta :dpx] [:stx :dpy] [:sta :idly] ; 0x90-0x97
+           [:tya nil]  [:sta :aby] [:txs nil]   [:txy nil]  [:stz :abs] [:sta :abx] [:stz :abx] [:sta :alx]  ; 0x98-0x9f
+           [:ldy :imm] [:lda :idx] [:ldx :imm]  [:lda :sr]  [:ldy :dp]  [:lda :dp]  [:ldx :dp]  [:lda :idl]  ; 0xa0-0xa7
+           [:tay nil]  [:lda :imm] [:tax nil]   [:plb nil]  [:ldy :abs] [:lda :abs] [:ldx :abs] [:lda :abl]  ; 0xa8-0xaf
+           [:bcs :rel] [:lda :idy] [:lda :idp]  [:lda :isy] [:ldy :dpx] [:lda :dpx] [:ldx :dpy] [:lda :idly] ; 0xb0-0xb7
+           [:clv nil]  [:lda :aby] [:tsx nil]   [:tyx nil]  [:ldy :abx] [:lda :abx] [:ldx :aby] [:lda :alx]  ; 0xb8-0xbf
+           [:cpy :imm] [:cmp :idx] [:rep :imm]  [:cmp :sr]  [:cpy :dp]  [:cmp :dp]  [:dec :dp]  [:cmp :idl]  ; 0xc0-0xc7
+           [:iny nil]  [:cmp :imm] [:dex nil]   [:wai nil]  [:cpy :abs] [:cmp :abs] [:dec :abs] [:cmp :abl]  ; 0xc8-0xcf
+           [:bne :rel] [:cmp :idy] [:cmp :idp]  [:cmp :isy] [:pei :idp] [:cmp :dpx] [:dec :dpx] [:cmp :idly] ; 0xd0-0xd7
+           [:cld nil]  [:cmp :aby] [:phx nil]   [:stp nil]  [:jmp :ial] [:cmp :abx] [:dec :abx] [:cmp :alx]  ; 0xd8-0xdf
+           [:cpx :imm] [:sbc :idx] [:sep :imm]  [:sbc :sr]  [:cpx :dp]  [:sbc :dp]  [:inc :dp]  [:sbc :idl]  ; 0xe0-0xe7
+           [:inx nil]  [:sbc :imm] [:nop nil]   [:xba nil]  [:cpx :abs] [:sbc :abs] [:inc :abs] [:sbc :abl]  ; 0xe8-0xef
+           [:beq :rel] [:sbc :idy] [:sbc :idp]  [:sbc :isy] [:pea :imm] [:sbc :dpx] [:inc :dpx] [:sbc :idly] ; 0xf0-0xf7
+           [:sed nil]  [:sbc :aby] [:plx nil]   [:xce nil]  [:jsr :iax] [:sbc :abx] [:inc :abx] [:sbc :alx]  ; 0xf8-0xff
+          ]
+       mnemonic-to-modemap {}]
+  (each [iop [mnemonic mode] (ipairs ops)]
+    (when (= (. mnemonic-to-modemap mnemonic) nil)
+      (tset mnemonic-to-modemap mnemonic {}))
+    (tset mnemonic-to-modemap mnemonic (or mode :nil) (- iop 1)))
+  (each [mnemonic modemap (pairs mnemonic-to-modemap)]
+    (tset opcodes mnemonic (fn [mode] (. modemap (or mode :nil))))))
+(set opcodes.jsl #(when (= $1 :abl) 0x22)) ; allow forced long subroutine calls
+
+(fn dp-addr [addr]
+  (when (and (= (type addr) :string) (= (addr:sub 1 1) :d))
+    (tonumber (addr:sub 2))))
+(fn addr-parser [addr] (or (dp-addr addr) (tonumber addr)))
+
+(fn explicit-mode-arg [arg]
+  (var result nil)
+  (when (= (type arg) :table)
+    (each [mode arg (pairs arg)]
+      (when (= (type mode) :string)
+        (set result [mode arg]))))
+  result)
+
+(fn parse-mode-arg [op]
+  (match op
+    (where [_ arg] (explicit-mode-arg arg)) (explicit-mode-arg arg)
+    (where [mvx srcbank dstbank]
+           (= (type srcbank) :number) (= (type dstbank) :number) (= (mvx:sub 1 2) :mv))
+       [:bm [dstbank srcbank]] ; encoded backwards for some reason
+    [_ offset :s] [:sr offset]
+    [_ :#8 imm] [:imm8 imm]
+    (where [_ imm] (or (= (type imm) :number) (= (type imm) :function))) [:imm imm]
+    [_ [[addr]] :y] [:idly addr]
+    [_ [addr :s] :y] [:isy addr]
+    [_ [addr] :y] [:idy addr]
+    ; can tell ial / idl apart by the mnemonic
+    [:jmp [[addr]]] [:ial addr]
+    [_ [[addr]]] [:idl addr]
+    ; can tell iax / idx apart by the mnemonic
+    [:jmp [addr :x]] [:iax addr]
+    [:jsr [addr :x]] [:iax addr]
+    [_ [addr :x]] [:idx addr]
+    ; rell is the only valid mode for two mnemonics
+    [:per addr] [:rell addr]
+    [:brl addr] [:rell addr]
+    ; rel is the only valid mode for other branches
+    (where [br addr] (= (type addr) "string") (= (br:sub 1 1) "b") (not= br :bit)) [:rel addr]
+    (where [_ addr :x] (dp-addr addr)) [:dpx addr]
+    (where [_ addr :y] (dp-addr addr)) [:dpy addr]
+    (where [_ [addr]] (dp-addr addr)) [:idp addr]
+    (where [_ addr] (dp-addr addr)) [:dp addr]
+    [_ [addr]] [:ind addr]
+    [_ addr :y] [:aby addr]
+    [:jsl addr] [:abl addr] ; jsl is always long
+    ; we'll assume local bank for now and fix up bankswitching in :patch
+    [_ addr :x] [:abx addr]
+    [_ addr] [:abs addr]
+    [_] [nil nil]
+    _ (error (.. "Unrecognized syntax" (fv op)))))
+
+; abl = $000000
+; alx = $000000,X
+(local op-pdat {})
+(fn addr-page [addr] (math.floor (/ addr 0x10000)))
+(fn op-pdat.patch [op env]
+  (local long-mode (match op.mode :abs :abl :abx :alx))
+  (when (and long-mode
+             (not= (type op.arg) :function)
+             (not= (addr-page (env:lookup-org op.arg))
+                   (addr-page env.root-block.org)))
+    (set op.mode long-mode)))
+
+(fn op-pdat.size [op env]
+; TODO: handle 8-bit modes
+  (match op.mode
+    (where (or :sr :dp :dpx :dpy :idp :idx :idy :idl :idly :isy :rel)) 2
+    :imm8 2
+    :imm (match op.opcode
+           (where (or :cop :brk :sep :rep)) 2
+           _ 3)
+    (where (or :abs :abx :aby :ind :iax :rell :bm)) 3
+    (where (or :abl :alx :ial)) 4
+    nil 1
+    _ (error (.. "unknown mode " op.mode))))
+
+(fn op-pdat.bytes [op env]
+  (local bytegen (. opcodes op.opcode))
+  (if bytegen
+    (let [opbyte (bytegen (if (= op.mode :imm8) :imm op.mode))
+          arg (if (= (type op.arg) :function) (op.arg env) op.arg)
+          argbytes
+          (if
+            (or (= op.mode :sr) (= op.mode :isy) (= op.mode :imm8)) (int8-to-bytes arg)
+            (= op.mode :bm) (.. (int8-to-bytes (. arg 1)) (int8-to-bytes (. arg 2)))
+            (and (= op.mode :imm) (= (op-pdat.size op env) 3)) (int16-to-bytes arg)
+            (and (= op.mode :imm) (= (op-pdat.size op env) 2)) (int8-to-bytes arg)
+            (= op.mode :rel)  (int8-to-bytes (- (env:lookup-addr arg) (+ op.addr 2)))
+            (= op.mode :rell) (int16-to-bytes (- (env:lookup-addr arg) (+ op.addr 3)))
+            (= (op-pdat.size op env) 2) (int8-to-bytes (env:lookup-addr arg))
+            (= (op-pdat.size op env) 3) (int16-to-bytes (env:lookup-addr arg))
+            (= (op-pdat.size op env) 4) (int24-to-bytes (env:lookup-addr arg))
+            "")]
+      (if opbyte
+        (.. (int8-to-bytes opbyte) argbytes)
+        (error (.. op.opcode " doesn't support mode " op.mode))))
+    ""))
+
+{: opcodes : parse-mode-arg : op-pdat : addr-parser}

asm/asm.fnl

@@ -1,98 +1,16 @@
 (local lume (require "lib.lume"))
-(local {: int8-to-bytes : int16-to-bytes} (require "lib.util"))
+(local {: int8-to-bytes : int16-to-bytes : int24-to-bytes : int32-to-bytes} (require "lib.util"))
-(local opcodes {})
-
-; op mode arg
-; single-byte ops
-(let [ops
-      {:php 0x08 :plp 0x28 :pha 0x48 :pla 0x68 :dey 0x88 :tay 0xa8 :iny 0xc8 :inx 0xe8
-       :clc 0x18 :sec 0x38 :cli 0x58 :sei 0x78 :tya 0x98 :clv 0xb8 :cld 0xd8 :sed 0xf8
-       :txa 0x8a :txs 0x9a :tax 0xaa :tsx 0xba :dex 0xca :nop 0xea :rti 0x40 :rts 0x60}]
-  (each [opcode byte (pairs ops)]
-    (tset opcodes opcode (fn [mode] (if mode nil byte)))))
-(set opcodes.brk (fn [mode] (if (or (= mode :imm) (= mode nil)) 0x00 nil)))
-
-; branch ops
-(let [ops {:bpl 0x10 :bmi 0x30 :bvc 0x50 :bvs 0x70 :bcc 0x90 :bcs 0xb0 :bne 0xd0 :beq 0xf0}]
-  (each [opcode byte (pairs ops)]
-    (tset opcodes opcode (fn [mode] (if (= mode :rel) byte nil)))))
-(set opcodes.jsr (fn [mode] (if (= mode :abs) 0x20 nil)))
-
-; aaabbbcc ops
-(fn aaabbbcc [aaa cc modemap]
-  (local base (bit.bor cc (bit.lshift aaa 5)))
-  (fn [mode]
-    (local bbb (. modemap mode))
-    (if bbb (bit.bor base (bit.lshift bbb 2)) nil)))
-
-(fn indexed-modes [...]
-  (let [modemap {}]
-    (each [index mode (pairs [...])]
-      (tset modemap mode (- index 1)))
-    modemap))
-
-(fn without-modes [modemap ...]
-  (let [newmodemap (lume.clone modemap)]
-    (each [_ mode (pairs [...])]
-      (tset newmodemap mode nil))
-    newmodemap))
-
-(fn only-modes [modemap ...]
-  (let [newmodemap {}]
-    (each [_ mode (pairs [...])]
-      (tset newmodemap mode (. modemap mode)))
-    newmodemap))
-
-; cc=1 ops
-(let [cc1-modes (indexed-modes :zp-x* :zp :imm :abs :zp*-y :zp-x :abs-y :abs-x)
-      ops {:ora 0 :and 1 :eor 2 :adc 3 :lda 5 :cmp 6 :sbc 7}]
-  (each [opcode aaa (pairs ops)]
-    (tset opcodes opcode (aaabbbcc aaa 1 cc1-modes))
-  (tset opcodes :sta (aaabbbcc 4 1 (without-modes cc1-modes :imm)))))
-; cc=2 ops
-(let [cc2-modes (indexed-modes nil :zp :a :abs nil :zp-x nil :abs-x)]
-  (each [opcode aaa (pairs {:asl 0 :rol 1 :lsr 2 :ror 3})]
-    (tset opcodes opcode (aaabbbcc aaa 2 cc2-modes))
-  (each [opcode aaa (pairs {:dec 6 :inc 7})]
-    (tset opcodes opcode (aaabbbcc aaa 2 (without-modes cc2-modes :a))))))
-(tset opcodes :stx (aaabbbcc 4 2 (indexed-modes nil :zp nil :abs nil nil :zp-y)))
-(tset opcodes :ldx (aaabbbcc 5 2 (indexed-modes :imm :zp nil :abs nil nil :zp-y nil :abs-y)))
-
-; cc=0 ops
-(let [cc0-modes (indexed-modes :imm :zp nil :abs nil :zp-x nil :abs-x)]
-  (tset opcodes :bit (aaabbbcc 1 0 (only-modes cc0-modes :zp :abs)))
-  (tset opcodes :sty (aaabbbcc 4 0 (only-modes cc0-modes :zp :abs :zp-x)))
-  (tset opcodes :ldy (aaabbbcc 5 0 cc0-modes))
-  (each [opcode aaa (pairs {:cpy 6 :cpx 7})]
-    (tset opcodes opcode (aaabbbcc aaa 0 (only-modes cc0-modes :imm :zp :abs)))))
-(tset opcodes :jmp (fn [mode] (match mode :abs 0x4c :abs* 0x6c _ nil)))
-
-(fn size [mode]
-  (if
-    (or (= mode nil) (= mode :a)) 1
-    (= (mode:sub 1 3) :abs) 3
-    2))
-(fn opsize [op] (if (= op.opcode :block) 0 (size op.mode)))
-
-(fn parse-mode-arg [op]
-  (match op
-    [_ :a] [:a nil]
-    ([_ imm] ? (or (= (type imm) "number") (= (type imm) "function"))) [:imm imm]
-    ([opcode addr] ? (and (= (type addr) "string") (= (opcode:sub 1 1) "b"))) [:rel addr] ; branch
-    [_ addr :x] [:addr-x addr]
-    [_ [addr] :y] [:zp*-y addr]
-    [_ addr :y] [:addr-y addr]
-    [_ [addr :x]] [:zp-x* addr]
-    ([_ addr] ? (= (type addr) "string")) [:addr addr]
-    [_ [addr]] [:abs* addr]
-    [_] [nil nil]
-    _ (error (.. "Unrecognized syntax" (fv op)))))
 
 (fn make-env [block parent]
   {:parent parent
+   :prg (or parent.prg parent)
+   :root-block (or parent.root-block block)
    :block block
-   ; todo: support local self-reference if org is set to zp
+   :lookup-org
-   :is-zp? (fn [self name] (if (. self.block.symbols name) false (self.parent:is-zp? name)))
+   (fn [self name]
+     (if (or (. self.block.symbols name) (. self.block.globals name))
+       self.root-block.org
+       (self.parent:lookup-org name)))
    :lookup-addr
    (fn [self name]
      (local ipdat (. self.block.symbols name))
@@ -110,7 +28,8 @@
 
        (self.parent:lookup-addr name)))})
 
-(fn program [prg-base]
+(fn program [prg-base ?processor]
+  (local {: opcodes : op-pdat : parse-mode-arg : addr-parser} (require (.. :asm. (or ?processor :6502))))
   ; 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 ...}
@@ -130,11 +49,14 @@
 
         (let [opcode (. dat 1)
               parser (. dat-parser opcode)
+              meta (getmetatable dat)
               pdat
               (if parser (parser dat block)
                   (. opcodes opcode) (dat-parser.op dat)
                   (error (.. "Unrecognized opcode " (fv opcode))))]
           (when pdat
+            (when meta (set block.last-meta meta))
+            (set pdat.meta block.last-meta)
             (set pdat.nearest-symbol block.last-symbol)
             (table.insert block.pdats pdat)
             (when pdat.globals
@@ -154,10 +76,11 @@
       (table.remove dats 1)
       (parse-dats (new-block block.last-symbol) dats)))
 
-  (fn dat-parser.db [db]       {:type :var :init (. db 2) :size 1})
+  (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.dw [dw]           {:type :var :init (. dw 2) :size 2})
-  (fn dat-parser.bytes [bytes] {:type :raw :bytes (. bytes 2)})
+  (fn dat-parser.dl [dl]           {:type :var :init (. dl 2) :size 4})
-  (fn dat-parser.ref [ref]     {:type :ref :target (. ref 2)})
+  (fn dat-parser.bytes [[_ bytes]] {:type :raw :bytes (if (= (type bytes) :table) (string.char (table.unpack bytes)) bytes)})
+  (fn dat-parser.ref [ref]         {:type :ref :target (. ref 2)})
   (fn dat-parser.flatten [flat block]
     (parse-dats block (lume.slice flat 2))
     nil)
@@ -169,6 +92,7 @@
     nil)
 
   (fn dat-parser.align [pad] {:type :pad :align (. pad 2)})
+  (fn dat-parser.meta [[_ f]] {:type :meta :bytes "" :size 0 : f})
   (fn dat-parser.hot-preserve [[_ label & dats] block]
     (let [preserve-block (new-block)]
       (tset block.preserved label preserve-block)
@@ -178,56 +102,33 @@
       preserve-block))
 
   (local pdat-processor {
-    :op {}
+    :op op-pdat
     :var {}
     :ref {}
     :raw {}
     :block {}
     :pad {}
+    :meta {}
   })
 
+  (fn describe-pdat [pdat]
+    (if pdat.meta (.. pdat.meta.filename "@" pdat.meta.line)
+      (.. (or pdat.nearest-symbol "<start of block>") " @" (or pdat.addr "<no address>"))))
+
   (fn process-pdat [pdat process default ...]
     (fn complain [ok ...]
       (if ok (values ...)
-          (do (error (.. process " failed in " pdat.type " near " (or pdat.nearest-symbol "<start of block>") " @" (or pdat.addr "<no address>") " - " ...)))))
+          (do (error (.. process " failed in " pdat.type " near " (describe-pdat pdat) " - " ...)))))
     (local processor (. pdat-processor pdat.type process))
     (if processor (complain (pcall #(processor pdat $...) ...)) default))
 
-  (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.op.size [op] (size op.mode))
   (fn pdat-processor.var.size [d] d.size)
   (fn pdat-processor.ref.size [r] 2)
   (fn pdat-processor.pad.size [pad]
     (let [misalignment (% pad.addr pad.align)]
       (if (= misalignment 0) 0
         (- pad.align misalignment))))
-  (fn pdat-processor.op.bytes [op env]
-    (local bytegen (. opcodes op.opcode))
-  ;   (pp op)
-    (if bytegen
-      (let [opbyte (bytegen op.mode)
-            argbytes
-            (if
-              (and (= op.mode :imm) (= (type op.arg) "function"))
-              (int8-to-bytes (op.arg env))
-
-              (= op.mode :imm) (int8-to-bytes op.arg)
-              (= op.mode :rel)
-                (int8-to-bytes (- (env:lookup-addr op.arg) (+ op.addr 2)))
-              (= (size op.mode) 2) (int8-to-bytes (env:lookup-addr op.arg))
-              (= (size op.mode) 3) (int16-to-bytes (env:lookup-addr op.arg))
-              "")]
-        (if opbyte
-          (.. (int8-to-bytes opbyte) argbytes)
-          (error (.. op.opcode " doesn't support mode " op.mode))))
-      ""))
   (fn pdat-processor.var.bytes [d env]
     (local init (match (type d.init)
                   :number d.init
@@ -236,11 +137,14 @@
     (match d.size
       1 (int8-to-bytes init)
       2 (int16-to-bytes init)
+      3 (int24-to-bytes init)
+      4 (int32-to-bytes init)
       n (string.rep "\0" n)))
   (fn pdat-processor.ref.bytes [ref env]
     (int16-to-bytes (env:lookup-addr ref.target)))
 
   (fn pdat-processor.pad.bytes [pad] (string.rep "\0" pad.size))
+  (fn pdat-processor.meta.generate [{: f : addr} env] (f addr env))
   (fn pdat-processor.block.symbols [block]
     (lume.concat (lume.keys block.symbols) (lume.keys block.globals)))
 
@@ -297,7 +201,8 @@
      (var block (. self.org-to-block org))
      (when (not block)
        (set block (new-block))
-       (tset self.org-to-block org block))
+       (tset self.org-to-block org block)
+       (set block.org org))
      {: block
       : org
       :prg self
@@ -305,14 +210,8 @@
       :append (fn [self ...] (self.prg:dbg self.org ...) (parse-dats self.block [...]) self)})
    :parse-addr
    (fn [self name]
-     (local addr (tonumber name))
+     (local addr ((or addr-parser tonumber) name))
      (if addr addr (error (.. "Symbol '" name "' not found"))))
-   :is-zp?
-   (fn [self name]
-     (local org (. self.symbol-to-org name))
-     (if org (< org 0x100)
-         self.prg-base (self.prg-base:is-zp? name)
-       (< (self:parse-addr name) 0x100)))
    :env-lookup
    (fn [self name lookup ...]
      (local org (. self.symbol-to-org name))
@@ -324,6 +223,9 @@
    (fn [self name]
 ;       (print "looking up" name "in" self)
       (or (self:env-lookup name :lookup-addr) (self:parse-addr name)))
+   :lookup-org
+   (fn [self name]
+     (or (self:env-lookup name :lookup-org) (self:parse-addr name)))
    :pass
    (fn [self passname]
      (print passname)
@@ -349,15 +251,16 @@
        (set self.dbgfile nil))
      self)
    :read-hotswap
-   (fn [self machine]
+   (fn [self machine prg-new]
      (let [addr-to-label {}
            addr-to-size {}]
        (each [_ block (pairs self.org-to-block)]
          (each [label pdat (pairs block.preserved)]
            (tset addr-to-label pdat.addr label)
            (tset addr-to-size pdat.addr pdat.size)))
-       (collect [addr bytes (pairs (machine:read-batch addr-to-size))]
+       (lume.merge (collect [addr bytes (pairs (machine:read-batch addr-to-size))]
-         (values (. addr-to-label addr) bytes))))
+                     (values (. addr-to-label addr) bytes))
+                   (if (?. self.source :read-hotswap) (self.source:read-hotswap machine prg-new) {}))))
    :write-hotswap
    (fn [self machine hotswap]
      (machine:write-batch

editor/gfxedit.fnl

@@ -20,7 +20,6 @@
 (fn GraphicsEditView.get_scrollable_size [self] self.scrollheight)
 (fn GraphicsEditView.resource-key [self] :tiles)
 (fn GraphicsEditView.tilesize [self] (values 16 16))
-(fn GraphicsEditView.tilebytelen [self] (let [(w h) (self:tilesize)] (/ (* w h) 8)))
 (fn GraphicsEditView.reload [self] (files.reload))
 (fn GraphicsEditView.save [self] (files.save))
 
@@ -30,13 +29,16 @@
     (when (>= itile 1) (set self.itile itile))))
 
 (fn GraphicsEditView.draw-sprite [self x y itile ?key]
-  (love.graphics.draw (self.tilecache:sprite itile ?key) x y 0 self.sprite-scale self.sprite-scale))
+  (let [sprite (self.tilecache:sprite itile ?key)]
+    (when sprite
+      (love.graphics.setColor 1 1 1)
+      (love.graphics.draw sprite x y 0 self.sprite-scale self.sprite-scale))))
 
 (fn GraphicsEditView.draw-tile-selector [self x y w ?key]
   (var tilex x)
   (var tiley y)
   (var (pixw pixh) (self:tilesize))
-  (set pixw (* (/ pixw 8) 7))
+  (when (= files.game.platform :ii) (set pixw (* (/ pixw 8) 7)))
   (local tilew (* self.sprite-scale pixw))
   (local tileh (* self.sprite-scale pixh))
   (for [itile 1 (length self.tilecache.tiles)]

editor/mapedit.fnl

@@ -10,10 +10,16 @@
 
 (local MapEditView (GraphicsEditView:extend))
 (local sprite-scale 3)
-(local mapw 20)
+
-(local maph 12)
+(local platforms {
-(local tilew (* sprite-scale 14))
+  :ii   {:mapw 20 :maph 12 :tilew 14 :tileh 16}
-(local tileh (* sprite-scale 16))
+  :iigs {:mapw 20 :maph 12 :tilew 16 :tileh 16}
+})
+
+(local platform (. platforms (files.platform)))
+(local {: mapw : maph} platform)
+(local tilew (* sprite-scale platform.tilew))
+(local tileh (* sprite-scale platform.tileh))
 
 (fn MapEditView.new [self]
   (MapEditView.super.new self)
@@ -60,10 +66,15 @@
   (when (. objects (+ iobjectsrc 1))
     (move-object objects (+ iobjectsrc 1) iobjectsrc)))
 
+(fn MapEditView.levels [self]
+  (when (= files.game.levels nil)
+    (set files.game.levels []))
+  files.game.levels)
+
 (fn MapEditView.draw-map-selector [self x y]
   (renderer.draw_text style.font "Map" x (+ y (/ style.padding.y 2)) style.text)
   (let [options {}
-        level-count (length files.game.levels)
+        level-count (length (self:levels))
         _ (do (for [i 1 level-count] (tset options i i))
               (table.insert options :New))
         (ilevel yNext) (dropdown self :map-selector self.ilevel options (+ x (* 50 SCALE)) y (* 100 SCALE))]
@@ -222,9 +233,9 @@
 
 (fn MapEditView.load-level [self]
   (set self.stripcache {})
-  (when (= (. files.game.levels self.ilevel) nil)
+  (when (= (. (self:levels) self.ilevel) nil)
-    (tset files.game.levels self.ilevel {:map (string.rep "\0" (* mapw maph)) :objects []}))
+    (tset (self:levels) self.ilevel {:map (string.rep "\0" (* mapw maph)) :objects []}))
-  (set self.level (. files.game.levels self.ilevel))
+  (set self.level (. (self:levels) self.ilevel))
   (set self.iobject nil))
 
 (fn MapEditView.reload [self]

editor/replview.fnl

@@ -1,5 +1,5 @@
 (local util (require :lib.util))
-(local {: attach-imstate : textbox} (util.require :editor.imstate))
+(local {: attach-imstate : textbox : textbutton : mouse-inside} (util.require :editor.imstate))
 (local View (require :core.view))
 (local style (require :core.style))
 
@@ -24,8 +24,14 @@
 (fn ReplView.append [self line]
   (table.insert self.log line))
 
-(fn ReplView.draw-cmd [{: cmd} view x y]
+(fn ReplView.draw-cmd [{: cmd} view x y iline]
   (renderer.draw_text style.font cmd x y style.text)
+  (when (mouse-inside x y view.size.x (style.font:get_height))
+    (when (textbutton view :X (+ x view.size.x -35) y)
+      (table.remove view.log iline)
+      (table.remove view.log iline))
+    (when (textbutton view :! (+ x view.size.x -60) y)
+      (view:submit cmd)))
   (+ (style.font:get_height) style.padding.y))
 
 (fn ReplView.submit [self ?cmd]
@@ -46,7 +52,7 @@
   ; note: then offscreen items can't be focussed without further effort
   ; todo: draw line numbers
   (each [i line (ipairs self.log)]
-    (let [h (line:draw self x y)]
+    (let [h (line:draw self x y i)]
       (set y (+ y h))
       (set rendered-h (+ rendered-h h))))
 

editor/tiledraw/ii.fnl

@@ -1,3 +1,5 @@
+(local {: putpixel : make-canvas} (require :editor.tiledraw))
+
 (fn pal-from-bit [bit]
   (if bit
     (values [20 207 253] [255 106 60])
@@ -6,25 +8,6 @@
 (fn pal-from-byte [byte]
   (pal-from-bit (not= 0 (bit.band byte 0x80))))
 
-(fn putpixel [x y color]
-  (when color
-    (love.graphics.setColor (/ (. color 1) 255) (/ (. color 2) 255) (/ (. color 3) 255))
-    (love.graphics.points (+ x 0.5) (+ y 0.5))))
-
-(fn make-canvas [w h f]
-  (local canvas (love.graphics.newCanvas w h))
-  (local prevcanvas (love.graphics.getCanvas))
-  (canvas:setFilter :nearest :nearest)
-  (local scissor [(love.graphics.getScissor)])
-  (love.graphics.setScissor)
-  (love.graphics.setCanvas canvas)
-  (love.graphics.clear 0 0 0)
-  (f canvas)
-  (love.graphics.setCanvas prevcanvas)
-  (love.graphics.setScissor (table.unpack scissor))
-  (love.graphics.setColor 1 1 1 1)
-  canvas)
-
 (fn draw-byte [bytes ibyte xoffset y ?state ?prevpal]
   (local byte (string.byte (bytes:sub ibyte ibyte)))
   (var prevstate nil)
@@ -105,32 +88,5 @@
       (for [y 0 7]
         (draw-byte gfx (+ y 1) 0 y))))))
 
-(fn TileCache [tiles ?spritegen]
+{: tile-to-sprite : char-to-sprite : portrait-to-sprite : screen-to-sprite : scanline-to-sprite : screen-y-to-offset
-  {: tiles
+ : tilestrip-to-sprite : pal-from-bit : pal-from-byte : draw-byte}
-   :spritegen (or ?spritegen tile-to-sprite)
-   :tilesprites []
-   :tile (fn [self itile] (or (. self.tiles itile) {:flags {}}))
-   :cachekey (fn [itile ?key] (.. (or ?key :gfx) itile))
-   :update-tile
-   (fn [self itile tile ?key]
-     (tset self.tiles itile
-       (-> (self:tile itile)
-         (doto (tset (or ?key :gfx) tile))))
-     (tset self.tilesprites (self.cachekey itile ?key) nil))
-   :set-flag
-   (fn [self itile flag clear]
-     (tset (. self.tiles itile :flags) flag (if clear nil true)))
-   :load
-   (fn [self tiles]
-     (set self.tiles tiles)
-     (set self.tilesprites []))
-   :sprite
-   (fn [self itile ?key]
-     (local key (self.cachekey itile ?key))
-     (when (and (= nil (. self.tilesprites key)) (not= nil (. self.tiles itile)))
-       (tset self.tilesprites key (self.spritegen (. self.tiles itile (or ?key :gfx)))))
-     (. self.tilesprites key))})
-
-{: tile-to-sprite : tilestrip-to-sprite : portrait-to-sprite : char-to-sprite : scanline-to-sprite
- : screen-y-to-offset : pal-from-bit : pal-from-byte : TileCache : make-canvas : draw-byte}
-

editor/tiledraw/iigs.fnl

@@ -0,0 +1,21 @@
+(local {: putpixel : make-canvas} (require :editor.tiledraw))
+
+; converted from http://pixeljoint.com/forum/forum_posts.asp?TID=12795 (db16)
+; maybe check out https://lospec.com/palette-list ?
+(local pal [[1 0 1]  [4 2 3]  [3 3 6]  [4 4 4]  [8 4 3]   [3 6 2]   [13 4 4]  [7 7 6]
+            [5 7 12] [13 7 2] [8 9 10] [6 10 2] [13 10 9] [6 12 12] [13 13 5] [13 14 13]])
+(fn gs-to-rgb [color] (icollect [_ v (ipairs color)] (* v 0x11)))
+
+(fn tile-to-sprite [tile]
+  (if tile (make-canvas 16 16 (fn [canvas]
+    (love.graphics.clear 0 0 0 0)
+    (for [y 0 15]
+      (for [x 0 15]
+        (let [ibyte (+ (* y 16) x 1)
+              byte (string.byte (tile:sub ibyte ibyte))
+              mask (bit.band (bit.rshift byte 4) 0xf)
+              color (bit.band byte 0xf)
+              rgb (if (= mask 0) (gs-to-rgb (. pal (+ color 1))) [255 0 255])]
+          (when (= mask 0) (putpixel x y rgb)))))))))
+
+{: tile-to-sprite : pal : gs-to-rgb}

editor/tiledraw/init.fnl

@@ -0,0 +1,60 @@
+(local files (require :game.files))
+(local TileDraw {})
+
+(fn TileDraw.putpixel [x y color]
+  (when color
+    (love.graphics.setColor (/ (. color 1) 255) (/ (. color 2) 255) (/ (. color 3) 255))
+    (love.graphics.points (+ x 0.5) (+ y 0.5))))
+
+(fn TileDraw.make-canvas [w h f]
+  (local canvas (love.graphics.newCanvas w h))
+  (local prevcanvas (love.graphics.getCanvas))
+  (canvas:setFilter :nearest :nearest)
+  (local scissor [(love.graphics.getScissor)])
+  (love.graphics.setScissor)
+  (love.graphics.setCanvas canvas)
+  (love.graphics.clear 0 0 0)
+  (f canvas)
+  (love.graphics.setCanvas prevcanvas)
+  (love.graphics.setScissor (table.unpack scissor))
+  (love.graphics.setColor 1 1 1 1)
+  canvas)
+
+(files.platform-methods TileDraw :editor.tiledraw
+  :tile-to-sprite :char-to-sprite :portrait-to-sprite :screen-to-sprite :screen-y-to-offset
+  :pal-from-bit :pal-from-byte :draw-byte)
+
+(files.default-platform-method TileDraw :editor.tiledraw :tilestrip-to-sprite
+  (fn [tiles]
+    (let [sprites (icollect [_ tile (ipairs tiles)] (TileDraw.tile-to-sprite tile))]
+      (TileDraw.make-canvas (* (: (. sprites 1) :getWidth) (length sprites)) (: (. sprites 1) :getHeight)
+        #(each [isprite sprite (ipairs sprites)]
+          (love.graphics.draw sprite (* (sprite:getWidth) (- isprite 1)) 0))))))
+
+(fn TileDraw.TileCache [tiles ?spritegen]
+  {: tiles
+   :spritegen (or ?spritegen TileDraw.tile-to-sprite)
+   :tilesprites []
+   :tile (fn [self itile] (or (. self.tiles itile) {:flags {}}))
+   :cachekey (fn [itile ?key] (.. (or ?key :gfx) itile))
+   :update-tile
+   (fn [self itile tile ?key]
+     (tset self.tiles itile
+       (-> (self:tile itile)
+         (doto (tset (or ?key :gfx) tile))))
+     (tset self.tilesprites (self.cachekey itile ?key) nil))
+   :set-flag
+   (fn [self itile flag clear]
+     (tset (. self.tiles itile :flags) flag (if clear nil true)))
+   :load
+   (fn [self tiles]
+     (set self.tiles tiles)
+     (set self.tilesprites []))
+   :sprite
+   (fn [self itile ?key]
+     (local key (self.cachekey itile ?key))
+     (when (and (= nil (. self.tilesprites key)) (not= nil (. self.tiles itile)))
+       (tset self.tilesprites key (self.spritegen (. self.tiles itile (or ?key :gfx)))))
+     (. self.tilesprites key))})
+
+TileDraw

editor/tileedit/ii.fnl

@@ -0,0 +1,20 @@
+(local tiledraw (require :editor.tiledraw))
+
+{:map-bitxy (fn [self x y]
+  (when (and (>= x 0) (< x 16) (>= y 0) (< y 16))
+    (local ibyte (if (< x 8) y (+ y 16)))
+    (local ibit
+      (if (= x 0) 7
+          (< x 8) (- x 1)
+                  (- x 8)))
+    (values ibyte ibit 1)))
+ :pixel-color (fn [self b _ ibit]
+   (if (= ibit 7) (tiledraw.pal-from-bit (= b 1))
+       (= b 1)    [255 255 255]
+                  [0 0 0]))
+ :draw-off  (fn [self]   (set self.bit nil))
+ :draw-on   (fn [self b] (when (= self.bit nil) (set self.bit (if (= b 1) 0 1))))
+ :draw-bits (fn [self] self.bit)
+ :pixel-storage-divisor #8
+}
+

editor/tileedit/iigs.fnl

@@ -0,0 +1,12 @@
+(local {: pal : gs-to-rgb} (require :editor.tiledraw.iigs))
+(local lume (require :lib.lume))
+
+{:map-bitxy (fn [self x y] (values (+ (* y 16) x) 0 0xff))
+ :pixel-color (fn [self b] (match b 0xf0 (values [128 128 128] [64 64 64])
+                                  _ (gs-to-rgb (. pal (+ b 1)))))
+ :draw-bits #(if (= $1.icolor 17) 0xf0 (- $1.icolor 1))
+ :palette #(lume.concat (icollect [_ color (ipairs pal)] (gs-to-rgb color)) [[255 0 255]])
+ :pixel-storage-divisor #1
+ :preview-locations #[[8 0] [0 5] [16 5] [8 10]]
+}
+

editor/tileedit/init.fnl

@@ -2,72 +2,67 @@
 (local style (require :core.style))
 (local tiles (require :game.tiles))
 (local files (require :game.files))
-(local tiledraw (require :editor.tiledraw))
 (local util (require :lib.util))
-(local {: mouse-inside : activate : active? : checkbox : textfield} (util.require :editor.imstate))
+(local {: mouse-inside : activate : active? : checkbox : textfield : button} (util.require :editor.imstate))
 
 (local TileView (GraphicsEditView:extend))
 
 (set TileView.pixel-size 24)
 (local pixel-size TileView.pixel-size)
 
-(fn TileView.map-bitxy [self x y]
-  (when (and (>= x 0) (< x 16) (>= y 0) (< y 16))
-    (local ibyte (if (< x 8) y (+ y 16)))
-    (local ibit
-      (if (= x 0) 7
-          (< x 8) (- x 1)
-                  (- x 8)))
-    (values ibyte ibit)))
-
 (fn TileView.tilesize [self] (values 16 16))
 (fn TileView.tilekeys [self]
   (if files.game.tilesets (icollect [_ key (pairs files.game.tilesets)] key)
     [:gfx]))
+(fn TileView.tilebytelen [self] (let [(w h) (self:tilesize)] (/ (* w h) (self:pixel-storage-divisor))))
 
 (fn get-byte [tile ibyte]
-  (: (tile:sub (+ ibyte 1) (+ ibyte 1)) :byte))
+  (or (: (tile:sub (+ ibyte 1) (+ ibyte 1)) :byte) 0))
-(fn get-bit [tile ibyte ibit]
+(fn get-bits [tile ibyte ibit mask]
-  (not= 0 (bit.band (get-byte tile ibyte) (bit.lshift 1 ibit))))
+  (-> (get-byte tile ibyte)
-(fn set-bit [tile ibyte ibit is-set]
+      (bit.band (bit.lshift mask ibit))
-  (local orval (bit.lshift 1 ibit))
+      (bit.rshift ibit)))
+(fn set-bits [tile ibyte ibit mask bits]
+  (local orval (bit.lshift mask ibit))
   (-> (get-byte tile ibyte)
     (bit.band (bit.bnot orval))
-    (bit.bor (if is-set orval 0))))
+    (bit.bor (bit.lshift bits ibit))))
 
-(fn set-tile-bit [tile ibyte ibit is-set]
+(fn set-tile-bits [tile ibyte ibit mask bits]
-  (util.splice tile ibyte (string.char (set-bit tile ibyte ibit is-set))))
+  (util.splice tile ibyte (string.char (set-bits tile ibyte ibit mask bits))))
 
-(fn draw-bit-color [bit x y]
+(files.platform-methods TileView :editor.tileedit :map-bitxy :pixel-color :draw-on :draw-off :draw-bits
-  (local (bgcolor color) (tiledraw.pal-from-bit bit))
+  :palette :pixel-storage-divisor)
-  (renderer.draw_rect x y pixel-size pixel-size bgcolor)
-  (renderer.draw_rect (+ x 3) (+ y 3) (- pixel-size 6) (- pixel-size 6) color))
 
-(fn draw-bit [bit x y even]
+(files.default-platform-method TileView :editor.tileedit :preview-locations
-  (renderer.draw_rect x y pixel-size pixel-size (if bit [255 255 255] [0 0 0])))
+  (fn [self] (let [(w h) (self:tilesize)] [[0 0] [w 0] [0 h] [w h]])))
 
 (fn TileView.tile [self]
   (local (w h) (self:tilesize))
-  (or (-?> self.tilecache.tiles (. self.itile) (. (or self.tilekey :gfx))) (string.rep "\0" (/ (* w h) 8))))
+  (or (-?> self.tilecache.tiles (. self.itile) (. (or self.tilekey :gfx)))
+      (string.rep "\0" (/ (* w h) (self:pixel-storage-divisor)))))
+
+(fn TileView.draw-pixel [self x y colorbg ?colorfg]
+  (renderer.draw_rect x y pixel-size pixel-size colorbg)
+  (when ?colorfg (renderer.draw_rect (+ x 3) (+ y 3) (- pixel-size 6) (- pixel-size 6) ?colorfg)))
 
 (fn TileView.draw-tile-editor [self tile x y]
-  (when (not (active? self :tile))
+  (when (not (active? self :tile)) (self:draw-off))
-    (set self.bit nil))
   (local (w h) (self:tilesize))
   (local editor-w (* (+ pixel-size 1) w))
   (local editor-h (* (+ pixel-size 1) h))
   (activate self :tile x y editor-w editor-h)
   (for [bitx 0 (- w 1)] (for [bity 0 (- h 1)]
-    (local (ibyte ibit) (self:map-bitxy bitx bity))
+    (local (ibyte ibit mask) (self:map-bitxy bitx bity))
-    (local b (get-bit tile ibyte ibit))
+    (local b (get-bits tile ibyte ibit mask))
     (local (px py) (values (+ x (* bitx (+ pixel-size 1))) (+ y (* bity (+ pixel-size 1)))))
-    (if (= ibit 7)
+    (local (colorbg colorfg) (self:pixel-color b ibyte ibit))
-      (draw-bit-color b px py)
+    (self:draw-pixel px py colorbg colorfg)
-      (draw-bit b px py (= (% bitx 2) 1)))
     (when (and (active? self :tile) (mouse-inside px py pixel-size pixel-size))
-      (when (= self.bit nil) (set self.bit (not b)))
+      (self:draw-on b)
-      (when (not= self.bit b)
+      (local bits (self:draw-bits))
-        (self:update-tile (set-tile-bit tile ibyte ibit self.bit))))))
+      (when (not= bits b)
+        (self:update-tile (set-tile-bits tile ibyte ibit mask bits))))))
   (love.graphics.setColor 1 1 1 1)
   (values editor-w editor-h))
 
@@ -85,7 +80,31 @@
     (set (tile.word y) (textfield self "Default word" tile.word x (+ y style.padding.y) (* 100 SCALE) (* 200 SCALE)))
     (set (tile.label y) (textfield self "Label" tile.label x (+ y style.padding.y) (* 100 SCALE) (* 200 SCALE))))
   (each [iflag flagname (ipairs (tiles.flags))]
-    (set y (self:draw-tile-flag flagname x (+ y style.padding.y)))))
+    (set y (self:draw-tile-flag flagname x (+ y style.padding.y))))
+  y)
+
+(fn TileView.draw-tile-preview [self x y]
+  (each [_ [tx ty] (ipairs (self:preview-locations))]
+    (self:draw-sprite (+ x (* tx self.sprite-scale)) (+ y (* ty self.sprite-scale)) self.itile self.tilekey)))
+
+(fn TileView.draw-tile-palette [self x y w]
+  (local pal (self:palette))
+  (if pal
+    (do (var cx x)
+        (var cy y)
+        (each [icolor color (ipairs pal)]
+          (when (>= cx w)
+            (set cx x)
+            (set cy (+ cy pixel-size style.padding.y)))
+          (when (button self [:pal icolor] cx cy pixel-size pixel-size)
+            (set self.icolor icolor))
+          (renderer.draw_rect cx cy pixel-size pixel-size color)
+          (when (= icolor self.icolor)
+            (love.graphics.setColor 1 1 1 1)
+            (love.graphics.rectangle :line (- cx 2) (- cy 2) (+ pixel-size 4) (+ pixel-size 4)))
+          (set cx (+ cx pixel-size style.padding.x)))
+        (+ pixel-size style.padding.y))
+    0))
 
 (fn TileView.update-tile [self newtile]
   (self.tilecache:update-tile self.itile newtile self.tilekey))
@@ -96,8 +115,10 @@
   (local (x y) (values (+ self.position.x style.padding.x (- self.scroll.x))
                        (+ self.position.y style.padding.y (- self.scroll.y))))
   (local (editor-w editor-h) (self:draw-tile-editor (self:tile) x y))
-  (self:draw-tile-flags (+ x editor-w pixel-size) y)
+  (local preview-y (self:draw-tile-flags (+ x editor-w pixel-size) y))
+  (self:draw-tile-preview (+ x editor-w pixel-size) (+ preview-y style.padding.y))
   (var selector-y (+ y editor-h pixel-size))
+  (set selector-y (+ selector-y (self:draw-tile-palette x selector-y (- self.size.x 20))))
   (each [_ key (ipairs (self:tilekeys))]
     (local selector-h (self:draw-tile-selector x selector-y (- self.size.x 20) key))
     (set selector-y (+ selector-y selector-h pixel-size)))

game/files.fnl

@@ -1,10 +1,9 @@
 (local util (require :lib.util))
 (local lume (require :lib.lume))
-(local tiledraw (require :editor.tiledraw))
 
 (local files (util.hot-table ...))
 
-(local default-filename "bitsy/game.json")
+(local default-filename "neutgs/game.json")
 
 (local encoded-tile-fields [:gfx :mask])
 (fn convert [tile field method]
@@ -51,7 +50,8 @@
        (if (util.file-exists (filename))
          (let [game (util.readjson (filename))]
            (each [k v (pairs game)]
-             (tset game k (lume.map v #(deserialize k (clone $1) game))))
+             (when (= (type v) :table)
+               (tset game k (lume.map v #(deserialize k (clone $1) game)))))
            game)
          {:tiles [] :portraits [] :font [] :levels []}))
   files.game)
@@ -60,11 +60,12 @@
   (when ?filename (set files.filename ?filename))
   (let [game {}]
     (each [k v (pairs files.game)]
-      (tset game k (lume.map v #(serialize k (clone $1) files.game))))
+      (tset game k (if (= (type v) :table) (lume.map v #(serialize k (clone $1) files.game)) v)))
     (util.writejson (filename) game)))
 
 (fn new-cache [game key]
-  (let [spritegen (match key
+  (let [tiledraw (require :editor.tiledraw)
+        spritegen (match key
                          :font tiledraw.char-to-sprite
                          :brushes tiledraw.char-to-sprite
                          :portraits tiledraw.portrait-to-sprite
@@ -73,6 +74,8 @@
     (tiledraw.TileCache gfx spritegen)))
 
 (fn files.cache [key]
+  (when (= (. files.game key) nil)
+    (tset files.game key []))
   (when (= (?. files :tilecaches key) nil)
     (util.nested-tset files [:tilecaches key] (new-cache files.game key)))
   (. files.tilecaches key))
@@ -86,6 +89,12 @@
 (fn files.module []
   (or files.game.module (: (filename) :match "^[^/]+")))
 
+(fn files.platform [] (or files.game.platform :ii))
+(fn files.default-platform-method [cls module-prefix method default]
+  (tset cls method (fn [...] (let [f (. (require (.. module-prefix :. (files.platform))) method)] (if f (f ...) (default ...))))))
+(fn files.platform-methods [cls module-prefix ...]
+  (each [_ key (ipairs [...])] (files.default-platform-method cls module-prefix key #nil)))
+
 (when (= files.game nil)
   (files.load))
 

lib/fennel.lua

@@ -266,7 +266,7 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
       else
         if parse_ok_3f then
           do
-            local _4_0, _5_0 = pcall(compiler.compile, x, {["assert-compile"] = opts["assert-compile"], ["parse-error"] = opts["parse-error"], correlate = opts.correlate, moduleName = opts.moduleName, scope = scope, source = src_string, useMetadata = opts.useMetadata})
+            local _4_0, _5_0 = pcall(compiler.compile, x, {["assert-compile"] = opts["assert-compile"], ["parse-error"] = opts["parse-error"], correlate = opts.correlate, moduleName = opts.moduleName, scope = scope, source = src_string, useBitLib = opts.useBitLib, useMetadata = opts.useMetadata})
             if ((_4_0 == false) and (nil ~= _5_0)) then
               local msg = _5_0
               clear_stream()
@@ -1202,6 +1202,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
   SPECIALS.each = function(ast, scope, parent)
     compiler.assert((#ast >= 3), "expected body expression", ast[1])
     local binding = compiler.assert(utils["table?"](ast[2]), "expected binding table", ast)
+    local _ = compiler.assert((2 <= #binding), "expected binding and iterator", binding)
     local until_condition = remove_until_condition(binding)
     local iter = table.remove(binding, #binding)
     local destructures = {}
@@ -1876,7 +1877,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
     else
       _0_ = 0
     end
-    return {autogensyms = {}, depth = _0_, hashfn = (parent0 and parent0.hashfn), includes = setmetatable({}, {__index = (parent0 and parent0.includes)}), macros = setmetatable({}, {__index = (parent0 and parent0.macros)}), manglings = setmetatable({}, {__index = (parent0 and parent0.manglings)}), parent = parent0, refedglobals = setmetatable({}, {__index = (parent0 and parent0.refedglobals)}), specials = setmetatable({}, {__index = (parent0 and parent0.specials)}), symmeta = setmetatable({}, {__index = (parent0 and parent0.symmeta)}), unmanglings = setmetatable({}, {__index = (parent0 and parent0.unmanglings)}), vararg = (parent0 and parent0.vararg)}
+    return {autogensyms = setmetatable({}, {__index = (parent0 and parent0.autogensyms)}), depth = _0_, gensyms = setmetatable({}, {__index = (parent0 and parent0.gensyms)}), hashfn = (parent0 and parent0.hashfn), includes = setmetatable({}, {__index = (parent0 and parent0.includes)}), macros = setmetatable({}, {__index = (parent0 and parent0.macros)}), manglings = setmetatable({}, {__index = (parent0 and parent0.manglings)}), parent = parent0, refedglobals = setmetatable({}, {__index = (parent0 and parent0.refedglobals)}), specials = setmetatable({}, {__index = (parent0 and parent0.specials)}), symmeta = setmetatable({}, {__index = (parent0 and parent0.symmeta)}), unmanglings = setmetatable({}, {__index = (parent0 and parent0.unmanglings)}), vararg = (parent0 and parent0.vararg)}
   end
   local function assert_msg(ast, msg)
     local ast_tbl = nil
@@ -1950,11 +1951,11 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
     end
   end
   local allowed_globals = nil
-  local function global_allowed(name)
+  local function global_allowed_3f(name)
     return (not allowed_globals or utils["member?"](name, allowed_globals))
   end
   local function unique_mangling(original, mangling, scope, append)
-    if scope.unmanglings[mangling] then
+    if (scope.unmanglings[mangling] and not scope.gensyms[mangling]) then
       return unique_mangling(original, (original .. append), scope, (append + 1))
     else
       return mangling
@@ -2010,6 +2011,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
       append = (append + 1)
     end
     scope.unmanglings[mangling] = (base or true)
+    scope.gensyms[mangling] = true
     return mangling
   end
   local function autogensym(base, scope)
@@ -2068,7 +2070,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
     if (local_3f and scope.symmeta[parts[1]]) then
       scope.symmeta[parts[1]]["used"] = true
     end
-    assert_compile((not reference_3f or local_3f or global_allowed(parts[1])), ("unknown global in strict mode: " .. tostring(parts[1])), symbol)
+    assert_compile((not reference_3f or local_3f or ("_ENV" == parts[1]) or global_allowed_3f(parts[1])), ("unknown global in strict mode: " .. tostring(parts[1])), symbol)
     if (allowed_globals and not local_3f) then
       utils.root.scope.refedglobals[parts[1]] = true
     end
@@ -2102,7 +2104,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
     local m = getmetatable(ast)
     return ((m and m.line and m) or (("table" == type(ast)) and ast) or {})
   end
-  local function flatten_chunk_correlated(main_chunk)
+  local function flatten_chunk_correlated(main_chunk, options)
     local function flatten(chunk, out, last_line, file)
       local last_line0 = last_line
       if chunk.leaf then
@@ -2111,7 +2113,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
         for _, subchunk in ipairs(chunk) do
           if (subchunk.leaf or (#subchunk > 0)) then
             local source = ast_source(subchunk.ast)
-            if (file == source.file) then
+            if (file == source.filename) then
               last_line0 = math.max(last_line0, (source.line or 0))
             end
             last_line0 = flatten(subchunk, out, last_line0, file)
@@ -2121,7 +2123,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
       return last_line0
     end
     local out = {}
-    local last = flatten(main_chunk, out, 1, main_chunk.file)
+    local last = flatten(main_chunk, out, 1, options.filename)
     for i = 1, last do
       if (out[i] == nil) then
         out[i] = ""
@@ -2178,7 +2180,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
   local function flatten(chunk, options)
     local chunk0 = peephole(chunk)
     if options.correlate then
-      return flatten_chunk_correlated(chunk0), {}
+      return flatten_chunk_correlated(chunk0, options), {}
     else
       local sm = {}
       local ret = flatten_chunk(sm, chunk0, options.indent, 0)
@@ -2222,20 +2224,21 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
   local function exprs1(exprs)
     return table.concat(utils.map(exprs, 1), ", ")
   end
-  local function disambiguate_parens(code, chunk)
-    if (code:byte() == 40) then
-      return ("do end " .. code)
-    else
-      return code
-    end
-  end
   local function keep_side_effects(exprs, chunk, start, ast)
-    for j = (start or 1), #exprs do
+    local start0 = (start or 1)
+    for j = start0, #exprs do
       local se = exprs[j]
       if ((se.type == "expression") and (se[1] ~= "nil")) then
         emit(chunk, string.format("do local _ = %s end", tostring(se)), ast)
       elseif (se.type == "statement") then
-        emit(chunk, disambiguate_parens(tostring(se), chunk), ast)
+        local code = tostring(se)
+        local disambiguated = nil
+        if (code:byte() == 40) then
+          disambiguated = ("do end " .. code)
+        else
+          disambiguated = code
+        end
+        emit(chunk, disambiguated, ast)
       end
     end
     return nil
@@ -2353,7 +2356,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
   local function compile_function_call(ast, scope, parent, opts, compile1, len)
     local fargs = {}
     local fcallee = compile1(ast[1], scope, parent, {nval = 1})[1]
-    assert_compile((fcallee.type ~= "literal"), ("cannot call literal value " .. tostring(ast[1])), ast)
+    assert_compile((("string" == type(ast[1])) or (fcallee.type ~= "literal")), ("cannot call literal value " .. tostring(ast[1])), ast)
     for i = 2, len do
       local subexprs = nil
       local _0_
@@ -2372,7 +2375,13 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
         keep_side_effects(subexprs, parent, 2, ast[i])
       end
     end
-    local call = string.format("%s(%s)", tostring(fcallee), exprs1(fargs))
+    local pat = nil
+    if ("string" == type(ast[1])) then
+      pat = "(%s)(%s)"
+    else
+      pat = "%s(%s)"
+    end
+    local call = string.format(pat, tostring(fcallee), exprs1(fargs))
     return handle_compile_opts({utils.expr(call, "statement")}, parent, opts, ast)
   end
   local function compile_call(ast, scope, parent, opts, compile1)
@@ -2749,7 +2758,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
     end
   end
   local function traceback(msg, start)
-    local msg0 = (msg or "")
+    local msg0 = tostring((msg or ""))
     if ((msg0:find("^Compile error") or msg0:find("^Parse error")) and not utils["debug-on?"]("trace")) then
       return msg0
     else
@@ -2888,7 +2897,7 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] or function(
     local m = getmetatable(ast)
     return ((m and m.line and m) or (("table" == type(ast)) and ast) or {})
   end
-  local suggestions = {["$ and $... in hashfn are mutually exclusive"] = {"modifying the hashfn so it only contains $... or $, $1, $2, $3, etc"}, ["can't start multisym segment with a digit"] = {"removing the digit", "adding a non-digit before the digit"}, ["cannot call literal value"] = {"checking for typos", "checking for a missing function name"}, ["could not compile value of type "] = {"debugging the macro you're calling to return a list or table"}, ["could not read number (.*)"] = {"removing the non-digit character", "beginning the identifier with a non-digit if it is not meant to be a number"}, ["expected a function.* to call"] = {"removing the empty parentheses", "using square brackets if you want an empty table"}, ["expected binding table"] = {"placing a table here in square brackets containing identifiers to bind"}, ["expected body expression"] = {"putting some code in the body of this form after the bindings"}, ["expected each macro to be function"] = {"ensuring that the value for each key in your macros table contains a function", "avoid defining nested macro tables"}, ["expected even number of name/value bindings"] = {"finding where the identifier or value is missing"}, ["expected even number of values in table literal"] = {"removing a key", "adding a value"}, ["expected local"] = {"looking for a typo", "looking for a local which is used out of its scope"}, ["expected macros to be table"] = {"ensuring your macro definitions return a table"}, ["expected parameters"] = {"adding function parameters as a list of identifiers in brackets"}, ["expected rest argument before last parameter"] = {"moving & to right before the final identifier when destructuring"}, ["expected symbol for function parameter: (.*)"] = {"changing %s to an identifier instead of a literal value"}, ["expected var (.*)"] = {"declaring %s using var instead of let/local", "introducing a new local instead of changing the value of %s"}, ["expected vararg as last parameter"] = {"moving the \"...\" to the end of the parameter list"}, ["expected whitespace before opening delimiter"] = {"adding whitespace"}, ["global (.*) conflicts with local"] = {"renaming local %s"}, ["illegal character: (.)"] = {"deleting or replacing %s", "avoiding reserved characters like \", \\, ', ~, ;, @, `, and comma"}, ["local (.*) was overshadowed by a special form or macro"] = {"renaming local %s"}, ["macro not found in macro module"] = {"checking the keys of the imported macro module's returned table"}, ["macro tried to bind (.*) without gensym"] = {"changing to %s# when introducing identifiers inside macros"}, ["malformed multisym"] = {"ensuring each period or colon is not followed by another period or colon"}, ["may only be used at compile time"] = {"moving this to inside a macro if you need to manipulate symbols/lists", "using square brackets instead of parens to construct a table"}, ["method must be last component"] = {"using a period instead of a colon for field access", "removing segments after the colon", "making the method call, then looking up the field on the result"}, ["mismatched closing delimiter (.), expected (.)"] = {"replacing %s with %s", "deleting %s", "adding matching opening delimiter earlier"}, ["multisym method calls may only be in call position"] = {"using a period instead of a colon to reference a table's fields", "putting parens around this"}, ["unable to bind (.*)"] = {"replacing the %s with an identifier"}, ["unexpected closing delimiter (.)"] = {"deleting %s", "adding matching opening delimiter earlier"}, ["unexpected multi symbol (.*)"] = {"removing periods or colons from %s"}, ["unexpected vararg"] = {"putting \"...\" at the end of the fn parameters if the vararg was intended"}, ["unknown global in strict mode: (.*)"] = {"looking to see if there's a typo", "using the _G table instead, eg. _G.%s if you really want a global", "moving this code to somewhere that %s is in scope", "binding %s as a local in the scope of this code"}, ["unused local (.*)"] = {"fixing a typo so %s is used", "renaming the local to _%s"}, ["use of global (.*) is aliased by a local"] = {"renaming local %s", "refer to the global using _G.%s instead of directly"}}
+  local suggestions = {["$ and $... in hashfn are mutually exclusive"] = {"modifying the hashfn so it only contains $... or $, $1, $2, $3, etc"}, ["can't start multisym segment with a digit"] = {"removing the digit", "adding a non-digit before the digit"}, ["cannot call literal value"] = {"checking for typos", "checking for a missing function name"}, ["could not compile value of type "] = {"debugging the macro you're calling to return a list or table"}, ["could not read number (.*)"] = {"removing the non-digit character", "beginning the identifier with a non-digit if it is not meant to be a number"}, ["expected a function.* to call"] = {"removing the empty parentheses", "using square brackets if you want an empty table"}, ["expected binding and iterator"] = {"making sure you haven't omitted a local name or iterator"}, ["expected binding table"] = {"placing a table here in square brackets containing identifiers to bind"}, ["expected body expression"] = {"putting some code in the body of this form after the bindings"}, ["expected each macro to be function"] = {"ensuring that the value for each key in your macros table contains a function", "avoid defining nested macro tables"}, ["expected even number of name/value bindings"] = {"finding where the identifier or value is missing"}, ["expected even number of values in table literal"] = {"removing a key", "adding a value"}, ["expected local"] = {"looking for a typo", "looking for a local which is used out of its scope"}, ["expected macros to be table"] = {"ensuring your macro definitions return a table"}, ["expected parameters"] = {"adding function parameters as a list of identifiers in brackets"}, ["expected rest argument before last parameter"] = {"moving & to right before the final identifier when destructuring"}, ["expected symbol for function parameter: (.*)"] = {"changing %s to an identifier instead of a literal value"}, ["expected var (.*)"] = {"declaring %s using var instead of let/local", "introducing a new local instead of changing the value of %s"}, ["expected vararg as last parameter"] = {"moving the \"...\" to the end of the parameter list"}, ["expected whitespace before opening delimiter"] = {"adding whitespace"}, ["global (.*) conflicts with local"] = {"renaming local %s"}, ["illegal character: (.)"] = {"deleting or replacing %s", "avoiding reserved characters like \", \\, ', ~, ;, @, `, and comma"}, ["local (.*) was overshadowed by a special form or macro"] = {"renaming local %s"}, ["macro not found in macro module"] = {"checking the keys of the imported macro module's returned table"}, ["macro tried to bind (.*) without gensym"] = {"changing to %s# when introducing identifiers inside macros"}, ["malformed multisym"] = {"ensuring each period or colon is not followed by another period or colon"}, ["may only be used at compile time"] = {"moving this to inside a macro if you need to manipulate symbols/lists", "using square brackets instead of parens to construct a table"}, ["method must be last component"] = {"using a period instead of a colon for field access", "removing segments after the colon", "making the method call, then looking up the field on the result"}, ["mismatched closing delimiter (.), expected (.)"] = {"replacing %s with %s", "deleting %s", "adding matching opening delimiter earlier"}, ["multisym method calls may only be in call position"] = {"using a period instead of a colon to reference a table's fields", "putting parens around this"}, ["unable to bind (.*)"] = {"replacing the %s with an identifier"}, ["unexpected closing delimiter (.)"] = {"deleting %s", "adding matching opening delimiter earlier"}, ["unexpected multi symbol (.*)"] = {"removing periods or colons from %s"}, ["unexpected vararg"] = {"putting \"...\" at the end of the fn parameters if the vararg was intended"}, ["unknown global in strict mode: (.*)"] = {"looking to see if there's a typo", "using the _G table instead, eg. _G.%s if you really want a global", "moving this code to somewhere that %s is in scope", "binding %s as a local in the scope of this code"}, ["unused local (.*)"] = {"fixing a typo so %s is used", "renaming the local to _%s"}, ["use of global (.*) is aliased by a local"] = {"renaming local %s", "refer to the global using _G.%s instead of directly"}}
   local unpack = (table.unpack or _G.unpack)
   local function suggest(msg)
     local suggestion = nil
@@ -3706,19 +3715,19 @@ local function dofile_2a(filename, options, ...)
   opts.filename = filename
   return eval(source, opts, ...)
 end
-local mod = {["comment?"] = utils["comment?"], ["compile-stream"] = compiler["compile-stream"], ["compile-string"] = compiler["compile-string"], ["list?"] = utils["list?"], ["load-code"] = specials["load-code"], ["macro-loaded"] = specials["macro-loaded"], ["macro-searchers"] = specials["macro-searchers"], ["make-searcher"] = specials["make-searcher"], ["search-module"] = specials["search-module"], ["sequence?"] = utils["sequence?"], ["string-stream"] = parser["string-stream"], ["sym-char?"] = parser["sym-char?"], ["sym?"] = utils["sym?"], comment = utils.comment, compile = compiler.compile, compile1 = compiler.compile1, compileStream = compiler["compile-stream"], compileString = compiler["compile-string"], doc = specials.doc, dofile = dofile_2a, eval = eval, gensym = compiler.gensym, granulate = parser.granulate, list = utils.list, loadCode = specials["load-code"], macroLoaded = specials["macro-loaded"], makeSearcher = specials["make-searcher"], make_searcher = specials["make-searcher"], mangle = compiler["global-mangling"], metadata = compiler.metadata, parser = parser.parser, path = utils.path, repl = repl, scope = compiler["make-scope"], searchModule = specials["search-module"], searcher = specials["make-searcher"](), sequence = utils.sequence, stringStream = parser["string-stream"], sym = utils.sym, traceback = compiler.traceback, unmangle = compiler["global-unmangling"], varg = utils.varg, version = "0.9.1-dev", view = view}
+local mod = {["comment?"] = utils["comment?"], ["compile-stream"] = compiler["compile-stream"], ["compile-string"] = compiler["compile-string"], ["list?"] = utils["list?"], ["load-code"] = specials["load-code"], ["macro-loaded"] = specials["macro-loaded"], ["macro-searchers"] = specials["macro-searchers"], ["make-searcher"] = specials["make-searcher"], ["search-module"] = specials["search-module"], ["sequence?"] = utils["sequence?"], ["string-stream"] = parser["string-stream"], ["sym-char?"] = parser["sym-char?"], ["sym?"] = utils["sym?"], comment = utils.comment, compile = compiler.compile, compile1 = compiler.compile1, compileStream = compiler["compile-stream"], compileString = compiler["compile-string"], doc = specials.doc, dofile = dofile_2a, eval = eval, gensym = compiler.gensym, granulate = parser.granulate, list = utils.list, loadCode = specials["load-code"], macroLoaded = specials["macro-loaded"], makeSearcher = specials["make-searcher"], make_searcher = specials["make-searcher"], mangle = compiler["global-mangling"], metadata = compiler.metadata, parser = parser.parser, path = utils.path, repl = repl, scope = compiler["make-scope"], searchModule = specials["search-module"], searcher = specials["make-searcher"](), sequence = utils.sequence, stringStream = parser["string-stream"], sym = utils.sym, traceback = compiler.traceback, unmangle = compiler["global-unmangling"], varg = utils.varg, version = "0.9.2", view = view}
 utils["fennel-module"] = mod
 do
   local builtin_macros = [===[;; This module contains all the built-in Fennel macros. Unlike all the other
   ;; modules that are loaded by the old bootstrap compiler, this runs in the
   ;; compiler scope of the version of the compiler being defined.
-
+  
   ;; The code for these macros is somewhat idiosyncratic because it cannot use any
   ;; macros which have not yet been defined.
-
+  
   ;; TODO: some of these macros modify their arguments; we should stop doing that,
   ;; but in a way that preserves file/line metadata.
-
+  
   (fn ->* [val ...]
     "Thread-first macro.
   Take the first value and splice it into the second form as its first argument.
@@ -3729,7 +3738,7 @@ do
         (table.insert elt 2 x)
         (set x elt)))
     x)
-
+  
   (fn ->>* [val ...]
     "Thread-last macro.
   Same as ->, except splices the value into the last position of each form
@@ -3740,7 +3749,7 @@ do
         (table.insert elt x)
         (set x elt)))
     x)
-
+  
   (fn -?>* [val ...]
     "Nil-safe thread-first macro.
   Same as -> except will short-circuit with nil when it encounters a nil value."
@@ -3755,7 +3764,7 @@ do
              (if ,tmp
                  (-?> ,el ,(unpack els))
                  ,tmp)))))
-
+  
   (fn -?>>* [val ...]
     "Nil-safe thread-last macro.
   Same as ->> except will short-circuit with nil when it encounters a nil value."
@@ -3770,14 +3779,20 @@ do
              (if ,tmp
                  (-?>> ,el ,(unpack els))
                  ,tmp)))))
-
+  
-  (fn ?dot [tbl k ...]
+  (fn ?dot [tbl ...]
     "Nil-safe table look up.
   Same as . (dot), except will short-circuit with nil when it encounters
   a nil value in any of subsequent keys."
-    (if (= nil k) tbl `(let [res# (. ,tbl ,k)]
+    (let [head (gensym :t)
-                         (and res# (?. res# ,...)))))
+          lookups `(do (var ,head ,tbl) ,head)]
-
+      (each [_ k (ipairs [...])]
+        ;; Kinda gnarly to reassign in place like this, but it emits the best lua.
+        ;; With this impl, it emits a flat, concise, and readable set of if blocks.
+        (table.insert lookups (# lookups) `(if (not= nil ,head)
+                                             (set ,head (. ,head ,k)))))
+      lookups))
+  
   (fn doto* [val ...]
     "Evaluates val and splices it into the first argument of subsequent forms."
     (let [name (gensym)
@@ -3787,7 +3802,7 @@ do
         (table.insert form elt))
       (table.insert form name)
       form))
-
+  
   (fn when* [condition body1 ...]
     "Evaluate body for side-effects only when condition is truthy."
     (assert body1 "expected body")
@@ -3795,7 +3810,7 @@ do
          (do
            ,body1
            ,...)))
-
+  
   (fn with-open* [closable-bindings ...]
     "Like `let`, but invokes (v:close) on each binding after evaluating the body.
   The body is evaluated inside `xpcall` so that bound values will be closed upon
@@ -3812,13 +3827,13 @@ do
       `(let ,closable-bindings
          ,closer
          (close-handlers# (xpcall ,bodyfn ,traceback)))))
-
+  
   (fn collect* [iter-tbl key-value-expr ...]
     "Returns a table made by running an iterator and evaluating an expression
   that returns key-value pairs to be inserted sequentially into the table.
   This can be thought of as a \"table comprehension\". The provided key-value
   expression must return either 2 values, or nil.
-
+  
   For example,
     (collect [k v (pairs {:apple \"red\" :orange \"orange\"})]
       (values v k))
@@ -3834,12 +3849,12 @@ do
          (match ,key-value-expr
            (k# v#) (tset tbl# k# v#)))
        tbl#))
-
+  
   (fn icollect* [iter-tbl value-expr ...]
     "Returns a sequential table made by running an iterator and evaluating an
   expression that returns values to be inserted sequentially into the table.
   This can be thought of as a \"list comprehension\".
-
+  
   For example,
     (icollect [_ v (ipairs [1 2 3 4 5])] (when (> v 2) (* v v)))
   returns
@@ -3853,7 +3868,7 @@ do
        (each ,iter-tbl
          (tset tbl# (+ (length tbl#) 1) ,value-expr))
        tbl#))
-
+  
   (fn partial* [f ...]
     "Returns a function with all arguments partially applied to f."
     (assert f "expected a function to partially apply")
@@ -3861,10 +3876,10 @@ do
       (table.insert body _VARARG)
       `(fn [,_VARARG]
          ,body)))
-
+  
   (fn pick-args* [n f]
     "Creates a function of arity n that applies its arguments to f.
-
+  
   For example,
     (pick-args 2 func)
   expands to
@@ -3876,10 +3891,10 @@ do
         (tset bindings i (gensym)))
       `(fn ,bindings
          (,f ,(unpack bindings)))))
-
+  
   (fn pick-values* [n ...]
     "Like the `values` special, but emits exactly n values.
-
+  
   For example,
     (pick-values 2 ...)
   expands to
@@ -3894,7 +3909,7 @@ do
       (if (= n 0) `(values)
           `(let [,let-syms ,let-values]
              (values ,(unpack let-syms))))))
-
+  
   (fn lambda* [...]
     "Function literal with arity checking.
   Will throw an exception if a declared argument is passed in as nil, unless
@@ -3921,26 +3936,26 @@ do
                                                   ,(tostring a)
                                                   ,(or a.filename :unknown)
                                                   ,(or a.line "?"))))))
-
+  
       (assert (= :table (type arglist)) "expected arg list")
       (each [_ a (ipairs arglist)]
         (check! a))
       (if empty-body?
           (table.insert args (sym :nil)))
       `(fn ,(unpack args))))
-
+  
   (fn macro* [name ...]
     "Define a single macro."
     (assert (sym? name) "expected symbol for macro name")
     (local args [...])
     `(macros {,(tostring name) (fn ,(unpack args))}))
-
+  
   (fn macrodebug* [form return?]
     "Print the resulting form after performing macroexpansion.
   With a second argument, returns expanded form as a string instead of printing."
     (let [handle (if return? `do `print)]
       `(,handle ,(view (macroexpand form _SCOPE)))))
-
+  
   (fn import-macros* [binding1 module-name1 ...]
     "Binds a table of macros from each macro module according to a binding form.
   Each binding form can be either a symbol or a k/v destructuring table.
@@ -3971,9 +3986,9 @@ do
                           (tostring modname)))
               (tset scope.macros import-key (. subscope.macros macro-name))))))
     nil)
-
+  
   ;;; Pattern matching
-
+  
   (fn match-values [vals pattern unifications match-pattern]
     (let [condition `(and)
           bindings []]
@@ -3984,7 +3999,7 @@ do
           (each [_ b (ipairs subbindings)]
             (table.insert bindings b))))
       (values condition bindings)))
-
+  
   (fn match-table [val pattern unifications match-pattern]
     (let [condition `(and (= (type ,val) :table))
           bindings []]
@@ -4016,7 +4031,7 @@ do
               (each [_ b (ipairs subbindings)]
                 (table.insert bindings b)))))
       (values condition bindings)))
-
+  
   (fn match-pattern [vals pattern unifications]
     "Takes the AST of values and a single pattern and returns a condition
   to determine if it matches as well as a list of bindings to
@@ -4043,11 +4058,10 @@ do
           (and (list? pattern) (= (. pattern 2) `?))
           (let [(pcondition bindings) (match-pattern vals (. pattern 1)
                                                      unifications)
-                condition `(and ,pcondition)]
+                condition `(and ,(unpack pattern 3))]
-            (for [i 3 (length pattern)] ; splice in guard clauses
+            (values `(and ,pcondition
-              (table.insert condition (. pattern i)))
+                          (let ,bindings
-            (values `(let ,bindings
+                            ,condition)) bindings))
-                       ,condition) bindings))
           ;; multi-valued patterns (represented as lists)
           (list? pattern)
           (match-values vals pattern unifications match-pattern)
@@ -4056,7 +4070,7 @@ do
           (match-table val pattern unifications match-pattern)
           ;; literal value
           (values `(= ,val ,pattern) []))))
-
+  
   (fn match-condition [vals clauses]
     "Construct the actual `if` AST for the given match values and clauses."
     (if (not= 0 (% (length clauses) 2)) ; treat odd final clause as default
@@ -4070,17 +4084,20 @@ do
           (table.insert out `(let ,bindings
                                ,body))))
       out))
-
+  
   (fn match-val-syms [clauses]
     "How many multi-valued clauses are there? return a list of that many gensyms."
     (let [syms (list (gensym))]
       (for [i 1 (length clauses) 2]
-        (if (list? (. clauses i))
+        (let [clause (if (and (list? (. clauses i)) (= `? (. clauses i 2)))
-            (each [valnum (ipairs (. clauses i))]
+                         (. clauses i 1)
-              (if (not (. syms valnum))
+                         (. clauses i))]
-                  (tset syms valnum (gensym))))))
+          (if (list? clause)
+              (each [valnum (ipairs clause)]
+                (if (not (. syms valnum))
+                    (tset syms valnum (gensym)))))))
       syms))
-
+  
   (fn match* [val ...]
     ;; Old implementation of match macro, which doesn't directly support
     ;; `where' and `or'. New syntax is implemented in `match-where',
@@ -4090,9 +4107,9 @@ do
       ;; protect against multiple evaluation of the value, bind against as
       ;; many values as we ever match against in the clauses.
       (list `let [vals val] (match-condition vals clauses))))
-
+  
   ;; Construction of old match syntax from new syntax
-
+  
   (fn partition-2 [seq]
     ;; Partition `seq` by 2.
     ;; If `seq` has odd amount of elements, the last one is dropped.
@@ -4112,7 +4129,7 @@ do
           (if (not= nil v2)
               (table.insert res [v1 v2]))))
       res))
-
+  
   (fn transform-or [[_ & pats] guards]
     ;; Transforms `(or pat pats*)` lists into match `guard` patterns.
     ;;
@@ -4121,7 +4138,7 @@ do
       (each [_ pat (ipairs pats)]
         (table.insert res (list pat `? (unpack guards))))
       res))
-
+  
   (fn transform-cond [cond]
     ;; Transforms `where` cond into sequence of `match` guards.
     ;;
@@ -4136,12 +4153,12 @@ do
               [(list second `? (unpack cond 3))]))
         :else
         [cond]))
-
+  
   (fn match-where [val ...]
     "Perform pattern matching on val. See reference for details.
-
+  
   Syntax:
-
+  
   (match data-expression
     pattern body
     (where pattern guard guards*) body
@@ -4157,7 +4174,7 @@ do
       (if else-branch
           (table.insert match-body else-branch))
       (match* val (unpack match-body))))
-
+  
   {:-> ->*
    :->> ->>*
    :-?> -?>*

lib/metatable_monkey.lua

@@ -0,0 +1,33 @@
+-- source: https://gitlab.com/technomancy/bussard/-/blob/master/metatable_monkey.lua
+-- Versions of Lua prior to 5.1 could not properly support iterating over proxy
+-- tables with their built-in iterators. This module fixes that problem.
+
+local original_pairs, original_ipairs = pairs, ipairs
+local mtpairs = function(tab)
+   local mt = getmetatable(tab)
+   if(mt and mt.__pairs) then
+      return mt.__pairs(tab)
+   else
+      return original_pairs(tab)
+   end
+end
+
+local mtipairs = function(tab)
+   local mt = getmetatable(tab)
+   if(mt and mt.__ipairs) then
+      return mt.__ipairs(tab)
+   else
+      return original_ipairs(tab)
+   end
+end
+
+local patched, ipatched, t = false, false, {}
+setmetatable(t, {__pairs = function() return next,{1},nil end})
+
+for _ in pairs(t) do patched = true end
+if(not patched) then pairs = mtpairs end
+for _ in ipairs(t) do ipatched = true end
+if(not ipatched) then ipairs = mtipairs end
+
+return {original_pairs, original_ipairs}
+

lib/util.fnl

@@ -9,20 +9,28 @@
 
 (fn lo [v] (bit.band v 0xff))
 (fn hi [v] (bit.band (bit.rshift v 8) 0xff))
+(fn loword [v] (bit.band v 0xffff))
+(fn hiword [v] (bit.band (bit.rshift v 16) 0xffff))
+
 (fn int8-to-bytes [i]
   (string.char (lo i)))
 (fn int16-to-bytes [i]
   (string.char (lo i) (hi i)))
 (fn int24-to-bytes [i]
-  (string.char (lo i) (hi i) (bit.band (bit.rshift i 16) 0xff)))
+  (string.char (lo i) (hi i) (lo (bit.rshift i 16))))
+(fn int32-to-bytes [i]
+  (string.char (lo i) (hi i) (lo (bit.rshift i 16)) (hi (bit.rshift i 16))))
 (fn bytes-to-uint8 [b ?offset]
   (string.byte b (+ 1 (or ?offset 0)) (+ 1 (or ?offset 0))))
 (fn bytes-to-uint16 [b ?offset]
-  (local (lo hi) (string.byte b (+ 1 (or ?offset 0))   (+ 2 (or ?offset 0))))
+  (local (lo hi) (string.byte b (+ 1 (or ?offset 0)) (+ 2 (or ?offset 0))))
   (bit.bor lo (bit.lshift hi 8)))
 (fn bytes-to-uint24 [b ?offset]
   (local (lo mid hi) (string.byte b (+ 1 (or ?offset 0)) (+ 3 (or ?offset 0))))
   (bit.bor lo (bit.lshift mid 8) (bit.lshift hi 16)))
+(fn bytes-to-uint32 [b ?offset]
+  (local [lo hi] [(bytes-to-uint16 b ?offset) (bytes-to-uint16 b (+ 2 (or ?offset 0)))])
+  (bit.bor lo (bit.lshift hi 16)))
 
 (fn splice [bytes offset str]
   (.. (bytes:sub 1 offset)
@@ -111,8 +119,33 @@
     (when (not= f nil) (io.close f))
     (not= f nil)))
 
-{: int8-to-bytes : int16-to-bytes : int24-to-bytes : bytes-to-uint8 : bytes-to-uint16 : bytes-to-uint24
+(fn pairoff [l]
- : splice : lo : hi
+  (fn [_ iprev] (let [i (if iprev (+ iprev 2) 1)]
- : reload : hotswap : swappable :require swappable-require : hot-table : nested-tset
+                          (when (< i (length l)) (values i (. l i) (. l (+ i 1)))))))
+
+(fn countiter [minmax ?max ?step]
+  (let [min (if ?max minmax 1)
+        max (or ?max minmax)
+        step (or ?step 1)]
+    (fn [_ iprev]
+      (let [i (if iprev (+ iprev step) min)]
+        (when (if (> step 0) (<= i max) (>= i max)) i)))))
+
+(fn condlist [...] (let [l []] (lume.push l ...) l))
+
+(fn prototype [base] (setmetatable {} {:__index base}))
+(fn proxy [t f]
+  (let [p {}
+        iter #(let [i (+ $2 1) v (. $1 i)] (when v (values i v)))
+        pnext #(let [k (next t $2)] (when k (values k (. $1 k))))]
+    (setmetatable p
+      {:__index #(f (. t $2) $2 t)
+       :__len #(length t)
+       :__ipairs #(values iter p 0)
+       :__pairs #(values pnext p nil)})))
+
+{: int8-to-bytes : int16-to-bytes : int24-to-bytes : int32-to-bytes : bytes-to-uint8 : bytes-to-uint16 : bytes-to-uint24 : bytes-to-uint32
+ : splice : lo : hi : loword : hiword : condlist : prototype : proxy
+ : reload : hotswap : swappable :require swappable-require : hot-table : nested-tset : pairoff : countiter
  : readjson : writejson : file-exists : waitfor : in-coro : multival}
 

link/init.fnl

@@ -3,7 +3,7 @@
    (fn [self name]
      (set self.machine (require (.. "link." name)))
      (set self.name name))
-   :types [:serial :tape :mame]})
+   :types [:serial :tape :mame :udpdebug]})
 
 (local serial (require :link.serial))
 (link:switch (if (and (pcall #(serial:connect)) (serial:connected?)) :serial :mame))

link/mame.fnl

@@ -23,7 +23,7 @@
   (set self.breakpoints {}))
 (fn Machine.boot [self]
   (when (not self.pid)
-    (set self.pid (start-mame :apple2e))))
+    (set self.pid (start-mame :apple2gs))))
 (fn Machine.run [self]
   (self:boot)
   (self:connect))
@@ -70,7 +70,7 @@
          (var last-addr ?last-addr)
          (while (let [state manager.machine.debugger.execution_state
                       addr (. manager.machine.devices ::maincpu :state :PC :value)]
-                    (not (and (= state :stop) (not= addr ?last-addr))))
+                    (not (and (= state :stop) (not= addr last-addr))))
            (when (= :run manager.machine.debugger.execution_state)
              (set last-addr nil))
            (coroutine.yield))))
@@ -141,7 +141,7 @@
     (bencode.encode addr-to-bytes)))
 (fn Machine.launch [self prg]
   (self:eval "(manager.machine:soft_reset)")
-  (self:eval (string.format "(emu.keypost \"CALL-151\\n %xG\\n\")" (prg:lookup-addr prg.start-symbol))))
+  (self:eval (string.format "(emu.keypost \"\n\nCALL-151\\n %xG\\n\")" (prg:lookup-addr prg.start-symbol))))
 (fn Machine.reboot [self] (self:eval "(manager.machine:hard_reset)"))
 (fn Machine.coro-eval [self code ?handlers]
   (var result nil)
@@ -174,7 +174,7 @@
   (self:set-bp addr
     #(util.in-coro (fn []
        (self:clear-bp addr)
-       (local hotswap (prg-old:read-hotswap self))
+       (local hotswap (prg-old:read-hotswap self prg-new))
        (prg-new:upload self)
        (prg-new:write-hotswap self hotswap)
        (self:jump (prg-new:lookup-addr :on-hotswap))

link/nrepl.fnl

@@ -72,7 +72,6 @@
      (tset self.active-requests msg-id nil))
    :handle
    (fn [self response]
-     (pp response)
      (local handlers (self:merge-handlers response))
      (each [prop handler (pairs handlers)]
        (local idiv (prop:find :/))

link/udpdebug.fnl

@@ -0,0 +1,153 @@
+(local core (require :core))
+(local socket (require :socket))
+(local {: int16-to-bytes : int32-to-bytes : bytes-to-uint16 : bytes-to-uint32 : lo : in-coro} (require :lib.util))
+(local Ssc (require :ssc))
+(import-macros {:sss ! : compile} :ssc.macros)
+
+(local config {
+  :host "172.24.1.6"
+  :port 6502
+})
+
+{:cmd {
+   :write 0
+   :read 1
+   :eval 2
+   :pause 3
+   :ping 4
+ }
+ :response {
+   :ack 0
+   :data 1
+ }
+ :pending {}
+ :msgid 0
+ :waiting false
+ :queue []
+ :connect
+ (fn [self ?port ?host]
+   (when (not self.connection)
+     (local [port host] [(or ?port config.port) (or ?host config.host)])
+     (set self.connection (assert (socket.udp)))
+     (assert (self.connection:setpeername host port))
+     (self.connection:settimeout 0)
+     (core.add_thread #(while (self:connected?) (self:receive) (coroutine.yield)) self.connection)))
+ :connected? (fn [self] (not= self.connection nil))
+ :disconnect
+ (fn [self]
+   (when self.connection
+     (self.connection:close)
+     (set self.connection nil)
+     (set self.pending {})
+     (set self.queue [])
+     (set self.waiting false)))
+ :next-msgid
+ (fn [self]
+   (set self.msgid (lo (+ self.msgid 1)))
+   self.msgid)
+ :send
+ (fn [self cmd ?data ?callback]
+   (self:enqueue
+     #(let [msgid (self:next-msgid)
+            msg (.. (string.char msgid cmd) (or ?data ""))]
+        (print "sending" msgid cmd (length msg))
+        (when ?callback
+          (tset self.pending msgid ?callback)
+          (set self.waiting true))
+        (self.connection:send msg))))
+ :receive
+ (fn [self]
+   (when self.connection
+     (let [data (self.connection:receive)]
+       (when data
+         (let [msgid (string.byte (data:sub 1 1))
+               cmd   (string.byte (data:sub 2 2))
+               pendingfn (. self.pending msgid)]
+           (print "recieved" msgid cmd)
+           (when pendingfn
+             (tset self.pending msgid nil)
+             (pendingfn self cmd (data:sub 3)))
+           (set self.waiting false)))
+       (when (and (not self.waiting) (> (length self.queue) 0))
+         (let [f (. self.queue 1)]
+           (table.remove self.queue 1)
+           (f))))))
+ :enqueue (fn [self f] (table.insert self.queue f))
+ :eval (fn [self c {: parent : org : ignore-result}]
+   (let [parent (or parent (require :ssc.iigs.u2-debug))
+         ssc (Ssc {: parent})
+         org (or org (parent.prg:lookup-addr :u2-debug-buffer))]
+     (compile ssc
+       (org [org])
+       (fn do-the-thing () [c]))
+     (ssc:assemble)
+     (if (not ignore-result)
+         (let [(_ data) (self:coro-send self.cmd.eval (. ssc.prg.org-to-block org :bytes))]
+           {:word (bytes-to-uint16 data) :long (bytes-to-uint32 data 2)})
+       (self:send self.cmd.eval (. ssc.prg.org-to-block org :bytes)))))
+ :jump (fn [self addr] (self:eval (! (asm (jsl [(tostring addr)]))) {:ignore-result true}))
+ :coro-send
+ (fn [self cmd ?data]
+   (let [coro (coroutine.running)]
+     (self:send cmd ?data #(coroutine.resume coro $2 $3))
+     (coroutine.yield)))
+ :handle-ack (fn [self cmd] (assert (= cmd self.response.ack)))
+ :split-batches (fn [self blocks max-size]
+   ; just make sure it's legal, not optimal - no need to solve an NP-hard bin-packing problem
+   (fn add-to-batch [batches iblock size]
+     (let [batch (. batches (length batches))
+           block (. blocks iblock)]
+       (if (= block nil) batches
+           ; must be split into multiple batches
+           (> block.len max-size)
+           (do (for [i 0 (- block.len 1) max-size]
+                 (when (and (= i 0) (= (length batch) 0)) (table.remove batches))
+                 (table.insert batches [{:addr (+ block.addr i)
+                                         :data (when block.data (block.data:sub (+ i 1) (+ i max-size)))
+                                         :len (math.min (- block.len i) max-size)
+                                         :offset 1
+                                         :append-to-addr block.addr}]))
+               (add-to-batch batches (+ iblock 1) (if (= (% block.len max-size) 0) max-size (% block.len max-size))))
+           ; we have run off the end of the current batch
+           (> (+ size block.len) max-size)
+           (do (table.insert batches [])
+               (add-to-batch batches iblock 0))
+         ; there is enough space to fit into the current batch
+         (do (set block.offset (+ size 1))
+             (table.insert batch block)
+             (add-to-batch batches (+ iblock 1) (+ size block.len))))))
+   (add-to-batch [[]] 1 0))
+ :read-batch (fn [self addr-to-len]
+   (let [blocks (icollect [addr len (pairs addr-to-len)] {: addr : len})
+         result {}]
+     (each [_ batch (ipairs (self:split-batches blocks 1450))]
+       (let [msg (.. (int16-to-bytes (length batch))
+                     (table.concat (icollect [_ {: addr : len} (ipairs batch)] (.. (int32-to-bytes addr) (int16-to-bytes len)))))
+             (response data) (self:coro-send self.cmd.read msg)]
+         (assert (= response self.response.data))
+         (each [_ {: addr : len : offset : append-to-addr} (ipairs batch)]
+           (let [read-data (data:sub offset (+ offset len -1))]
+             (if append-to-addr (tset result append-to-addr (.. (. result append-to-addr) read-data))
+               (tset result addr read-data))))))
+     result))
+ :read (fn [self addr len] (. (self:read-batch {addr len}) addr))
+ :write-batch (fn [self addr-to-data]
+   (let [blocks (icollect [addr data (pairs addr-to-data)] {: addr :len (+ (length data) 6) : data})]
+     (each [_ batch (ipairs (self:split-batches blocks 1450))]
+       (print "writing batch of size" (length batch))
+       (let [msg (.. (int16-to-bytes (length batch))
+                     (table.concat (icollect [_ {: addr : data} (ipairs batch)] (.. (int32-to-bytes addr) (int16-to-bytes (length data)) data))))]
+         (self:send self.cmd.write msg self.handle-ack)))))
+ :write (fn [self addr data] (self:write-batch {addr data}))
+ :pause  (fn [self] (self:send self.cmd.pause (int16-to-bytes 0xffff) self.handle-ack))
+ :resume (fn [self] (self:send self.cmd.pause (int16-to-bytes 0) self.handle-ack))
+ :launch (fn [self prg] (self:jump (prg:lookup-addr prg.start-symbol)))
+ :hotswap
+ (fn [self prg-old prg-new]
+   (in-coro (fn []
+     (self:pause)
+     (local hotswap (prg-old:read-hotswap self prg-new))
+     (prg-new:upload self)
+     (prg-new:write-hotswap self hotswap)
+     (self:resume))))
+}

main.lua

@@ -1,9 +1,11 @@
 -- bootstrap the compiler
 fennel = require("lib.fennel")
-table.insert(package.loaders, fennel.make_searcher())
+table.insert(package.loaders, fennel.searcher)
+debug.traceback = fennel.traceback
 fv = fennel.view
 pp = function(x) print(fv(x)) end
 lume = require("lib.lume")
+require("lib.metatable_monkey") -- unbreak luajit ipairs
 -- these set global variables and can't be required after requiring core.strict
 _, luars232 = pcall(function () require("luars232") end)
 

neutgs/game.json

@@ -0,0 +1 @@
+{"tiles":[{"flags":[],"word":"","label":"","gfx":"F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F00F0FF0F0F0F0F0F0F0F0F0F0F0F00F0F0F0F0F0FF0F0F0F0F0F0F0F00A0A0F0F0F0F0F0F0A0AF0F0F0F00A0A0A0A0A0A0F0F0A0A0A0A0A0AF00A0A0A0A0A0A0A0A0A0A0A0A0A0A0A0AF00A0A0A0A0A0A0F0F0A0A0A0A0A0AF0F0F0F00A0A0F0F0F0F0F0F0A0AF0F0F0F0F0F0F0F00F0F0F0F0F0FF0F0F0F0F0F0F0F0F0F0F0F00F0FF0F0F0F0F0F0F0"},{"flags":[],"word":"","label":"","gfx":"F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F00808F0F0F0F0F0F0F0F0F0F0F0F0080808080808F0F0F0F0F0F0F0F008080208020802080808F0F0F0F00808080808020802080808080808F008080808080808080808080808080808F00808080808080808080808080808F0F0F0F008080808020802080208F0F0F0F0F0F0F0F0080808020802F0F0F0F0F0F0F0F0F0F0F0F00808F0F0F0F0F0F0F0"},{"flags":[],"word":"","label":"","gfx":"F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F00904F0F0F0F0F0F0F0F0F0F0F0F0040409090404F0F0F0F0F0F0F0F009090904040909090404F0F0F0F00909040909090404090909040909F004040909040409090904040909040409F00904090904040404090904090909F0F0F0F004090909090904090904F0F0F0F0F0F0F0F0040409090404F0F0F0F0F0F0F0F0F0F0F0F00409F0F0F0F0F0F0F0"},{"flags":[],"word":"","label":"","gfx":"F0F0F0F0F0F0F00707F0F0F0F0F0F0F0F0F0F0F0F0070707070707F0F0F0F0F0F0F0F007070707070707070707F0F0F0F00707070707070707070707070707F00707070707070707070707070707070707070707070707070707070707070707070707070707070707070707070707070707070707070707070707070707070707070707070707070707070707070707070707070707070707070707070707070303070707070707070707070707030303030307070707070707070707030303F00303030307070707070703030303F0F0F0F003030303070703030303F0F0F0F0F0F0F0F0030303030303F0F0F0F0F0F0F0F0F0F0F0F00303F0F0F0F0F0F0F0"},{"flags":[],"word":"","label":"","gfx":"F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F00000F0F0F0F0F0F0F0F0F0F0F0F0F0000A0A0000F0F0F0F0F0F0F0F0F0F0000A0A0303030000F0F0F0F0F0F0F0000A0A00000303030300F0F0F0F0F0000A0A030303000003000AF0F0F0F0000A0A000003030303000A0AF0F0F0000A0A030303000003000A0A0AF0F0000A0A000003030303000A0A0A0AF0000A0A030303000003000A0A0A0A0A000A0A000003030303000A0A0A0A0A0A000A030303000003000A0A0A0A0A0A0AF0000003030303000A0A0A0A0A0A0AF0F0F0F0000003000A0A0A0A0A0AF0F0F0F0F0F0F0F0000A0A0A0A0AF0F0F0F0F0F0F0F0F0F0F0F00A0AF0F0F0F0F0F0F0"}],"platform":"iigs","levels":[{"loadword":"","objects":[],"tickword":"","moveword":"","map":"000000000000000000000000000000000000000000000000000000000000000000000000000000000000002000000000200000000000000000000000000000400000000040000000000000000000000000000040000020204000000000000000000000000000004000004000000000000000000000000000000000402020400000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"}],"tilesets":{"jaye-tileset":"gfx","neut-tileset":"neut"}}

neutgs/init.fnl

@@ -0,0 +1,145 @@
+(local Ssc (require :ssc))
+(local files (require :game.files))
+(local {: pal} (require :editor.tiledraw.iigs))
+(local u2-debug (require :ssc.iigs.u2-debug))
+(local link (require :link))
+(import-macros {:sss ! : compile} :ssc.macros)
+
+(local ssc (Ssc {:parent u2-debug}))
+(compile ssc
+  (require ssc.iigs.bootstub)
+  (require ssc.iigs.toolbox)
+  (require ssc.iigs.graphics)
+
+  (tooltable toolsets
+    ToolsetIntegerMath  0x0100
+    ToolsetText         0x0100
+    ToolsetQuickDraw    0x0100
+    ToolsetEventManager 0x0100
+    5                   0x0100  ; desk manager
+    9                   0x0100) ; ADB
+
+  (buffer hexbuf (cstr "    "))
+
+  (fn printnum (num)
+    (long! (ref hexbuf) (HexIt num))
+    (WriteCString (far-ref hexbuf)))
+
+  (asm event-buffer)
+  (global word event-what)
+  (global long event-msg)
+  (global long event-when)
+  (global word event-y)
+  (global word event-x)
+  (global word event-mod)
+
+  (fn wait-for-key ()
+    (FlushEvents keyDownMask 0)
+    (while (not (GetNextEvent keyDownMask (far-ref event-buffer)))
+      (yield)))
+
+  (define screen-addr 0xe12000)
+  (define screen-size 0x9d00)
+
+  (compile-sprite tile0 [(. files.game.tiles 1 :gfx)] 16 16)
+  (compile-sprite tile1 [(. files.game.tiles 2 :gfx)] 16 16)
+  (compile-sprite tile2 [(. files.game.tiles 3 :gfx)] 16 16)
+  (compile-sprite tile3 [(. files.game.tiles 4 :gfx)] 16 16)
+  (asm tiles (jmp tile0) (nop) (jmp tile1) (nop) (jmp tile2) (nop) (jmp tile3) (nop))
+
+  (form set-palette [(fn [ssc index pal]
+    (let [addr (+ 0xe19e00 (* index 0x20))
+          writes (icollect [icolor [r g b] (ipairs pal)]
+                   [[:lda (bit.bor (bit.lshift r 8) (bit.lshift g 4) b)] [:sta (tostring (+ addr (* icolor 2) -2))]])]
+      (lume.concat [:block] (table.unpack writes))))])
+
+  (global word userID)
+
+  (fn print-numbers-forever ()
+    (let (i 0) (while true
+      (printnum i)
+      (yield)
+      (set! i (+ i 1)))))
+
+  (form itile-to-tile [(fn [ssc itile]
+    [:block (ssc:expr-word itile) [:asl] [:asl] [:clc] [:adc #($1:lookup-addr :tiles)]])])
+
+  (global word with-shadowing 0)
+
+  (fn draw-test-tiles (i)
+    (when with-shadowing (disable-shadow-writes))
+    (let (x 0 y 0 screen 0x2000)
+      (while (< y 37)
+        (let (tile (itile-to-tile (& (+ x y i) 3)))
+          (draw-object screen tile))
+        (set! x (+ x 1))
+        (if (= x 20)
+          (do (set! y (+ y 1))
+              (set! x (if (& y 1) 1 0))
+              (set! screen (+ screen [(+ 12 (* 160 4))])))
+          (set! screen (+ screen 8)))))
+    (when with-shadowing
+      (enable-shadow-writes)
+      (if (= with-shadowing 1)
+          (let (x 0 y 0 screen 0x2000)
+            (while (< y 12)
+              (draw-object screen pei-slam-tile)
+              (set! x (+ x 1))
+              (if (= x 20)
+                (do (set! x 0)
+                    (set! y (+ y 1))
+                    (set! screen (+ screen [(+ 8 (* 1  60 15))])))
+                (set! screen (+ screen 8)))))
+        (let (screen 0x2000 y 0)
+          (while (< y 200)
+            (draw-object screen pei-slam-scanline)
+            (set! screen (+ screen 160))
+            (set! y (+ y 1)))))))
+
+  (fn draw-test-tiles-forever ()
+    (let (i 0)
+      (forever
+        (draw-test-tiles i)
+        (yield)
+        (set! i (+ i 1)))))
+
+  (fn debug-task () (forever [(if (= link.name :udpdebug) [:u2-debug-server-poll] [:do])] (yield)))
+  (far-fn main ()
+    (new-task (ref debug-task))
+
+    (LoadTools (far-ref toolsets))
+    (set! userID (MMStartUp))
+    (IMStartUp)
+    (TextStartUp)
+    (QDStartUp 0x3100 0 0 userID)
+    (EMStartUp 0x3000 0 0 320 0 200 userID)
+    (GrafOn)
+    (ClearScreen 0)
+    (let (screen 0x12000) (while (< screen 0x1a000)
+      (word! screen 0)
+      (set! screen (+ screen 2))))
+    (set-palette 0 [pal])
+    (SetAllSCBs 0)
+
+    (enable-shadow-writes)
+    (draw-test-tiles 0)
+    (wait-for-key)
+    (let (tile-task (new-task (ref draw-test-tiles-forever)))
+      (wait-for-key)
+      (set! with-shadowing 1)
+      (wait-for-key)
+      (set! with-shadowing 2)
+      (wait-for-key)
+      (set! with-shadowing false)
+      (reset-task tile-task (ref yield-forever))
+      (wait-for-key))
+
+    (GrafOff)
+
+    (EMShutDown)
+    (QDShutDown)
+    (TextShutDown)
+    (IMShutDown)
+    (MMShutDown userID)))
+
+(ssc:assemble)

ssc/hotswap.fnl

@@ -0,0 +1,112 @@
+; hotswap support
+(local {: addr-parser} (require :asm.65816))
+(local util (require :lib.util))
+(local {: bytes-to-uint16 : bytes-to-uint24 : int16-to-bytes : int24-to-bytes} util)
+
+; Hotswap theory:
+; The common case is code moving around in memory; even if you are not changing the content of code that
+; is currently executing, any changes to anything mean that pointers to that code will need to change.
+; If you try not to store pointers in globals (when everything is statically allocated, you should explicitly
+; name things, like in Forth) then the main place that persistent pointers to code exist is in call stacks -
+; specifically, the values on the stack consumed by "rts" or "rtl". When hotswapping, we need to walk the
+; callstack and A. find these values, and B. patch them to their new values. For this, we need to be able to
+; map any address that might be returned to from the old program to the new program - we can easily do this
+; by generating symbols for each callsite and setting up a reverse lookup table. We _also_ need to know the
+; stack layout at the time of each call so that we can find the next link in the chain, and to verify that
+; this hasn't changed (if the function has changed enough, then we can't modify it mid-execution).
+
+(fn assert-local-matches [funcname loc-old loc-new]
+  (each [_ key (ipairs [:type :name :returnaddr])]
+    (assert (= (. loc-old key) (. loc-new key)) (.. "Stack mismatch when patching " funcname))))
+
+(fn assert-locals-match [funcname locals-old locals-new]
+  (assert (= (length locals-old) (length locals-new)) (.. "Stack size mismatch when patching " funcname))
+  (each [iloc loc-old (ipairs locals-old)]
+    (assert-local-matches funcname loc-old (. locals-new iloc))))
+
+(fn next-callsite-offset [locals]
+  (var offset 0)
+  (var start-counting false)
+  (each [_ loc (ipairs locals)]
+    (if start-counting (let [size (match loc.type :placeholder 0 :word 2 :long 4)] (set offset (+ offset size)))
+        loc.returnaddr (set start-counting true)))
+  offset)
+
+(fn next-callsite-far? [locals]
+  (var far? false)
+  (each [_ loc (ipairs locals)]
+    (when (and loc.returnaddr (= loc.type :long))
+      (set far? true)))
+  far?)
+
+(fn read-callsite-addr [stack bank far]
+  (if far (bytes-to-uint24 stack 1) ; lowest byte (top of stack) is preserved B register
+          (bit.bor (bytes-to-uint16 stack) (bit.lshift bank 16))))
+
+(fn lookup-callsite [ssc addr]
+  (if (= addr (- (ssc.prg:lookup-addr :yield-forever) 1))
+      {:callsite-sym :yield-forever :locals [] :calling :yield-forever :funcname "<base task>"}
+    (. ssc.addr-to-callsite addr)))
+
+(fn patch-stack [ssc-old ssc-new stack bank far]
+  (if (= (length stack) 0) stack
+      ; top-of-stack should be a callsite; look it up
+    (let [callsite-addr (read-callsite-addr stack bank far)
+          {: callsite-sym : locals : funcname} (assert (lookup-callsite ssc-old callsite-addr)
+                                                 (.. "Top of stack value " callsite-addr " is not a recognized callsite"))
+          new-addr (- (ssc-new.prg:lookup-addr callsite-sym) 1)
+          {:locals new-locals} (lookup-callsite ssc-new  new-addr)
+          new-bank (bit.rshift new-addr 16)
+          _ (when (not far) (assert (= (bit.band callsite-addr 0xff0000) (bit.band new-addr 0xff0000))
+                              (.. funcname " moved banks from " bank " to " new-bank)))
+          _ (print (.. "patching " callsite-sym " from " callsite-addr " to " new-addr))
+          _ (assert-locals-match funcname locals new-locals)
+          new-top (if far (.. (stack:sub 1 1) (int24-to-bytes new-addr))
+                          (int16-to-bytes new-addr))
+          iaftertop (if far 5 3)
+          inextstack (+ iaftertop (next-callsite-offset locals))]
+      (.. new-top (stack:sub iaftertop (- inextstack 1))
+          (if (= funcname ssc-old.prg.start-symbol) (stack:sub inextstack) ; stop when we hit the boot-up function
+            (patch-stack ssc-old ssc-new (stack:sub inextstack) new-bank (next-callsite-far? locals)))))))
+
+(fn split-equally [s size]
+  (values (fn [s iprev] (let [i (+ iprev 1)
+                              istart (+ (* (- i 1) size) 1)
+                              iend (* i size)]
+                          (when (>= (length s) iend) (values i (s:sub istart iend)))))
+          s 0))
+
+(fn read-stacks [link ssc]
+  (let [stack-bounds-addr (ssc.prg:lookup-addr :first-task)
+        stack-bounds-bytes (link:read stack-bounds-addr 4)
+        first-task (bytes-to-uint16 stack-bounds-bytes)
+        last-task (bytes-to-uint16 stack-bounds-bytes 2)
+        task-size 0x100
+        read-size (+ (- last-task first-task) task-size)
+        task-count (/ read-size task-size)
+        task-bytes (link:read first-task read-size)
+        sp-offset (addr-parser ssc.TASK-STACK)]
+    (icollect [_ task (split-equally task-bytes task-size)]
+      (let [sp-addr (bytes-to-uint16 task sp-offset)
+            istackstart (bit.band sp-addr 0xff)
+            stack (task:sub (+ istackstart 2))]
+        {:sp-addr (+ sp-addr 1) : stack}))))
+
+(fn lookup-yield-bank [ssc] (bit.rshift (ssc.prg:lookup-addr :yield) 16))
+(fn filter-nonyielding-stacks [ssc stacks]
+  (let [yield-bank (lookup-yield-bank ssc)]
+    (icollect [_ stack (ipairs stacks)]
+      (let [callsite-addr (read-callsite-addr stack.stack yield-bank false)
+            callsite (lookup-callsite ssc callsite-addr)
+            funcname (?. callsite :calling)]
+        (when (= funcname :yield) stack)))))
+
+(fn hotswap-stacks [link ssc-old ssc-new]
+  (let [stacks (read-stacks link ssc-old)
+        yielding-stacks (filter-nonyielding-stacks ssc-old stacks)]
+    (collect [_ {: sp-addr : stack} (ipairs yielding-stacks)]
+      (let [(success new-stack) (pcall #(patch-stack ssc-old ssc-new stack (lookup-yield-bank ssc-old) false))]
+        (if success (values (tostring sp-addr) new-stack)
+          (error (.. new-stack ": stack at " (string.format "%X" sp-addr))))))))
+
+{: hotswap-stacks}

ssc/iigs/bootstub.fnl

@@ -0,0 +1,61 @@
+(import-macros {:sss ! : compile} :ssc.macros)
+(local link (require :link))
+
+#(compile $1
+   (start-symbol boot)
+   (predef-fn boot () void far)
+   (predef-fn [(or $2 :main)] () void far)
+
+   [(when (not= link.name :udpdebug) (! (do ;udpdebug boots into 16-bit mode
+     (start-symbol boot-8)
+     (org 0x1000)
+     (fn boot-8 ()
+       (asm (clc) (xce) (rep 0x30))  ; disable emulation mode, 16-bit index registers
+       (boot)
+       (asm (sec) (xce))) ; re-enter emulation mode
+   )))]
+
+   (org 0x060000)
+   (require ssc.iigs.toolbox)
+   (require ssc.task)
+
+   (global word BootUserID)
+   (global long BootHandle-00)
+   (global long BootHandle-01)
+   (global long BootHandle-e0)
+   (global long BootHandle-e1)
+   (global long BootHandle-06)
+
+   (far-fn boot ()
+     (save-dp-sp 0x0800)
+     (set-task-base 0x0800) ; space for 8 tasks
+     (save-6502-stack)
+
+     ; http://www.1000bit.it/support/manuali/apple/technotes/pdos/tn.pdos.27.html
+     ; When bootstrapping with no OS, we must reserve
+     (TLStartUp)
+     (LoadOneTool ToolsetMisc 0x0100)
+     (MTStartUp)
+     (set! BootUserID (GetNewID 0x1f00))
+
+     (LoadOneTool ToolsetMemoryManager 0x0100)
+     (set! BootHandle-06 (NewHandle 0xffff BootUserID 0xb017 0x060000))
+     (set! BootHandle-00 (NewHandle 0xb800 BootUserID 0xb017 0x000800))
+     (set! BootHandle-01 (NewHandle 0xb800 BootUserID 0xb017 0x010800))
+     (set! BootHandle-e0 (NewHandle 0x4000 BootUserID 0xb017 0xe02000))
+     (set! BootHandle-e1 (NewHandle 0x8000 BootUserID 0xb017 0xe12000))
+
+     ( [(or $2 :main)] )
+
+     (DisposeHandle BootHandle-e1)
+     (DisposeHandle BootHandle-e0)
+     (DisposeHandle BootHandle-01)
+     (DisposeHandle BootHandle-00)
+     (DisposeHandle BootHandle-06)
+     (DeleteID BootUserID)
+
+     (MTShutDown)
+
+     (restore-6502-stack)
+     (restore-dp-sp)))
+

ssc/iigs/graphics.fnl

@@ -0,0 +1,139 @@
+; IIgs graphical architecture:
+; PREMISE: All small-scale bitmapped graphics are encoded as code that pushes the graphics onto the stack,
+; which has been aligned to the appropriate place to draw said graphics.
+; Jump tables are stored in the main code segment so that eg. tiles can be easily calculated by index, and
+; so we don't have to explicitly pass longs to a regular function.
+
+(import-macros {:sss ! : compile} :ssc.macros)
+(local lume (require :lib.lume))
+(local {: countiter} (require :lib.util))
+
+; Our bitmap compiler is based on MrSprite - http://brutaldeluxe.fr/products/crossdevtools/mrspritetech/
+; sprite is a Lua string, where each byte is made up of two nibbles - the low nibble
+; should be a 16-bit value representing the colour, and the high nibble should be
+; 0 if the pixel is opaque, or f if the pixel is transparent.
+; width should be a multiple of 4.
+(fn preprocess-sprite [sprite w h]
+  ; splits up each horizontal line into two kinds of "runs":
+  ; :solid - each word can be directly written to memory; there is no transparency
+  ; :masked - the word at this location must be bitwise ANDed by :mask and ORed by :word
+  ; words containing nothing but transparent pixels are removed.
+  ; Also determines the most frequently-occurring solid words and distributes them
+  ; to registers.
+  (let [rows [] frequencies {}]
+    (var word 0)
+    (var mask 0)
+    (var isprite 1)
+    (for [y 0 (- h 1)]
+      (let [row []]
+        (var solidrun nil)
+        (for [x 0 (- w 1)]
+          (let [b (string.byte (sprite:sub isprite isprite))
+                pixcolour (bit.band b 0x0f)
+                pixmask (bit.rshift (bit.band b 0xf0) 4)
+                pixshift (match (% x 4) 0 4  1 0  2 12  3 8)]
+            (set word (bit.bor word (bit.lshift pixcolour pixshift)))
+            (set mask (bit.bor mask (bit.lshift pixmask pixshift)))
+            (when (= (% x 4) 3)
+              (when (not= mask 0) (set solidrun nil))
+              (when (= mask 0) ; fully opaque word
+                (when (= solidrun nil)
+                  (set solidrun {:run :solid :x (/ (- x 3) 2) :words []})
+                  (table.insert row solidrun))
+                (table.insert solidrun.words word)
+                (tset frequencies word (+ (or (. frequencies word) 0) 1)))
+              (when (and (not= mask 0) (not= mask 0xffff))
+                (table.insert row {:run :masked :x (/ (- x 3) 2) : word : mask}))
+              (set word 0)
+              (set mask 0))
+            (set isprite (+ isprite 1))))
+        (table.insert rows row)))
+    (local top-frequencies (icollect [word freq (pairs frequencies)] {: word : freq}))
+    (table.sort top-frequencies #(> $1.freq $2.freq))
+    {: rows
+     :registers {:x (?. top-frequencies 1 :word)
+                 :y (?. top-frequencies 2 :word)
+                 :d (?. top-frequencies 3 :word)}}))
+
+(fn compile-row [block row registers]
+  (each [_ run (ipairs row)]
+    (match run.run
+      :solid
+      (let [s-target (+ run.x (* (length run.words) 2) -1)]
+        (lume.push block [:tsc] [:adc (- s-target registers.s)] [:tcs])
+        (set registers.s (- run.x 1))
+        (for [iword (length run.words) 1 -1]
+          (lume.push block
+                     (match (. run.words iword)
+                       registers.x [:phx]
+                       registers.y [:phy]
+                       registers.d [:phd]
+                       word [:pea word]))))
+      :masked
+      (do (var s-offset (- run.x registers.s))
+          (when (> s-offset 127)
+            (lume.push block [:tsc] [:adc s-offset] [:tcs])
+            (set registers.s run.x)
+            (set s-offset 0))
+          (lume.push block [:lda s-offset :s] [:and run.mask] [:ora run.word] [:sta s-offset :s])))))
+
+(fn compile-sprite [sprite w h]
+  (let [{: rows : registers} (preprocess-sprite sprite w h)
+        block (lume.concat [:block]
+                           (when registers.x [[:ldx registers.x]])
+                           (when registers.y [[:ldy registers.y]])
+                           (when registers.d [[:lda registers.d] [:tcd]]))]
+    (set registers.s 0)
+    (each [_ row (ipairs rows)]
+      (compile-row block row registers)
+      (set registers.s (- registers.s 160)))
+    block))
+
+#(compile $1
+  (fn enable-shadow-writes ()  (set! (word-at (ref :0xc035)) (& (word-at (ref :0xc035)) 0xfff1)))
+  (fn disable-shadow-writes () (set! (word-at (ref :0xc035)) (| (word-at (ref :0xc035)) 0x000e)))
+
+  ; The fastest way to draw any graphics on the IIgs is to map the stack pointer to
+  ; video memory, and use stack-pushing instructions to write values. draw-object
+  ; takes a location in video memory and a pointer to a machine code routine called a "drawfn"
+  ; that performs the drawing
+  (global word draw-object-saved-stack 0)
+  (fn draw-object (screen object)
+    (asm (sei)  ; disable interrupts
+         (lda object) (sta [{:abs #(+ ($1:lookup-addr :draw-object-current-object-jump) 1)}]) ; self-modifying code! rewrite the jump target
+         (phd) ; save direct page register
+         (tsc) (sta draw-object-saved-stack) ; save stack
+         (lda screen 2) ; we offset by 2 because we just pushed a word onto the stack and the compiler doesn't know about it
+           (tcs) ; drawfns expect the current screen pointer to be stored in the stack register
+         (lda :0xc068) (ora 0x30) (sta :0xc068) ; move bank 1 to bank 0
+         (clc) ; clear carry - all drawfns will add to the stack pointer and then walk it back
+      draw-object-current-object-jump
+         (jmp draw-object) ; will actually jump to "object"
+      draw-object-finished (export draw-object-finished)
+         (lda :0xc068) (and 0xffcf) (sta :0xc068) ; move bank 1 back to bank 1
+         (lda draw-object-saved-stack) (tcs) ; restore the stack pointer
+         (pld) ; restore direct page register
+         (cli))) ; enable interrupts
+
+  (macrobarrier drawfn)
+  (form drawfn [(lambda [ssc name ...]
+    (let [expr (lume.concat [:do ...] [[:asm [:jmp :draw-object-finished]]])]
+      (ssc:define-fn name nil #(do
+        (local fname (.. "<drawfn " name ">"))
+        (local asm (ssc:expr-poly expr))
+        (ssc:expr-poly [:form name (fn [ssc] (assert (= ssc.locals nil) (.. name " must be called from a drawfn")) [:jmp fname])])
+        (ssc:expr-poly [:define name [:ref fname]])
+        (ssc.org:append fname asm)))))])
+
+  (drawfn pei-slam-tile
+    (asm (tsc) (tcd) (adc 7) (tcs)
+         [(lume.concat [:block] (icollect [_ (countiter 16)]
+            [(! block (pei (:d6)) (pei (:d4)) (pei (:d2)) (pei (:d0))
+                      (tsc) (adc 161) (tcd) (adc 7) (tcs))]))]))
+
+  (drawfn pei-slam-scanline
+    (asm (tsc) (tcd) (adc 159) (tcs)
+         [(lume.concat [:block] (icollect [offset (countiter 158 0 -2)] [:pei [(.. :d offset)]]))]))
+
+  (form compile-sprite [(lambda [ssc name sprite w h] (ssc:expr-poly [:drawfn name [:asm (compile-sprite sprite w h)]]))])
+)

ssc/iigs/toolbox.fnl

@@ -0,0 +1,458 @@
+(import-macros {:sss ! : compile} :ssc.macros)
+(local lume (require :lib.lume))
+(local util (require :lib.util))
+(local {: pairoff} util)
+
+#(compile $1 (do
+  (form def-toolbox [
+    (fn [ssc cmd name args return-type]
+      (let [call (fn [ssc ...]
+                   (let [arg-count (select :# ...)
+                         expected-arg-count (length args)
+                         expected-resultptr (= (type return-type) :number)
+                         expected-arg-count (if expected-resultptr (+ expected-arg-count 1) expected-arg-count)
+                         resultptr (when expected-resultptr (select expected-arg-count ...))
+                         error-handler (when (= arg-count (+ expected-arg-count 1)) (select (+ expected-arg-count 1) ...))
+                         expected-arg-count (if error-handler (+ expected-arg-count 1) expected-arg-count)
+                         block [:block]
+                         iloc-resultptr (do (assert (= arg-count expected-arg-count) (.. name " expected " expected-arg-count " args, got " (fv [...])))
+                                            (when resultptr
+                                              (lume.push block (ssc:push nil resultptr :word))
+                                              (length ssc.locals)))]
+                     (for [_ 1 (match return-type :void 0 :word 1 :long 2 _ return-type)]
+                       (lume.push block (ssc:push nil nil :register)))
+                     (each [_ push (ipairs (ssc:push-arguments (ssc:parse-parameters args) (lume.slice [...] 1 (length args))))]
+                       (lume.push block push))
+                     (lume.push block [:ldx cmd] [:jsr :0xe10000])
+                     (ssc:was-dropped (length args))
+                     (when error-handler
+                       (lume.push block [:bcc :-no-error-]
+                                        (ssc:push :error nil :register) (ssc:expr-poly error-handler) (ssc:drop :error)
+                                        :-no-error-))
+                     (match return-type
+                       :void nil
+                       :word (lume.push block (ssc:pop) nil)
+                       :long (lume.push block (ssc:pop) [:sta ssc.LONG_LO] (ssc:pop) [:sta ssc.LONG_HI])
+                       _     (do (lume.push block [:ldy 0])
+                                       (for [i 1 return-type]
+                                         (lume.push block (ssc:pop) [:sta [(ssc:local-offset iloc-resultptr) :s] :y])
+                                         (when (< i return-type) (lume.push block [:iny] [:iny])))
+                                       (lume.push block (ssc:drop))))
+                     (values block (if (= (type return-type) :string) return-type :void))))]
+      (ssc:expr-poly [:form name call])))])
+
+  (form tooltable [(fn [ssc name ...]
+    (ssc.org:append name [:dw (/ (select :# ...) 2)])
+    (each [_ toolset-id version (pairoff [...])]
+      (ssc.org:append [:dw (match (type toolset-id) :number toolset-id :string (. ssc.constants toolset-id))]
+                      [:dw version])))])
+
+  (define ToolsetToolLocator 0x01)
+  (def-toolbox 0x0201 TLStartUp () void)
+  (def-toolbox 0x0301 TLShutDown () void)
+  (def-toolbox 0x0401 TLVersion () word)
+  (def-toolbox 0x0b01 GetFuncPtr (userOrSystem funcNumTsNum) long)
+  (def-toolbox 0x0f01 LoadOneTool (toolNumber minVersion) void)
+  (def-toolbox 0x0e01 LoadTools ((long toolTablePtr)) void)
+  (def-toolbox 0x1501 MessageCenter (action type (long messageHandle)) void)
+  (def-toolbox 0x1401 RestoreTextState ((long stateHandle)) void)
+  (def-toolbox 0x1301 SaveTextState () long)
+  (def-toolbox 0x1101 TLMountVolume (whereX whereY (long line1ptr) (long line2ptr) (long but1ptr) (long but2ptr)) word)
+  (def-toolbox 0x1201 TLTextMountVolume ((long line1Ptr) (long line2Ptr) (long button1Ptr) (long button2Ptr)) word)
+  (def-toolbox 0x1001 UnloadOneTool (toolNumber) void)
+
+  (define ToolsetIntegerMath 0x0b)
+  (def-toolbox 0x020b IMStartUp () void)
+  (def-toolbox 0x030b IMShutDown () void)
+  (def-toolbox 0x040b IMVersion () word)
+  (def-toolbox 0x060b IMStatus () word)
+  (def-toolbox 0x280b Dec2Int ((long strPtr) strLength signedFlag) word)
+  (def-toolbox 0x290b Dec2Long ((long strPtr) strLength signedFlag) long)
+  (def-toolbox 0x1c0b Fix2Frac ((long fixedValue)) long)
+  (def-toolbox 0x1b0b Fix2Long ((long fixedValue)) long)
+  (def-toolbox 0x1e0b Fix2X ((long fixedValue) (long extendPtr)) void)
+  (def-toolbox 0x170b FixATan2 ((long input1) (long input2)) long)
+  (def-toolbox 0x110b FixDiv ((long dividend) (long divisor)) long)
+  (def-toolbox 0x0f0b FixMul ((long multiplicand) (long multiplier)) long)
+  (def-toolbox 0x0e0b FixRatio (numerator denominator) long)
+  (def-toolbox 0x130b FixRound ((long fixedValue)) word)
+  (def-toolbox 0x1d0b Frac2Fix ((long fracValue)) long)
+  (def-toolbox 0x1f0b Frac2X ((long fracValue) (long extendPtr)) void)
+  (def-toolbox 0x150b FracCos ((long angle)) long)
+  (def-toolbox 0x120b FracDiv ((long dividend) (long divisor)) long)
+  (def-toolbox 0x100b FracMul ((long multiplicand) (long multiplier)) long)
+  (def-toolbox 0x160b FracSin ((long angle)) long)
+  (def-toolbox 0x140b FracSqrt ((long fracValue)) long)
+  (def-toolbox 0x240b Hex2Int ((long strPtr) strLength) word)
+  (def-toolbox 0x250b Hex2Long ((long strPtr) strLength) long)
+  (def-toolbox 0x2a0b HexIt (intValue) long)
+  (def-toolbox 0x180b HiWord ((long longValue)) word)
+  (def-toolbox 0x260b Int2Dec (wordValue (long strPtr) strLength signedFlag) void)
+  (def-toolbox 0x220b Int2Hex (intValue (long strPtr) strLength) void)
+  (def-toolbox 0x270b Long2Dec ((long longValue) (long strPtr) strLength signedFlag) void)
+  (def-toolbox 0x1a0b Long2Fix ((long longIntValue)) long)
+  (def-toolbox 0x230b Long2Hex ((long longValue) (long strPtr) strLength) void)
+  (def-toolbox 0x0d0b LongDivide ((long dividend) (long divisor)) 4) ; -> long remainder, long quotient
+  (def-toolbox 0x0c0b LongMul ((long multiplicand) (long multiplier)) 4) ; -> long msResult, long lsResult
+  (def-toolbox 0x190b LoWord ((long longValue)) word)
+  (def-toolbox 0x090b Multiply (multiplicand multiplier) long)
+  (def-toolbox 0x0a0b SDivide (dividend divisor) long) ; -> word remainder, word quotient
+  (def-toolbox 0x0b0b UDivide (dividend divisor) long) ; -> word remainder, word quotient
+  (def-toolbox 0x200b X2Fix ((long extendPtr)) long)
+  (def-toolbox 0x210b X2Frac ((long extendPtr)) long)
+
+  (define ToolsetMemoryManager 0x02)
+  (def-toolbox 0x0202 MMStartUp () word)
+  (def-toolbox 0x0302 MMShutDown (userID) void)
+  (def-toolbox 0x0402 MMVersion () word)
+  (def-toolbox 0x0602 MMStatus () word)
+  (def-toolbox 0x2b02 BlockMove ((long sourcePtr) (long destPtr) (long count)) void)
+  (def-toolbox 0x1e02 CheckHandle ((long theHandle)) void)
+  (def-toolbox 0x1f02 CompactMem () void)
+  (def-toolbox 0x1102 DisposeAll (userID) void)
+  (def-toolbox 0x1002 DisposeHandle ((long theHandle)) void)
+  (def-toolbox 0x1a02 FindHandle ((long locationPtr)) long)
+  (def-toolbox 0x1b02 FreeMem () long)
+  (def-toolbox 0x1802 GetHandleSize ((long theHandle)) long)
+  (def-toolbox 0x2a02 HandToHand ((long sourceHandle) (long destHandle) (long count)) void)
+  (def-toolbox 0x2902 HandToPtr ((long sourceHandle) (long destPtr) (long count)) void)
+  (def-toolbox 0x2002 HLock ((long theHandle)) void)
+  (def-toolbox 0x2102 HLockAll (userID) void)
+  (def-toolbox 0x2202 HUnlock ((long theHandle)) void)
+  (def-toolbox 0x2302 HUnlockAll (userID) void)
+  (def-toolbox 0x1c02 MaxBlock () long)
+  (def-toolbox 0x0902 NewHandle ((long blockSize) userID attributes (long locationPtr)) long)
+  (def-toolbox 0x2802 PtrToHand ((long sourcePtr) (long destHandle) (long count)) void)
+  (def-toolbox 0x1302 PurgeAll (userID) void)
+  (def-toolbox 0x1202 PurgeHandle ((long theHandle)) void)
+  (def-toolbox 0x0a02 ReAllocHandle ((long blockSize) userID attributes (long locationPtr) (long theHandle)) void)
+  (def-toolbox 0x0b02 RestoreHandle ((long theHandle)) void)
+  (def-toolbox 0x1902 SetHandleSize ((long newSize) (long theHandle)) void)
+  (def-toolbox 0x2402 SetPurge ((long theHandle)) word)
+  (def-toolbox 0x2502 SetPurgeAll (userID newPurgeLevel) void)
+  (def-toolbox 0x1d02 TotalMem () long)
+
+  (define ToolsetText 0x0c)
+  (def-toolbox 0x020c TextStartUp () void)
+  (def-toolbox 0x030c TextShutDown () void)
+  (def-toolbox 0x040c TextVersion () word)
+  (def-toolbox 0x060c TextStatus () word) ; -> activeFlag
+  (def-toolbox 0x160c CtlTextDev (deviceNum controlCode) void)
+  (def-toolbox 0x1f0c ErrWriteBlock ((long textPtr) offset count) void)
+  (def-toolbox 0x190c ErrWriteChar (theChar) void)
+  (def-toolbox 0x210c ErrWriteCString ((long cStrPtr)) void)
+  (def-toolbox 0x1b0c ErrWriteLine ((long strPtr)) void)
+  (def-toolbox 0x1d0c ErrWriteString ((long strPtr)) void)
+  (def-toolbox 0x0e0c GetErrGlobals () long) ; -> word andMask, word orMask
+  (def-toolbox 0x140c GetErrorDevice () 3) ; -> word deviceType, long ptrOrSlot
+  (def-toolbox 0x0c0c GetInGlobals () long) ; -> word andMask, word orMask
+  (def-toolbox 0x120c GetInputDevice () 3) ; -> word deviceType, long ptrOrSlot
+  (def-toolbox 0x0d0c GetOutGlobals () long) ; -> word andMask, word orMask
+  (def-toolbox 0x130c GetOutputDevice () 3) ; -> word deviceType, long ptrOrSlot
+  (def-toolbox 0x150c InitTextDev (deviceNum) void)
+  (def-toolbox 0x220c ReadChar (echoFlag) word)
+  (def-toolbox 0x240c ReadLine ((long bufferPtr) maxCount eolChar echoFlag) word)
+  (def-toolbox 0x0b0c SetErrGlobals (andMask orMask) void)
+  (def-toolbox 0x110c SetErrorDevice (deviceType (long ptrOrSlot)) void)
+  (def-toolbox 0x090c SetInGlobals (andMask orMask) void)
+  (def-toolbox 0x0f0c SetInputDevice (deviceType (long ptrOrSlot)) void)
+  (def-toolbox 0x0a0c SetOutGlobals (andMask orMask) void)
+  (def-toolbox 0x100c SetOutputDevice (deviceType ptrOrSlot) void)
+  (def-toolbox 0x170c StatusTextDev (deviceNum requestCode) void)
+  (def-toolbox 0x230c TextReadBlock ((long bufferPtr) offset blockSize echoFlag) void)
+  (def-toolbox 0x1e0c TextWriteBlock ((long textPtr) offset count) void)
+  (def-toolbox 0x180c WriteChar (theChar) void)
+  (def-toolbox 0x200c WriteCString ((long cStrPtr)) void) ; ptr cStrPtr
+  (def-toolbox 0x1a0c WriteLine ((long strPtr)) void)
+  (def-toolbox 0x1c0c WriteString ((long strPtr)) void)
+
+  (define ToolsetMisc 0x03)
+  (def-toolbox 0x0203 MTStartUp () void)
+  (def-toolbox 0x0303 MTShutDown () void)
+  (def-toolbox 0x0403 MTVersion () word)
+  (def-toolbox 0x0603 MTStatus () word)
+  (def-toolbox 0x0903 WriteBRam ((long bufferPtr)) void)
+  (def-toolbox 0x0a03 ReadBRam ((long bufferPTr)) void)
+  (def-toolbox 0x0b03 WriteBParam (theData paramRefNum) void)
+  (def-toolbox 0x0c03 ReadBParam (paramRefNum) word)
+  (def-toolbox 0x0d03 ReadTimeHex () 4) ; -> bytes: weekDay, null, month, day, curYear, hour, minute, second
+  (def-toolbox 0x0e03 WriteTimeHex (month-day curYear-hour mintue-second) void)
+  (def-toolbox 0x0f03 ReadAsciiTime ((long bufferPtr)) void)
+  (def-toolbox 0x2403 FWEntry (aRegValue xRegValue yRegValue eModeEntryPt) 4) ; words: status, aRegExit, xRegExit, yRegExit
+  (def-toolbox 0x1603 GetAddr (refNum) long)
+  (def-toolbox 0x2503 GetTick () long)
+  (def-toolbox 0x2904 GetIRQEnable () word)
+  (def-toolbox 0x2303 IntSource (srcRefNum) void)
+  (def-toolbox 0x1c03 ClampMouse (xMinCLamp xMaxClamp yMinClamp yMaxClamp) void)
+  (def-toolbox 0x1b03 ClearMouse () void)
+  (def-toolbox 0x1d03 GetMouseClamp () 4) ; words: xMinCLamp, xMaxClamp, yMinClamp, yMaxClamp
+  (def-toolbox 0x1a03 HomeMouse () void)
+  (def-toolbox 0x1803 InitMouse (mouseSlot) void)
+  (def-toolbox 0x1e03 PosMouse (xPos yPos) void)
+  (def-toolbox 0x1704 ReadMouse () 3) ; xPosition, yPosition, byte status, byte mode
+  (def-toolbox 0x1f03 ServeMouse () word)
+  (def-toolbox 0x1903 SetMouse (mouseMode) void)
+  (def-toolbox 0x2a03 SetAbsClamp (xMinClamp xMaxClamp yMinClamp yMaxClamp) void)
+  (def-toolbox 0x2b03 GetAbsClamp () 4) ; xMinClamp xMaxClamp yMinClamp yMaxClamp
+  (def-toolbox 0x2603 PackBytes ((long startHandle) (long sizePtr) (long bufferPtr) bufferSize) word)
+  (def-toolbox 0x2703 UnPackBytes ((long bufferPtr) bufferSize (long startHandle) (long sizePtr)) word)
+  (def-toolbox 0x2803 Munger ((long destPtr) (long destLenPtr) (long targPtr) targLEn (long replPtr) replLen (long padPtr)) word)
+  (def-toolbox 0x1203 SetHeartBeat ((long taskPtr)) void)
+  (def-toolbox 0x1303 DelHeartBeat ((long taskPtr)) void)
+  (def-toolbox 0x1403 ClrHeartBeat () void)
+  (def-toolbox 0x2c03 SysBeep () void)
+  (def-toolbox 0x1503 SysFailMgr (errorCode (long strPtr)) void)
+  (def-toolbox 0x2003 GetNewID (idTag) word)
+  (def-toolbox 0x2103 DeleteID (idTag) void)
+  (def-toolbox 0x2203 StatusID (idTag) void)
+  (def-toolbox 0x1003 SetVector (vectorRefNum (long vectorPtr)) void)
+  (def-toolbox 0x1103 GetVector (vectorRefNum) long)
+
+  (define ToolsetEventManager 0x06)
+  (define nullEvt 0)
+  (define mouseDownEvt 1)
+  (define mouseUpEvt 2)
+  (define keyDownEvt 3)
+  (define autoKeyEvt 5)
+  (define updateEvt 6)
+  (define activeFlag 0x0001)
+  (define changeFlag 0x0002)
+  (define btn1State 0x0040)
+  (define btn0State 0x0080)
+  (define appleKey 0x0100)
+  (define shiftKey 0x0200)
+  (define capsLock 0x0400)
+  (define optionKey 0x0800)
+  (define controlKey 0x1000)
+  (define keyPad 0x2000)
+  (define mDownMask 0x0002)
+  (define mUpMask 0x0004)
+  (define keyDownMask 0x0008)
+  (define autoKeyMask 0x0020)
+  (define updateMask 0x0040)
+  (def-toolbox 0x0206 EMStartUp (dPageAddr queueSize xMinClamp xMaxClamp yMinClamp yMaxClamp userID) void)
+  (def-toolbox 0x0306 EMShutDown () void)
+  (def-toolbox 0x0406 EMVersion () word)
+  (def-toolbox 0x0606 EMStatus () word)
+  (def-toolbox 0x0d06 Button (buttonNum) word)
+  (def-toolbox 0x0b06 EventAvail (eventMask (long eventPtr)) word)
+  (def-toolbox 0x1506 FlushEvents (eventMask stopMask) word)
+  (def-toolbox 0x1206 GetCaretTime () long)
+  (def-toolbox 0x1106 GetDblTime () long)
+  (def-toolbox 0x0c06 GetMouse ((long mouseLocPtr)) void)
+  (def-toolbox 0x0a06 GetNextEvent (eventMask (long eventPtr)) word)
+  (def-toolbox 0x1606 GetOSEvent (eventMask (long eventPtr)) word)
+  (def-toolbox 0x1706 OSEventAvail (eventMask (long eventPtr)) word)
+  (def-toolbox 0x1406 PostEvent (eventCode (long eventMsg)) word)
+  (def-toolbox 0x1806 SetEventMask (sysEventMask) void)
+  (def-toolbox 0x0e06 StillDown (buttonNum) word)
+  (def-toolbox 0x1006 TickCount () long)
+  (def-toolbox 0x0f06 WaitMouseUp (buttonNum) word)
+
+  (define ToolsetQuickDraw 0x04)
+  (def-toolbox 0x0204 QDStartUp (dPageAddr masterSCB maxWidth userID) void)
+  (def-toolbox 0x0304 QDShutDown () void)
+  (def-toolbox 0x0404 QDVersion () word)
+  (def-toolbox 0x0604 QDStatus () word)
+  (def-toolbox 0x8004 AddPt ((long srcPtPtr) (long destPtPtr)) void)
+  (def-toolbox 0xac04 CharBounds (theChar (long resultPtr)) void)
+  (def-toolbox 0xa804 CharWidth (theChar) word)
+  (def-toolbox 0x1504 ClearScreen (colorWord) void)
+  (def-toolbox 0x2604 ClipRect ((long rectPtr)) void)
+  (def-toolbox 0xc204 ClosePoly () void)
+  (def-toolbox 0x1a04 ClosePort ((long portPtr)) void)
+  (def-toolbox 0x6e04 CloseReg ((long rgnHandle)) void)
+  (def-toolbox 0x6904 CopyRgn ((long srcRgnHandle) (long dstRgnHandle)) void)
+  (def-toolbox 0xae04 CStringBounds ((long cStringPtr) (long resultPtr)) void)
+  (def-toolbox 0xaa04 CStringWidth ((long cStringPtr)) word)
+  (def-toolbox 0x7304 DiffRgn ((long rgn1Handle) (long rgn2Handle) (long diffRgnHandle)) void)
+  (def-toolbox 0x6804 DisposeRgn ((long rgnHandle)) void)
+  (def-toolbox 0xa404 DrawChar (theChar) void)
+  (def-toolbox 0xa604 DrawCString ((long cStringPtr)) void)
+  (def-toolbox 0xa504 DrawString ((long stringPtr)) void)
+  (def-toolbox 0xa704 DrawText ((long textPtr) textLength) void)
+  (def-toolbox 0x7804 EmptyRgn ((long rgnHandle)) word)
+  (def-toolbox 0x8304 EqualPt ((long point1Ptr) (long point2Ptr)) word)
+  (def-toolbox 0x5104 EqualRect ((long rect1Ptr) (long rect2Ptr)) word)
+  (def-toolbox 0x7704 EqualRgn ((long rgn1Handle) (long rgn2Handle)) word)
+  (def-toolbox 0x6404 EraseArc ((long rectPtr) startAngle arcAngle) void)
+  (def-toolbox 0x5a04 EraseOval ((long rectPtr)) void)
+  (def-toolbox 0xbe04 ErasePoly ((long polyHandle)) void)
+  (def-toolbox 0x5504 EraseRect ((long rectPtr)) void)
+  (def-toolbox 0x7b04 EraseRgn ((long rgnHandle)) void)
+  (def-toolbox 0x5f04 EraseRRect ((long rectPtr) ovalWidth ovalHeight) void)
+  (def-toolbox 0x6604 FillArc ((long rectPtr) startAngle arcAngle (long patternPtr)) void)
+  (def-toolbox 0x5c04 FillOval ((long rectPtr) (long patternPtr)) void)
+  (def-toolbox 0xc004 FillPoly ((long polyHandle) (long patternPtr)) void)
+  (def-toolbox 0x5704 FillRect ((long rectPtr) (long patternPtr)) void)
+  (def-toolbox 0x7d04 FillRgn ((long rgnHandle) (long patternPtr)) void)
+  (def-toolbox 0x6104 FillRRect ((long rectPtr) ovalWidth ovalHeight (long patternPtr)) void)
+  (def-toolbox 0xcc04 ForceBufDims (maxWidth maxFontHeight maxFBRExtent) void)
+  (def-toolbox 0x6204 FrameArc ((long rectPtr) startAngle arcAngle) void)
+  (def-toolbox 0x5804 FrameOval ((long rectPtr)) void)
+  (def-toolbox 0xbc04 FramePoly ((long polyHandle)) void)
+  (def-toolbox 0x5304 FrameRect ((long rectPtr)) void)
+  (def-toolbox 0x7904 FrameRgn ((long rgnHandle)) void)
+  (def-toolbox 0x5d04 FrameRRect ((long rectPtr) ovalWidth ovalHeight) void)
+  (def-toolbox 0x0904 GetAddress (tableID) long)
+  (def-toolbox 0xb104 GetArcRot () word)
+  (def-toolbox 0xa304 GetBackColor () word)
+  (def-toolbox 0x3504 GetBackPat ((long patternPtr)) void)
+  (def-toolbox 0xd504 GetCharExtra () long)
+  (def-toolbox 0x2504 GetClip ((long rgnHandle)) void)
+  (def-toolbox 0xc704 GetClipHandle () long)
+  (def-toolbox 0x1104 GetColorEntry (tableNumber entryNumber) word)
+  (def-toolbox 0x0f04 GetColorTable (tableNumber (long destTablePtr)) void)
+  (def-toolbox 0x8f04 GetCursorAdr () long)
+  (def-toolbox 0xcf04 GetFGSize () word)
+  (def-toolbox 0x9504 GetFont () long)
+  (def-toolbox 0x9904 GetFontFlags () word)
+  (def-toolbox 0x9704 GetFontGlobals ((long fgRecPtr)) void)
+  (def-toolbox 0xd104 GetFontID () long)
+  (def-toolbox 0x9604 GetFontInfo ((long fontInfoRecPtr)) void)
+  (def-toolbox 0xd904 GetFontLore ((long recordPtr) recordSize) word)
+  (def-toolbox 0xa104 GetForeColor () word)
+  (def-toolbox 0x4504 GetGrafProcs () long)
+  (def-toolbox 0x1704 GetMasterSCB () word)
+  (def-toolbox 0x2904 GetPen () long)
+  (def-toolbox 0x3304 GetPenMask ((long maskPtr)) void)
+  (def-toolbox 0x2f04 GetPenMode () word)
+  (def-toolbox 0x3104 GetPenPat ((long patternPtr)) void)
+  (def-toolbox 0x2d04 GetPenSize ((long pointPtr)) void)
+  (def-toolbox 0x2b04 GetPenState ((long penStatePtr)) void)
+  (def-toolbox 0x3f04 GetPicSave () long)
+  (def-toolbox 0x8804 GetPixel (h v) word)
+  (def-toolbox 0x4304 GetPolySave () long)
+  (def-toolbox 0x1c04 GetPort () long)
+  (def-toolbox 0x1e04 GetPortLoc ((long locInfoPtr)) void)
+  (def-toolbox 0x2004 GetPortRect ((long rectPtr)) void)
+  (def-toolbox 0x4104 GetRgnSave () long)
+  (def-toolbox 0xd804 GetRomFont ((long recordPtr)) void)
+  (def-toolbox 0x1304 GetSCB (scanLine) word)
+  (def-toolbox 0x9f04 GetSpaceExtra () long)
+  (def-toolbox 0x0c04 GetStandardSCB () word)
+  (def-toolbox 0x4904 GetSysField () long)
+  (def-toolbox 0xb304 GetSysFont () long)
+  (def-toolbox 0x9b04 GetTextFace () word)
+  (def-toolbox 0x9d04 GetTextMode () word)
+  (def-toolbox 0xd304 GetTextSize () word)
+  (def-toolbox 0x4704 GetUserField () long)
+  (def-toolbox 0xc904 GetVisHandle () long)
+  (def-toolbox 0xb504 GetVisRgn ((long rgnHandle)) void)
+  (def-toolbox 0x8504 GlobalToLocal ((long pointPtr)) void)
+  (def-toolbox 0x0b04 GrafOff () void)
+  (def-toolbox 0x0a04 GrafOn () void)
+  (def-toolbox 0x9004 HideCursor () void)
+  (def-toolbox 0x2704 HidePen () void)
+  (def-toolbox 0xd704 InflateTextBuffer (newWidth newHeight) void)
+  (def-toolbox 0x0d04 InitColorTable ((long tablePtr)) void)
+  (def-toolbox 0xca04 InitCursor () void)
+  (def-toolbox 0x1904 InitPort ((long portPtr)) void)
+  (def-toolbox 0x4c04 InsetRect ((long rectPtr) dH dV) void)
+  (def-toolbox 0x7004 InsetRgn ((long rgnHandle) dH dV) void)
+  (def-toolbox 0x6504 InvertArc ((long rectPtr) startAngle arcAngle) void)
+  (def-toolbox 0x5b04 InvertOval ((long rectPtr)) void)
+  (def-toolbox 0xbf04 InvertPoly ((long polyHandle)) void)
+  (def-toolbox 0x5604 InvertRect ((long rectPtr)) void)
+  (def-toolbox 0x7c04 InvertRgn ((long rgnHandle)) void)
+  (def-toolbox 0x6004 InvertRRect ((long rectPtr) ovalWidth ovalHeight) void)
+  (def-toolbox 0xc304 KillPoly ((long polyHandle)) void)
+  (def-toolbox 0x3d04 Line (dH dV) void)
+  (def-toolbox 0x3c04 LineTo (h v) void)
+  (def-toolbox 0x8404 LocalToGlobal ((long pointPtr)) void)
+  (def-toolbox 0xc504 MapPoly ((long polyHandle) (long srcRectPtr) (long destRectPtr)) void)
+  (def-toolbox 0x8a04 MapPt ((long pointPtr) (long srcRectPtr) (long destRectPtr)) void)
+  (def-toolbox 0x8b04 MapRect ((long rectPtr) (long srcRectPtr) (long destRectPtr)) void)
+  (def-toolbox 0x8c04 MapRgn ((long mapRgnHandle) (long srcRectPtr) (long destRectPtr)) void)
+  (def-toolbox 0x3b04 Move (dH dV) void)
+  (def-toolbox 0x2204 MovePortTo (h v) void)
+  (def-toolbox 0x3a04 MoveTo (h v) void)
+  (def-toolbox 0x6704 NewRgn () long)
+  (def-toolbox 0x5204 NotEmptyRect ((long rectPtr)) word)
+  (def-toolbox 0x9204 ObscureCursor () void)
+  (def-toolbox 0xc404 OffsetPoly ((long polyHandle) dH dV) void)
+  (def-toolbox 0x4b04 OffsetRect ((long rectPtr) dH dV) void)
+  (def-toolbox 0x6f04 OffsetRgn ((long rgnHandle) dH dV) void)
+  (def-toolbox 0xc104 OpenPoly () long)
+  (def-toolbox 0x1804 OpenPort ((long portPtr)) void)
+  (def-toolbox 0x6d04 OpenRgn () void)
+  (def-toolbox 0x6304 PaintArc ((long rectPtr) startAngle arcAngle) void)
+  (def-toolbox 0x5904 PaintOval ((long rectPtr)) void)
+  (def-toolbox 0x7f04 PaintPixels ((long paintParamPtr)) void)
+  (def-toolbox 0xbd04 PaintPoly ((long polyHandle)) void)
+  (def-toolbox 0x5404 PaintRect ((long rectPtr)) void)
+  (def-toolbox 0x7a04 PaintRgn ((long rgnHandle)) void)
+  (def-toolbox 0x5e04 PaintRRect ((long rectPtr) ovalWidth ovalHeight) void)
+  (def-toolbox 0x3604 PenNormal () void)
+  (def-toolbox 0xd604 PPToPort ((long srcLocPtr) (long srcRectPtr) destX destY transferMode) void)
+  (def-toolbox 0x5004 Pt2Rect ((long point1Ptr) (long point2Ptr) (long rectPtr)) void)
+  (def-toolbox 0x4f04 PtInRect ((long pointPtr) (long rectPtr)) word)
+  (def-toolbox 0x7504 PtInRgn ((long pointPtr) (long rgnHandle)) word)
+  (def-toolbox 0x8604 Random () word)
+  (def-toolbox 0x7604 RectInRgn ((long rectPtr) (long rgnHandle)) word)
+  (def-toolbox 0x6c04 RectRgn ((long rgnHandle) (long rectPtr)) void)
+  (def-toolbox 0xce04 RestoreBufDims ((long sizeInfoPtr)) void)
+  (def-toolbox 0xcd04 SaveBufDims ((long sizeInfoPtr)) void)
+  (def-toolbox 0x8904 ScalePt ((long pointPtr) (long srcRectPtr) (long destRectPtr)) void)
+  (def-toolbox 0x7e04 ScrollRect ((long rectPtr) dH dV (long updateRgnHandle)) void)
+  (def-toolbox 0x4d04 SectRect ((long rect1Ptr) (long rect2Ptr) (long intersectRectPtr)) word)
+  (def-toolbox 0x7104 SectRgn ((long rgn1Handle) (long rgn2Handle) (long destRgnHandle)) void)
+  (def-toolbox 0x1404 SetAllSCBs (newSCB) void)
+  (def-toolbox 0xb004 SetArcRot (arcRotValue) void)
+  (def-toolbox 0xa204 SetBackColor (backColor) void)
+  (def-toolbox 0x3404 SetBackPat ((long patternPtr)) void)
+  (def-toolbox 0xcb04 SetBufDims (maxWidth maxFontHeight maxFBRExtent) void)
+  (def-toolbox 0xd404 SetCharExtra ((long charExtra)) void)
+  (def-toolbox 0x2404 SetClip ((long rgnHandle)) void)
+  (def-toolbox 0xc604 SetClipHandle ((long rgnHandle)) void)
+  (def-toolbox 0x1004 SetColorEntry (tableNumber entryNUmber newColor) void)
+  (def-toolbox 0x0e04 SetColorTable (tableNumber (long srcTablePtr)) void)
+  (def-toolbox 0x8e04 SetCursor ((long cursorPtr)) void)
+  (def-toolbox 0x6a04 SetEmptyRgn ((long rgnHandle)) void)
+  (def-toolbox 0x9404 SetFont ((long newFontHandle)) void)
+  (def-toolbox 0x9804 SetFontFlags (fontFlags) void)
+  (def-toolbox 0xd004 SetFontID ((long fontID)) void)
+  (def-toolbox 0xa004 SetForeColor (foreColor) void)
+  (def-toolbox 0x4404 SetGrafProcs ((long grafProcsPtr)) void)
+  (def-toolbox 0xb604 SetIntUse (useInt) void)
+  (def-toolbox 0x1604 SetMasterSCB (masterSCB) void)
+  (def-toolbox 0x2304 SetOrigin (h v) void)
+  (def-toolbox 0x3204 SetPenMask ((long maskPtr)) void)
+  (def-toolbox 0x2e04 SetPenMode (penMode) void)
+  (def-toolbox 0x3004 SetPenPat ((long patternPtr)) void)
+  (def-toolbox 0x2c04 SetPenSize (penWidth penHeight) void)
+  (def-toolbox 0x2a04 SetPenState ((long penStatePtr)) void)
+  (def-toolbox 0x3e04 SetPicSave ((long picSaveValue)) void)
+  (def-toolbox 0x1b04 SetPort ((long portPtr)) void)
+  (def-toolbox 0x1d04 SetPortLoc ((long locInfoPtr)) void)
+  (def-toolbox 0x1f04 SetPortRect ((long rectPtr)) void)
+  (def-toolbox 0x2104 SetPortSize (portWidth portHeight) void)
+  (def-toolbox 0x8204 SetPt ((long srcPtPtr) h v) void)
+  (def-toolbox 0x8704 SetRandSeed ((long randomSeed)) void)
+  (def-toolbox 0x4a04 SetRect ((long rectPtr) left top right bottom) void)
+  (def-toolbox 0x6b04 SetRectRgn ((long rgnHandle) left top right bottom) void)
+  (def-toolbox 0x1204 SetSCB (scanLine newSCB) void)
+  (def-toolbox 0x3804 SetSolidBackPat (colorNum) void)
+  (def-toolbox 0x3704 SetSolidPenPat (colorNum) void)
+  (def-toolbox 0x9e04 SetSpaceExtra ((long spaceExtra)) void)
+  (def-toolbox 0x8d04 SetStdProcs ((long stdProcRecPtr)) void)
+  (def-toolbox 0xb204 SetSysFont ((long fontHandle)) void)
+  (def-toolbox 0x9a04 SetTextFace (textFace) void)
+  (def-toolbox 0x9c04 SetTextMode (textMode) void)
+  (def-toolbox 0xd204 SetTextSize (textSize) void)
+  (def-toolbox 0x4604 SetUserField ((long userFieldValue)) void)
+  (def-toolbox 0xc804 SetVisHandle ((long rgnHandle)) void)
+  (def-toolbox 0xb404 SetVisRgn ((long rgnHandle)) void)
+  (def-toolbox 0x9104 ShowCursor () void)
+  (def-toolbox 0x2804 ShowPen () void)
+  (def-toolbox 0x3904 SolidPattern (colorNum (long patternPtr)) void)
+  (def-toolbox 0xad04 StringBounds ((long stringPtr) (long resultPtr)) void)
+  (def-toolbox 0xa904 StringWidth ((long stringPtr)) word)
+  (def-toolbox 0x8104 SubPt ((long srcPtPtr) (long destPtPtr)) void)
+  (def-toolbox 0xaf04 TextBounds ((long textPtr) textLength (long resultPtr)) void)
+  (def-toolbox 0xab04 TextWidth ((long textPtr) textLength) word)
+  (def-toolbox 0x4e04 UnionRect ((long rect1Ptr) (long rect2Ptr) (long unionRectPtr)) void)
+  (def-toolbox 0x7204 UnionRgn ((long rgn1Handle) (long rgn2Handle) (long unionRgnHandle)) void)
+  (def-toolbox 0x7404 XorRgn ((long rgn1Handle) (long rgn2Handle) (long xorRgnHandle)) void)
+))
+

ssc/iigs/u2-debug.fnl

@@ -0,0 +1,142 @@
+(import-macros {:sss ! : compile} :ssc.macros)
+(local {: cmd : response} (require :link.udpdebug))
+
+; sudo route add -net 172.24.1.0/24 gw 192.168.2.25
+
+; -VEDRIVE
+; CAT,S1
+; BLOAD UDPDEBUG.SYSTEM, TSYS, A$2000
+; CALL-151
+; 2000S
+
+(local Ssc (require :ssc))
+
+(local ssc (Ssc))
+
+(compile ssc
+  (start-symbol boot-8)
+  (org 0x2000)
+  (fn boot-8 ()
+    (asm (clc) (xce) (rep 0x30)  ; disable emulation mode, 16-bit index registers
+         (jsr debug-server-loop)
+         (sec) (xce))) ; re-enter emulation mode
+
+  (require ssc.stdlib)
+  (require ssc.iigs.toolbox)
+
+  (macro out [#(! (WriteLine (far-ref (pstr [$2]))))])
+
+  (buffer hexbuf (cstr "    "))
+  (fn printnum (num)
+    (long! (ref hexbuf) (HexIt num))
+    (WriteCString (far-ref hexbuf)))
+
+  (require ssc.iigs.uthernet2)
+
+  (fn u2-init-debug-server ()
+    (out "Starting server")
+    (u2-reset)
+    (u2-udp-server-start 6502))
+
+  (buffer u2-debug-buffer 1500)
+
+  (predef-fn u2-debug-server-poll () void far)
+
+  (global word u2-debug-server-paused false)
+  (fn u2-debug-server-cmd-write (msgid)
+    (set! u2-debug-server-paused true)
+    (let (count (word-at (ref u2-debug-buffer)) index 2)
+      (printnum count) (out ": # of blocks to write")
+      (while (> count 0)
+        (let (addr (long-at (+ (ref u2-debug-buffer) index))
+              size (word-at (+ (ref u2-debug-buffer) index 4)))
+          (printnum (hiword addr)) (printnum (loword addr)) (printnum size) (out ": writing")
+          (memcpy (+ (far-ref u2-debug-buffer) index 6) addr size)
+          (set! index (+ index size 6))
+          (set! count (- count 1))))
+      (u2-tx-begin 2)
+      (u2-write msgid)
+      (u2-write [response.ack])
+      (u2-tx-complete)))
+
+  (fn u2-debug-server-cmd-read (msgid)
+    (let (index 6 totalsize 0 count (word-at (ref u2-debug-buffer)))
+      (printnum count) (out ": # of blocks to read")
+      (while (> count 0)
+        (let (size (word-at (+ (ref u2-debug-buffer) index)))
+          (set! totalsize (+ totalsize size))
+          (set! index (+ index 6))
+          (set! count (- count 1))))
+      (u2-tx-begin (+ totalsize 2))
+      (u2-write msgid)
+      (u2-write [response.data])
+      (set! count (word-at (ref u2-debug-buffer)))
+      (set! index 2)
+      (while (> count 0)
+        (let (addr (long-at (+ (ref u2-debug-buffer) index))
+              size (word-at (+ (ref u2-debug-buffer) index 4)))
+          (u2-write-farbuf addr size)
+          (set! index (+ index 6))
+          (set! count (- count 1))))
+      (u2-tx-complete)))
+
+  (fn u2-debug-server-cmd-exec (msgid)
+    (let (val (asm (jsr u2-debug-buffer))
+          longval (asm-long))
+      (u2-tx-begin 8)
+      (u2-write msgid)
+      (u2-write [response.data])
+      (u2-write-word val)
+      (u2-write-word (loword longval))
+      (u2-write-word (hiword longval))
+      (u2-tx-complete)))
+
+  (fn u2-debug-server-cmd-pause (msgid)
+    (set! u2-debug-server-paused (word-at (ref u2-debug-buffer)))
+    (u2-tx-begin 3)
+    (u2-write msgid)
+    (u2-write [response.ack])
+    (u2-write u2-debug-server-paused)
+    (u2-tx-complete)
+    (while u2-debug-server-paused
+      (u2-debug-server-poll)))
+
+  (fn u2-debug-server-cmd-ping (msgid)
+    (u2-tx-begin 2)
+    (u2-write msgid)
+    (u2-write [response.ack])
+    (u2-tx-complete))
+
+  (fn u2-debug-server-cmd (msgid cmd)
+    (if (= cmd [cmd.write]) (u2-debug-server-cmd-write msgid)
+        (= cmd [cmd.read])  (u2-debug-server-cmd-read msgid)
+        (= cmd [cmd.eval])  (u2-debug-server-cmd-exec msgid)
+        (= cmd [cmd.pause]) (u2-debug-server-cmd-pause msgid)
+        (= cmd [cmd.ping])  (u2-debug-server-cmd-ping msgid)))
+
+  (far-fn u2-debug-server-poll ()
+    (let (size (u2-rx-begin))
+      (when size
+        (let (msgid (u2-read)
+              cmd (u2-read))
+            (printnum msgid) (printnum cmd) (out ": Got message!")
+          (u2-read-buf (ref u2-debug-buffer) (- size 2))
+          (u2-rx-complete)
+          (u2-set-tx-dest u2-udp-recv-ip u2-udp-recv-port)
+          (u2-debug-server-cmd msgid cmd)))))
+
+  (fn debug-server-loop ()
+    (TextStartUp)
+    (IMStartUp)
+    (u2-init-debug-server)
+    (forever (u2-debug-server-poll)))
+)
+
+(let [Prodos (require :asm.prodos)
+      prg (ssc:assemble)
+      disk (Prodos "ProDOS_Blank.dsk")]
+  (disk:update-volume-header {:name "UDP.DEBUG"})
+  (disk:add-file "UDPDEBUG.SYSTEM" Prodos.file-type.SYS 0x2000 (. (prg:org 0x2000) :block :bytes))
+  (disk:write "UdpDebug.dsk"))
+
+ssc

ssc/iigs/uthernet2.fnl

@@ -0,0 +1,149 @@
+; uthernet ii driver
+(local config {
+  :gateway [172 24 1 1]
+  :netmask [255 255 255 0]
+  :ip [172 24 1 6]
+  :slot 3
+  :mac [0xAD 0xE9 0xA5 0x4A 0x6D 0x66]
+})
+
+(import-macros {:sss ! : compile} :ssc.macros)
+
+(fn reg [base] (tostring (+ base (* config.slot 16))))
+(let [U2-MODE (reg 0xc084)
+      U2-ADDR-HI (reg 0xc085)
+      U2-ADDR-LO (reg 0xc086)
+      U2-DATA (reg 0xc087)]
+  #(compile $1
+    (macro u2-addr! [#[:word! [:ref U2-ADDR-HI] [:byteswap $2]]])
+    (macro u2-read [#[:byte-at [:ref U2-DATA]]])
+    (macro u2-write [#[:byte! [:ref U2-DATA] $2]])
+    (fn u2-read-word ()
+      (let (hi (u2-read)
+            lo (u2-read))
+        (| (byteswap hi) lo)))
+    (fn u2-write-word (w)
+      (let (hi (& (byteswap w) 0xff)
+            lo (& w 0xff))
+        (u2-write hi)
+        (u2-write lo)))
+
+    (fn u2-read-buf (addr count)
+      (asm (lda count) (tax)
+           (ldy 0)
+           (sep 0x20)
+         loop
+           (lda [U2-DATA])
+           (sta (addr) y)
+           (iny)
+           (dex)
+           (bne loop)
+
+           (rep 0x20)))
+
+    (fn u2-write-buf (addr count)
+      (asm (lda count) (tax)
+           (ldy 0)
+           (sep 0x20)
+         loop
+           (lda (addr) y)
+           (sta [U2-DATA])
+           (iny)
+           (dex)
+           (bne loop)
+
+           (rep 0x20)))
+
+    (fn u2-write-farbuf ((long addr) count)
+      (asm (lda addr) (sta [$1.ADDR_LO])
+           (lda addr 2) (sta [$1.ADDR_HI])
+           (lda count) (tax)
+           (ldy 0)
+           (sep 0x20)
+         loop
+           (lda (([$1.ADDR_LO])) y)
+           (sta [U2-DATA])
+           (iny)
+           (dex)
+           (bne loop)
+
+           (rep 0x20)))
+
+    (asm u2-ipconfig
+         (bytes [config.gateway])
+         (bytes [config.netmask])
+         (bytes [config.mac])
+         (bytes [config.ip]))
+
+    (fn u2-reset ()
+      (byte! (ref [U2-MODE]) 0x80)
+      (byte! (ref [U2-MODE]) 0x03)
+      (u2-addr! 0x0001)
+      (u2-write-buf (ref u2-ipconfig) 18)
+      (u2-addr! 0x0016) (u2-write 0)) ; disable interrupts
+
+    (fn u2-udp-server-start (port)
+      (u2-addr! 0x001a)
+      (u2-write 0x03) ; allocate all 8kb rx buffer to socket 0
+      (u2-write 0x03) ; same, but tx
+      (u2-addr! 0x0400)
+      (u2-write 0x42) ; UDP, filter by MAC
+      (u2-addr! 0x0404) ; set port
+      (u2-write-word port)
+      (u2-addr! 0x0401)
+      (u2-write 0x01)  ; open socket
+      (u2-addr! 0x0403)
+      (printnum (u2-read)) (out ": Opened socket"))
+
+    (fn u2-data-ready ()
+      (u2-addr! 0x0426)
+      (u2-read-word))
+
+    (define u2-buf-mask 0x1fff)
+    (global long u2-udp-recv-ip 0)
+    (global word u2-udp-recv-port 0)
+    (global word u2-udp-recv-size 0)
+    (global word u2-udp-recv-rxrd 0)
+    (fn u2-rx-complete ()
+      (u2-addr! 0x0428)
+      (u2-write-word (+ u2-udp-recv-rxrd 8 u2-udp-recv-size))
+      (u2-addr! 0x0401)
+      (u2-write 0x40)) ; RECV command
+
+    (fn u2-rxtx-ptr (rd base) (+ (& rd u2-buf-mask) base))
+    (fn u2-rx-begin ()
+      (if (u2-data-ready)
+          (do (u2-addr! 0x0428)
+              (set! u2-udp-recv-rxrd (u2-read-word))
+              (let (rxrd (u2-rxtx-ptr u2-udp-recv-rxrd 0x6000))
+                (u2-addr! rxrd)
+                (u2-read-buf (ref u2-udp-recv-ip) 8)
+                ; convert from network order
+                (set! u2-udp-recv-port (byteswap u2-udp-recv-port))
+                (set! u2-udp-recv-size (byteswap u2-udp-recv-size))
+                u2-udp-recv-size))
+        0))
+
+    (fn u2-set-tx-dest ((long ip) port)
+      (u2-addr! 0x040c)
+      (u2-write-word (byteswap (loword ip))) ; ip is always network order
+      (u2-write-word (byteswap (hiword ip)))
+      (u2-write-word port))
+
+    (global word u2-udp-send-size 0)
+    (fn u2-tx-begin (size)
+      (set! u2-udp-send-size size)
+      (let (freesize 0) (while (< freesize size)
+        (u2-addr! 0x0420) (set! freesize (u2-read-word))))
+      (u2-addr! 0x0424)
+      (let (txwr (u2-rxtx-ptr (u2-read-word) 0x4000))
+        (u2-addr! txwr)))
+
+    (fn u2-tx-complete ()
+      (u2-addr! 0x0424)
+      (let (txwr (u2-read-word))
+        (u2-addr! 0x0424)
+        (u2-write-word (+ txwr u2-udp-send-size))
+        (u2-addr! 0x0401)
+        (u2-write 0x20)))  ; SEND command
+  ))

ssc/init.fnl

@@ -0,0 +1,551 @@
+; ssc: the sufficiently simple compiler
+
+; The goal of ssc is to allow simple prefix expressions to be compiled into 65816 code that
+; would run at least as fast or faster than the equivalent threaded Forth code. Complex
+; optimizations are a non-goal; if you want to tune the generated code, go ahead and write
+; the assembly directly.
+
+; * Expressions have 3 data types: word (2 bytes), long (4 bytes), void (0 bytes).
+; * Expressions return their results in different places depending on type - word values are stored in the A register,
+;   long values are stored in the direct page at LONG_LO / LONG_HI.
+; * Data and return addresses are mixed on one stack, unlike Forth.
+; * Function calls take a fixed number of arguments, and return 0 or 1 results. The compiler enforces arity checking.
+; * To call a function taking arguments [arg1 arg2 arg3], all 3 arguments should be pushed to the stack before calling.
+;   When the function takes control, the stack should look like this:
+;     arg1 arg2 arg3 return-address
+; * The caller is responsible for removing all arguments from the stack once the function returns.
+; * The caller is responsible for preserving the A, X and Y registers, if this is desirable.
+; * If the function returns a value, it is stored in the A/LONG register, like any expression.
+; * If a function returns no result, it is not obliged to preserve the A/LONG register.
+; * Multitasking is achieved by overlapping the D and S registers on the same 256-byte page of memory.
+;   Yielding to a new task involves saving the S register, setting the D register to the new task's page,
+;   then setting the S register to the saved value in the old task.
+; * Useful task-local "registers" are kept at the beginning of the page, and the stack grows down from the end of the page.
+;   * DP register list:
+;     * LONG (32-bit "register")
+;     * Last suspended value of S
+;     * Mailbox
+;     * Pointer to next task
+
+; Compiler notes:
+; Expressions are of the form [:function arg1 arg2 arg3]
+; args are either strings (symbols) or numbers
+
+(local Object (require :core.object))
+(local lume (require :lib.lume))
+(local Ssc (Object:extend))
+(local Prg (require :asm.asm))
+(local util (require :lib.util))
+(local {: loword : hiword : pairoff : countiter : condlist : prototype : proxy} util)
+
+(fn Ssc.new [self ?opts]
+  (local opts (or ?opts {}))
+  (set self.prg (Prg.new (or opts.prg (?. opts.parent :prg)) :65816))
+  (set self.forms (prototype (or opts.forms (?. opts.parent :forms) self.__index.forms)))
+  (set self.functions (prototype (or (?. opts.parent :functions) {})))
+  (set self.locals [])
+  (set self.addr-to-callsite {})
+  (set self.modules (prototype (or (?. opts.parent :modules) {})))
+  (set self.constants (prototype (or (?. opts.parent :constants) {:true 0xffff true 0xffff :false 0 false 0})))
+  (set self.macros (prototype (or opts.macros  (?. opts.parent :macros) self.__index.macros)))
+  (set self.macrobarriers (prototype (or (?. opts.parent :macrobarriers) {:fn true :far-fn true :do true})))
+  (set self.setters (prototype (or (?. opts.parent :setters) {})))
+  (set self.dp-vars (or (?. opts.parent :dp-vars) 0))
+  (set self.gensym-count (or (?. opts.parent :gensym-count) 0))
+  (set self.LONG_LO (or (?. opts.parent :LONG_LO) (self:alloc-dp-var)))
+  (set self.LONG_HI (or (?. opts.parent :LONG_HI) (self:alloc-dp-var)))
+  (set self.ADDR_LO (or (?. opts.parent :ADDR_LO) (self:alloc-dp-var)))
+  (set self.ADDR_HI (or (?. opts.parent :ADDR_HI) (self:alloc-dp-var))))
+
+(fn Ssc.alloc-dp-var [self]
+  (let [addr (.. :d self.dp-vars)]
+    (set self.dp-vars (+ self.dp-vars 2))
+    addr))
+
+(fn Ssc.gensym [self ?prefix]
+  (let [sym (.. "<gensym " self.gensym-count (if ?prefix (.. " " ?prefix ">") ">"))]
+    (set self.gensym-count (+ self.gensym-count 1))
+    sym))
+
+(fn Ssc.push [self name expr ?etype]
+  (let [opgen (if (= ?etype :register) {:lo #[:flatten]}
+                (self:expr-opgen expr ?etype))
+        etype (if (= ?etype :register) :word
+                   ?etype ?etype
+                   opgen.hi :long
+                :word)
+        c-setup (when opgen.setup (opgen.setup))
+        c-hi (when opgen.hi [(opgen.hi :lda) [:pha]])
+        loc {: name :type (if c-hi :word :placeholder)}
+        _ (table.insert self.locals loc) ; if we push a high word onto the stack it shifts stack offsets
+        c-lo [(opgen.lo :lda) [:pha]]]
+    (set loc.type etype)
+    (lume.concat [:block c-setup] c-hi c-lo)))
+
+(fn Ssc.remove-local [self ?name]
+  (let [loc (. self.locals (length self.locals))]
+    (when (not= loc.name ?name) (error (.. "Internal stack error: expected " (or ?name "temporary") ", got " (or loc.name "temporary"))))
+    (tset self.locals (length self.locals) nil)
+    loc))
+
+(fn Ssc.drop [self ?name]
+  (match (. (self:remove-local ?name) :type)
+    :word [:ply]
+    :long [:block [:ply] [:ply]]))
+
+(fn Ssc.pop [self ?name]
+  (let [{:type etype} (self:remove-local ?name)]
+    (values (match etype
+              :word [:pla]
+              :long [:block [:pla] [:sta self.LONG_LO] [:pla] [:sta self.LONG_HI]])
+            etype)))
+
+(fn Ssc.was-dropped [self localcount]
+  (set self.locals (lume.slice self.locals 1 (- (length self.locals) localcount))))
+
+(fn Ssc.define-fn [self name locals f]
+  (assert (not (self:defining?)) "Can't nest function definitions")
+  (set self.defining-fn name)
+  (set self.locals (when locals (lume.clone locals)))
+  (set self.callsites {})
+  (let [result (f)]
+    (set self.defining-fn nil)
+    (set self.callsites {})
+    (assert (or (and (= locals nil) (= self.locals nil))
+                (= (length self.locals) (length locals)))
+        (.. "Left locals on stack?? Expected " (fv locals) " got " (fv self.locals)))
+    (set self.locals [])
+    result))
+
+(fn Ssc.defining? [self] (not= self.defining-fn nil))
+
+; operations that work on the accumulator, like adc or sbc
+; optimization strategy: keep the current result in the accumulator, work from the stack or immediate values
+; 1. take "right" arguments and push them (unless already on stack, immediate, or absolute)
+; 2. load left into accumulator
+; 3. apply until done
+(fn Ssc.accumulation-op [self op first ...]
+  (var etype (self:type-expr first))
+  (for [i 1 (select :# ...)] (when (= (self:type-expr (select i ...)) :long) (set etype :long)))
+  (let [args (icollect [_ val (ipairs [...])] (self:push-opgen val))
+        setup (icollect [_ {: setup} (ipairs args)] (when setup (setup)))
+        acc (: self (.. :expr- etype) first)
+        operations (icollect [i addr (ipairs args)] (op etype addr i))
+        cleanup (icollect [_ {: cleanup} (ipairs args)] (when cleanup (cleanup)))]
+    (values (lume.concat [:block] setup [acc] operations cleanup) etype)))
+
+(fn Ssc.simple-accumulator [self op etype {: lo : hi} ?defaulthi]
+  (match etype
+    :word (lo op)
+    :long [:block [:lda self.LONG_LO] (lo op) [:sta self.LONG_LO]
+                  [:lda self.LONG_HI] (if hi (hi op) [op (or ?defaulthi 0)]) [:sta self.LONG_HI]]))
+
+; comparisons assume left-hand side was in accumulator and cmp (right-hand side) was just executed.
+; For lobranch, the branch should execute if the comparison is FALSE; the label passed is for the false branch.
+; For hibranch, the branch should not execute if the low word still needs to be compared; otherwise, $1 is the true branch,
+; and $2 is the false branch.
+(set Ssc.comparisons
+  {:<    {:hibranch #[:block [:bcc $1] [:bne $2]] :lobranch #[:bcs $1] :opposite :>=}
+   :>    {:swap :< :opposite :<=}
+   :>=   {:hibranch #[:block [:bcc $2] [:bne $1]] :lobranch #[:bcc $1] :opposite :<}
+   :<=   {:swap :>= :opposite :>}
+   :=    {:hibranch #[:bne $2] :lobranch #[:bne $1] :opposite :not=}
+   :not= {:hibranch #[:bne $1] :lobranch #[:beq $1] :opposite :=}
+ })
+
+(fn Ssc.rewrite-condition [self cond] ; rewrite comparisons down to primitives - <, >=, =, not=, or, and. "or" and "and" can nest.
+  (match cond
+    (where [op] (?. self.comparisons op :hibranch)) ; already a primitive op
+      cond
+    (where [op lhs rhs] (?. self.comparisons op :swap))
+      [(. self.comparisons op :swap) rhs lhs]
+    [:not [:not expr]]
+      (self:rewrite-condition expr)
+    (where [:not [op lhs rhs]] (?. self.comparisons op :opposite))
+      (self:rewrite-condition [(. self.comparisons op :opposite) lhs rhs])
+    (where [:not [op & tests]] (or (= op :or) (= op :and))) ; !(x||y) => (!x)&&(!y)
+      (lume.concat [(if (= op :or) :and :or)] (icollect [_ test (ipairs tests)] (self:rewrite-condition [:not test])))
+    [:not expr]
+      (self:rewrite-condition [:not (self:rewrite-condition expr)])
+    (where [op & tests] (or (= op :or) (= op :and)))
+      (lume.concat [op] (icollect [_ test (ipairs tests)] (self:rewrite-condition test)))
+    _ [:not= cond 0]))
+
+(fn Ssc.gen-condition [self cond truelabel falselabel ?depth ?branch-when-true]
+  (let [depth (or ?depth 0)
+        cond (self:rewrite-condition cond)
+        [op & args] cond
+        cmp (. self.comparisons op)]
+    (if cmp
+        (let [[lhs rhs] args
+              ropgen (self:push-opgen rhs)
+              pre (when ropgen.setup (ropgen.setup))
+              lopgen (self:expr-opgen lhs)
+              left (when lopgen.setup (lopgen.setup))
+              truebranch (.. :-if-true-cleanup- depth)
+              falsebranch (.. :-if-false-cleanup- depth)
+              hibranch (when lopgen.hi
+                         [(lopgen.hi :lda) (ropgen.hi :cmp) (cmp.hibranch truebranch falsebranch)])
+              lobranch [(lopgen.lo :lda) (ropgen.lo :cmp) (cmp.lobranch falsebranch)]
+              cleanup (if ropgen.cleanup (ropgen.cleanup) [:flatten])
+              post (if cleanup [truebranch cleanup [:brl truelabel] falsebranch cleanup [:brl falselabel]]
+                       ?branch-when-true [[:bra truelabel]])]
+          (lume.concat [:block] [pre] [left] hibranch lobranch post))
+
+        (or (= op :or) (= op :and))
+        (lume.concat [:block]
+                     (icollect [itest test (ipairs args)]
+                       (let [lastclause (= itest (length args))
+                             nextlabel (.. :-next- op :-clause- itest :- depth)
+                             whentrue (if (= op :or) truelabel (if lastclause truelabel nextlabel))
+                             whenfalse (if (= op :or) (if lastclause falselabel nextlabel) falselabel)]
+                         [:block (self:gen-condition test whentrue whenfalse (+ depth 1) (and (= op :or) (not lastclause))) nextlabel])))
+      (error (.. "Internal error: can't handle conditional " op)))))
+
+(fn Ssc.cmp-to-bool [self op ...] (self:expr-poly [:if [op ...] true false]))
+
+(fn Ssc.compile-function-generic [self name args body post-body returnaddr-type call-instruction]
+  (let [arglocals (self:parse-parameters args)]
+    (self:define-fn name (lume.concat arglocals [{:type returnaddr-type :returnaddr true}])
+      #(let [(c-function etype) (self:expr-poly body)]
+         (self.org:append name c-function (table.unpack post-body))
+         {:arity (length args) :args arglocals :org self.org :type etype : name : call-instruction}))))
+
+(fn Ssc.compile-function [self name args ...] (self:compile-function-generic name args [:do ...] [[:rts]] :word :jsr))
+(fn Ssc.compile-far-function [self name args ...] (self:compile-function-generic name args [:do [:asm [:phb] [:phk] [:plb]] ...] [[:plb] [:rtl]] :long :jsl))
+
+(fn Ssc.asm-localify [self block]
+  (icollect [_ inst (ipairs block)]
+    (match inst
+      [op [:ref sym] & rest] [op sym (table.unpack rest)]
+      (where [op loc ?off] (and (= (type loc) :string) (self:local-offset loc)))
+        [op (+ (self:local-offset loc) (or ?off 0)) :s]
+      (where [op [loc ?off] :y]  (and (= (type loc) :string) (self:local-offset loc)))
+        [op [(+ (self:local-offset loc) (or ?off 0)) :s] :y]
+      [:block] (self:asm-localify inst)
+      _        inst)))
+
+(fn string? [v] (= (type v) :string))
+(fn xxxx-at [v] ; matches byte-at, word-at, long-at
+  (when (string? v)
+    (let [(i-at i-done) (v:find :-at)]
+      (when (and i-at (= i-done (length v))) (v:sub 1 (- i-at 1))))))
+
+(fn Ssc.compile-read-at [self ref etype]   ; opgen catches the trivial cases; we have to compile ref to get a pointer
+  (let [opgen (self:expr-opgen ref)
+        pre (when opgen.setup (opgen.setup))
+        load (if opgen.hi [:lda [[self.ADDR_LO]] :y] [:lda [self.ADDR_LO] :y])
+        load (if (= etype :byte) [:block [:rep 0x30] load [:sep 0x30] [:and 0xff]] load)]
+    (values (condlist :block pre (opgen.lo :lda) [:sta self.ADDR_LO]
+                      (when opgen.hi [:block (opgen.hi :lda) [:sta self.ADDR_HI]])
+                      [:ldy 0] load
+                      (when (= etype :long) [:block [:sta self.LONG_LO] [:ldy 2] load [:sta self.LONG_HI]]))
+            (if (= etype :byte) :word etype))))
+
+(set Ssc.forms
+  {:asm (fn [self ...] (if (self:defining?) (self:asm-localify [:block ...]) (self.org:append (table.unpack (self:asm-localify [...])))))
+   :asm-long (fn [self ...] (values (self:asm-localify [:block ...]) :long))
+   :org (lambda [self org] (set self.org (self.prg:org org)))
+   :start-symbol (lambda [self symbol] (set self.prg.start-symbol symbol))
+   :form (lambda [self name func] (tset self.forms name func))
+   :define (lambda [self name val] (tset self.constants name val))
+   :macro (lambda [self name func] (tset self.macros name func))
+   :macrobarrier (lambda [self formname] (tset self.macrobarriers formname true))
+   :setter (lambda [self name arg ...]
+     (assert (= (length arg) 1))
+     (tset self.setters name (self:compile-function (.. :-set- name) arg ...)))
+   :require (lambda [self name ...]
+              (when (= (. self.modules name) nil)
+                (let [mod (util.reload name)
+                      func (if (= (type mod) :function) mod mod.module)]
+                  (tset self.modules name mod)
+                  (func self ...))))
+   :global (lambda [self etype name ?const]
+             (tset self.constants name [(.. etype :-at) [:ref [:quote name]]])
+             (self.org:append [:hot-preserve name
+               (match etype
+                 :byte [:db ?const]
+                 :word [:dw ?const]
+                 :long [:dl ?const]
+                 _ (error (.. "Unrecognized type " (fv etype))))]))
+   :buffer (lambda [self name bytes-or-size]
+             (self.org:append [:hot-preserve name [:bytes (match (type bytes-or-size)
+                                                   :string bytes-or-size
+                                                   :number (string.rep "\x00" bytes-or-size))]]))
+   :do (fn [self ...]
+         (var etype-body :void)
+         (local c-body (lume.concat [:block] (icollect [i (countiter (select :# ...))]
+                                               (let [(expr etype) (self:expr-poly (select i ...))]
+                                                 (set etype-body etype)
+                                                 expr))))
+         (values c-body etype-body))
+   :let (fn [self bindings ...]
+          (let [compiled-bindings     (icollect [_ symbol expr (pairoff bindings)] (self:push symbol expr))
+                (compiled-body etype) (self:expr-poly [:do ...])
+                compiled-cleanup      (icollect [i-half (countiter (/ (length bindings) 2))]
+                                        (self:drop (. bindings (- (length bindings) (* i-half 2) -1))))]
+            (values (lume.concat [:block] compiled-bindings [compiled-body] compiled-cleanup) etype)))
+   :fn (lambda [self name args ...] (tset self.functions name (self:compile-function name args ...)))
+   :far-fn (lambda [self name args ...] (tset self.functions name (self:compile-far-function name args ...)))
+   :predef-fn (lambda [self name args etype ?far]
+                (tset self.functions name {:arity (length args) :args (self:parse-parameters args) :org self.org :type etype : name :call-instruction (if (= ?far :far) :jsl :jsr)}))
+   :if (lambda [self test iftrue ?else ...]
+         (let [(c-true truetype) (self:expr-poly iftrue)
+               iffalse (if (> (select :# ...) 0) [:if ?else ...] ?else)
+               (c-false falsetype) (when (not= iffalse nil) (self:expr-poly iffalse))
+               etype (if (not= truetype falsetype) :void truetype)
+               block [:block (self:gen-condition test :-if-true- :-if-false-) :-if-true- c-true]
+               cl-false (if (not= iffalse nil) [[:bra :-if-done-] :-if-false- c-false :-if-done-]
+                                               [:-if-false-])]
+           (values (lume.concat block cl-false) etype)))
+   :while (lambda [self test ...]
+            (let [block [:block :-loop-top- (self:gen-condition test :-enter-loop- :-exit-loop-) :-enter-loop-]
+                  c-body (self:expr-poly [:do ...])]
+              (values (lume.concat block [c-body [:brl :-loop-top-] :-exit-loop-]) :void)))
+   :forever (lambda [self ...] [:block :-loop-top- (self:expr-poly [:do ...]) [:brl :-loop-top-]])
+   :+ (lambda [self first ...]
+        (self:accumulation-op
+          (fn [etype opgen]
+            (if (and (= etype :word) opgen.const (>= opgen.const -2) (<= opgen.const 2))
+                (match opgen.const  1 [:inc]  2 [:block [:inc] [:inc]]
+                                   -1 [:dec] -2 [:block [:dec] [:dec]])
+              [:block [:clc] (self:simple-accumulator :adc etype opgen)]))
+          first ...))
+   :- (lambda [self first ...]
+        (if (= (select :# ...) 0)
+            (match (self:type-expr first) :word [:block (self:expr-word first) [:eor 0xffff] [:inc]] ; negate with two's complement
+                                          :long (self:expr-poly [:- 0 first])) ; just subtract from 0
+          (self:accumulation-op
+            (fn [etype opgen]
+              (if (and (= etype :word) (>= opgen.const -2) (<= opgen.const 2))
+                  (match opgen.const -1 [:inc] -2 [:block [:inc] [:inc]]
+                                      1 [:dec]  2 [:block [:dec] [:dec]])
+                [:block [:sec] (self:simple-accumulator :sbc etype opgen)]))
+            first ...)))
+    :| (lambda [self first ...] (self:accumulation-op #(self:simple-accumulator :ora $...) first ...))
+    :& (lambda [self first ...] (self:accumulation-op #(self:simple-accumulator :and $...) first ...))
+    :^ (lambda [self first ...] (self:accumulation-op #(self:simple-accumulator :eor $...) first ...))
+    := (lambda [self lhs rhs] (self:cmp-to-bool := lhs rhs))
+    :not= (lambda [self lhs rhs] (self:cmp-to-bool :not= lhs rhs))
+    :< (lambda [self lhs rhs] (self:cmp-to-bool :< lhs rhs))
+    :> (lambda [self lhs rhs] (self:cmp-to-bool :> lhs rhs))
+    :>= (lambda [self lhs rhs] (self:cmp-to-bool :>= lhs rhs))
+    :<= (lambda [self lhs rhs] (self:cmp-to-bool :<= lhs rhs))
+    :not (lambda [self bool] (self:cmp-to-bool :not bool))
+    :or (lambda [self ...] (self:cmp-to-bool :or ...))
+    :and (lambda [self ...] (self:cmp-to-bool :and ...))
+    :loword (lambda [self long]
+              (let [{: lo : setup} (self:expr-opgen long :long)]
+                (lume.concat [:block] [(when setup (setup))] [(lo :lda)])))
+    :hiword (lambda [self long]
+              (let [{: hi : setup} (self:expr-opgen long :long)]
+                (lume.concat [:block] [(when setup (setup))] [(hi :lda)])))
+    :ref (lambda [self label] [:lda #(loword ($1:lookup-addr label))])
+    :far-ref (lambda [self label] (values [:block [:lda #(loword ($1:lookup-addr label))] [:sta self.LONG_LO]
+                                                  [:lda #(hiword ($1:lookup-addr label))] [:sta self.LONG_HI]] :long))
+    :byteswap (lambda [self word] [:block (self:expr-word word) [:xba]])
+    :long (lambda [self value] (values [:block (self:expr-word value) [:sta self.LONG_LO] [:lda 0] [:sta self.LONG_HI]] :long))
+    :byte-at (lambda [self ref] (self:compile-read-at ref :byte))
+    :word-at (lambda [self ref] (self:compile-read-at ref :word))
+    :long-at (lambda [self ref] (self:compile-read-at ref :long))
+    :set! (lambda [self lhs value]
+            (if (and (= (type lhs) :string) (. self.setters lhs))
+                (self:compile-function-call (. self.setters lhs) [value])
+
+                (self:opgen-lhs lhs)
+                (let [{:lo val-lo :hi val-hi : setup} (assert (self:expr-opgen value) (.. (fv value) " did not produce a value"))
+                      c-setup (when setup (setup))
+                      {: lo : hi} (self:opgen-lhs lhs)
+                      c-lo [:flatten (val-lo :lda) (lo :sta)]
+                      c-hi (when hi [:flatten (if val-hi (val-hi :lda) [:lda 0]) (hi :sta)])
+                      block [:block]]
+                  (lume.push block c-setup c-lo c-hi)
+                  (values block :void))
+
+                (and (= (type lhs) :table) (xxxx-at (. lhs 1)))
+                (let [ropgen (self:push-opgen value)
+                      pre1 (when ropgen.setup (ropgen.setup))
+                      lopgen (self:expr-opgen (. lhs 2))
+                      pre2 (when lopgen.setup (lopgen.setup))
+                      etype (xxxx-at (. lhs 1))
+                      store (if lopgen.hi [:sta [[self.ADDR_LO]] :y] [:sta [self.ADDR_LO] :y])
+                      store (if (= etype :byte) [:block [:rep 0x30] store [:sep 0x30]] store)]
+                  (values (condlist :block pre1 pre2 (lopgen.lo :lda) [:sta self.ADDR_LO]
+                                    (when lopgen.hi [:block (lopgen.hi :lda) [:sta self.ADDR_HI]])
+                                    (ropgen.lo :lda) [:ldy 0] store
+                                    (when (= etype :long) [:block (if ropgen.hi (ropgen.hi :lda) [:lda 0]) [:ldy 2] store])
+                                    (when ropgen.cleanup (ropgen.cleanup)))
+                          :void))
+              (error (.. (fv lhs) " not valid as a target of set!"))))
+  })
+(set Ssc.macros
+  {:getter (lambda [self name ...] (let [getter-name (.. "<get " name ">")]
+                                     [:do [:fn getter-name [] ...]
+                                          [:define name [getter-name]]]))
+   :when (lambda [self test ...] [:if test [:do ...]])
+   :byte! (lambda [self ref value] [:set! [:byte-at ref] value])
+   :word! (lambda [self ref value] [:set! [:word-at ref] value])
+   :long! (lambda [self ref value] [:set! [:long-at ref] value])
+   :data (lambda [self bytes]
+     (print "data" bytes (self:defining?))
+     (if (self:defining?) (let [name (self:gensym)] (self:expr-poly [:buffer name bytes]) name)
+       bytes))
+   :pstr (lambda [self str] [:data (.. (string.char (length str)) str)]) ; pascal-style
+   :cstr (lambda [self str] [:data (.. str "\x00")]) ; c-style
+  })
+
+(fn Ssc.local-offset [self name-or-index]
+  (var offset nil)
+  (var stacklen 0)
+  (when self.locals
+    (for [i 1 (length self.locals)]
+      (let [loc (. self.locals i)
+            size (match loc.type :placeholder 0 :word 2 :long 4 _ (error (.. "how big is this local??" (fv loc))))]
+        (set stacklen (+ stacklen size))
+        (when (or (= i name-or-index) (= loc.name name-or-index))
+          (set offset stacklen)))))
+  (when offset (+ (- stacklen offset) 1)))
+
+(fn Ssc.local-type [self name-or-index]
+  (var etype nil)
+  (for [i 1 (length self.locals)]
+    (when (or (= i name-or-index) (= (. self.locals i :name) name-or-index))
+      (set etype (. self.locals i :type))))
+  etype)
+
+(fn Ssc.type-expr [self expr] (let [(_ etype) (self:expr-poly expr)] etype))
+
+; opgen - a small structure that allows for reading a value with many different addressing modes
+; :lo and :hi keys are functions that, when called with an opcode, returns that opcode with the appropriate argument to work on
+; either the low or high word. If :hi does not exist in the structure, then the value represented by the opgen is only word-sized.
+; :setup and :cleanup keys are used by push-opgen to handle generation of the necessary stack manipulation instructions.
+; opgen-const makes the constant available in the :const key so it can be checked and potentially optimized further (+1 -> inc)
+(fn Ssc.opgen-const [self const]
+  {:lo #[$1 (bit.band const 0xffff)] :hi (let [hi (bit.rshift (bit.band const 0xffff0000) 16)] (if (or (= hi 0) (= hi 0xffff)) nil #[$1 hi])) : const})
+
+(fn Ssc.opgen-local [self loc]
+  {:lo #[$1 (self:local-offset loc) :s] :hi (when (= (self:local-type loc) :long) #[$1 (+ (self:local-offset loc) 2) :s])})
+
+(fn Ssc.opgen-symbol [self name etype]
+  (if (= etype :byte) {:lo #[:block [:sep 0x30] [$1 name] [:rep 0x30] (when (= $1 :lda) [:and 0xff])]}
+    {:lo #[$1 name] :hi (when (= etype :long) #[$1 {:abs #(+ ($1:lookup-addr name) 2)}])}))
+
+(fn Ssc.opgen-ref-loc [self name etype]
+  (when (= (self:local-type name) :word) ; long pointer deref is not possible directly from the stack; have to eval and move to LONG register
+    {:lo #[:block [:ldy 0] [$1 [(self:local-offset name) :s] :y]]
+     :hi (when (= etype :long) #[:block [:ldy 2] [$1 [(self:local-offset name) :s] :y]])}))
+
+(fn Ssc.opgen-lhs [self expr]
+  (match [(type expr) expr]
+    (where [:string _] (self:local-offset expr)) (self:opgen-local expr)
+    (where [_ [type-at [:ref name]]] (string? name) (xxxx-at type-at)) (self:opgen-symbol name (xxxx-at type-at))
+    (where [_ [type-at name]] (string? name) (xxxx-at type-at) (self:local-offset name)) (self:opgen-ref-loc name (xxxx-at type-at))))
+
+(fn Ssc.opgen [self expr]
+  (if (= (type expr) :number) (self:opgen-const expr)
+    (self:opgen-lhs expr)))
+
+(fn Ssc.push-opgen [self expr]
+  (or (self:opgen expr)
+      (let [c (self:push nil expr)
+            iloc (length self.locals)]
+        (lume.merge (self:opgen-local iloc) {:setup #c :cleanup #(self:drop)}))))
+
+(fn Ssc.expr-opgen [self expr ?expected-etype]
+  (var opgen (self:opgen expr))
+  (when (not opgen)
+    (let [(c-expr etype) (self:expr-poly expr)]
+      (set opgen (match etype
+                   :word {:setup #c-expr :lo #[:flatten]}
+                   :long {:setup #c-expr :lo #[$1 self.LONG_LO] :hi #[$1 self.LONG_HI]}))))
+  (when (and (= ?expected-etype :long) (= opgen.hi nil)) (set opgen.hi #[$1 0]))
+  (when (and ?expected-etype (= opgen nil)) (error (.. "Expected " ?expected-etype ", got void")))
+  (when (and (= ?expected-etype :word) opgen.hi) (error (.. "Expected word, got long")))
+  opgen)
+
+(fn Ssc.parse-parameters [self params]
+  (icollect [_ param (ipairs params)] (match param
+                                          [:long pname] {:name pname :type :long}
+                                          pname         {:name pname :type :word})))
+
+(fn Ssc.push-arguments [self paramdefs args]
+  (icollect [iarg arg (ipairs args)]
+    (let [atype (. paramdefs iarg :type)
+          c-push (self:push nil arg atype)]
+      c-push)))
+
+(fn Ssc.compile-function-call [self f args]
+  (let [pre (self:push-arguments f.args args)
+        locals (lume.clone self.locals)
+        callid (or (. self.callsites f.name) 0)
+        _ (tset self.callsites f.name (+ callid 1))
+        funcname self.defining-fn
+        callsite-sym (.. "<callsite " funcname " " f.name ":" callid ">")
+        capture-addr (fn [addr] (tset self.addr-to-callsite (- addr 1) {: callsite-sym : locals : funcname :calling f.name}))
+        post (icollect [_ (countiter (length args))] (self:drop))]
+    (values (lume.concat [:block] pre [[f.call-instruction f.name] callsite-sym [:export callsite-sym] [:meta capture-addr]] post) f.type)))
+
+(fn Ssc.enter-expr [self expr]
+  (let [m (getmetatable expr)]
+    (when (and m m.filename) (set self.expr-metadata m))))
+
+(fn Ssc.expr-index [self expr index] (self:expr-expand (. expr index)))
+
+(fn Ssc.expr-expand [self expr]
+  (let [mt (or (getmetatable expr) {})
+        expanded (match expr
+                   [:quote rawsymbol] rawsymbol
+                   (where c (. self.constants c)) (self:expr-expand (. self.constants c))
+                   (where [m & args] (. self.macros m)) (self:expr-expand ((. self.macros m) self (table.unpack args)))
+                   _ expr)]
+    (if (= (type expanded) :table) (proxy expanded #(self:expr-expand $1))
+      expanded)))
+
+(fn Ssc.expr-poly [self expr]
+  (self:enter-expr expr)
+  (let [meta (or self.expr-metadata {:filename "<unknown>" :line "??"})
+        expr (self:expr-expand expr)
+        (success c-expr etype)
+        (pcall #(match expr
+                  (where lit (?. (self:opgen lit) :hi)) (let [{: lo : hi} (self:opgen lit)]
+                    (values [:block (lo :lda) [:sta self.LONG_LO] (hi :lda) [:sta self.LONG_HI]] :long))
+                  (where lit (?. (self:opgen lit) :lo)) (let [{: lo} (self:opgen lit)] (values (lo :lda) :word))
+                  (where [func & args] (= (?. self.functions func :arity) (length args)))
+                    (self:compile-function-call (. self.functions func) args)
+                  (where [form & args] (. self.forms form))
+                    (let [f (. self.forms form)
+                          (cexpr etype) (f self (table.unpack args))]
+                      (values cexpr (or etype :word)))
+                  nil (values [:block] :void)
+                  _ (error (.. "Unrecognized expression"))))]
+    (if success (do (when (and c-expr (= (getmetatable c-expr) nil)) (setmetatable c-expr meta))
+                    (values c-expr etype))
+      (let [{: filename : line} meta] (error (.. filename "@" line ": " c-expr "\n" (fv expr)))))))
+
+(fn Ssc.expr-word [self expr]
+  (let [(c etype) (self:expr-poly expr)]
+    (when (not= etype :word) (error (.. "Unexpected long or void in " (fv expr) " - please wrap in explicit truncation form")))
+    c))
+
+(fn Ssc.expr-long [self expr]
+  (let [(c etype) (self:expr-poly expr)]
+    (match etype
+      :long c
+      :word [:block c [:sta self.LONG_LO] [:lda 0] [:sta self.LONG_HI]]
+      _ (error (.. "Unexpected type " (fv etype) " in " (fv expr) " - wanted long or word")))))
+
+(fn Ssc.compile [self ...]
+  (for [i 1 (select :# ...)]
+    (self:expr-poly (select i ...)))
+  self)
+
+(fn Ssc.assemble [self]
+  (self.prg:assemble)
+  (set self.prg.source self)
+  self.prg)
+
+(fn Ssc.read-hotswap [self machine prg-new]
+  (local {: hotswap-stacks} (require :ssc.hotswap))
+  (hotswap-stacks machine self prg-new.source))
+
+Ssc

ssc/macros.fnl

@@ -0,0 +1,31 @@
+; Sufficiently Simple Syntax macro
+; This is basically just a quote that converts fennel syntax to Lua tables.
+; Turns symbols into strings and lists into table literals. Table literals can be used to escape into regular fennel.
+; Examples:
+;    (let (x 1 y 2) (+ "x" :y))
+; => [:let [:x 1 :y 2] [:+ :x :y]]
+;    (form mymacro [(fn [ssc] (ssc:compile-expr [:+ 1 2]))])
+; => [:form :mymacro (fn [ssc] (ssc:compile-expr [:+ 1 2]))]
+
+(fn attach-metadata [form result]
+  (if (list? form)
+      (let [{: filename : line : bytestart : byteend} form]
+        `(setmetatable ,result ,{: filename : line : bytestart : byteend}))
+    result))
+
+(fn form-to-fnl [form]
+  (attach-metadata form
+    (if (sym? form)      (tostring form)
+        (sequence? form) (. form 1) ; escape
+        (list? form)     (icollect [_ inner-form (ipairs form)] (form-to-fnl inner-form))
+      form)))
+
+(fn sss [...]
+  (let [result `(values)]
+    (for [i 1 (select :# ...)]
+      (table.insert result (form-to-fnl (select i ...))))
+    result))
+
+(fn compile [ssc ...] `(: ,ssc :compile ,(sss ...)))
+
+{: sss : form-to-fnl : compile}

ssc/notes.txt

@@ -0,0 +1,6 @@
+- Could custom forms compile to opgens?? What would this look like?
+  * see far-ref - it's really a constant, there's no reason to stuff the result into the temporary register just to push it onto the stack
+  * if you call expr-poly / expr-word / expr-long, then put it into the register
+  * but if you call expr-opgen, just return it! (opgen.setup) returns the appropriate code if needed
+  * toolbox calls could actually benefit from this! function calls, not so much
+  * currently expr-opgen is assumed to not have a cleanup step - this could complicate things

ssc/stdlib.fnl

@@ -0,0 +1,17 @@
+(import-macros {:sss ! : compile} :ssc.macros)
+
+#(compile $1
+  (fn memcpy ((long src) (long dst) count)
+    (let (bank (| (hiword dst) (byteswap (hiword src))))
+      (asm (lda bank)
+           (sta [{:abs #(+ ($1:lookup-addr :inst) 1)}])
+           (lda src) (tax)
+           (lda dst) (tay)
+           (lda count)
+           (dec)
+           (phb)
+         inst
+           (mvn 0 0)
+           (plb))))
+ )
+

ssc/task.fnl

@@ -0,0 +1,58 @@
+(import-macros {:sss ! : compile} :ssc.macros)
+(local {: addr-parser} (require :asm.65816))
+
+#(compile $1
+  [(do (set $1.TASK-NEXT ($1:alloc-dp-var))
+       (set $1.TASK-STACK ($1:alloc-dp-var))
+       (set $1.TASK-MAILBOX ($1:alloc-dp-var))
+       nil)]
+  (global word old-dp 0)
+  (global word old-sp 0)
+
+  (form save-dp-sp    [#[:block [:tdc] [:sta :old-dp] [:tsc] [:sta :old-sp]]])
+  (form restore-dp-sp [#[:block [:lda :old-dp] [:tcd] [:lda :old-sp] [:tcs]]])
+  (form save-6502-stack    [#[:block [:tsc] [:tay] [:and 0xff] [:ora 0x100] [:tax] [:eor 0xffff] [:clc] [:adc 0x200] [:phb] [:mvn 0 0] [:plb]]])
+  (form restore-6502-stack [#[:block [:tsc] [:tax] [:and 0xff] [:ora 0x100] [:tay] [:eor 0xffff] [:clc] [:adc 0x200] [:phb] [:mvn 0 0] [:plb]]])
+; 0x1ef = 0x1ef-0x1ff = 0x0f -> 0x7f
+  (define task-size 0x100)
+  (global word first-task)
+  (global word last-task)
+
+  (form set-task-base [(fn [ssc task-base]
+    [:block [:lda task-base] [:tcd]
+            [:sta ssc.TASK-NEXT] [:sta :first-task] [:sta :last-task]
+            [:tsc] [:and 0xff] [:ora task-base] [:tcs]])])
+
+  (fn yield ()
+    (asm (tsc) (sta [$1.TASK-STACK]) ;  
+         debug-stub on-hotswap (export debug-stub) (export on-hotswap) ; todo: cleanup mame hotswap logic
+         (lda [$1.TASK-NEXT]) (tcd)
+         (lda [$1.TASK-STACK]) (tcs)))
+
+  (fn yield-forever () (while true (yield)))
+
+  (fn reset-task (task f)
+    ; setup stack
+    (word! (long (+ task 0xfe)) (- (ref yield-forever) 1)) ; allow tasks to return; rts adds one to the value on the stack for the next pc
+    (word! (long (+ task 0xfc)) (- f 1))                   ; yield will return to this address
+    (word! (long (+ task [(addr-parser $1.TASK-STACK)]))   (+ task 0xfb)) ; stack pointer is the next available location
+    (word! (long (+ task [(addr-parser $1.TASK-MAILBOX)])) 0)             ; clear mailbox
+  )
+
+  (fn new-task (f)
+    (let (next-task (+ last-task task-size))
+      (reset-task next-task f)
+      (word! (long (+ next-task [(addr-parser $1.TASK-NEXT)])) first-task) ; the last task yields to the first task, round-robin
+      (word! (long (+ last-task [(addr-parser $1.TASK-NEXT)])) next-task)  ; the previously-last task now yields to us
+      (set! last-task next-task)
+      next-task))
+
+  (form current-task [#[:tdc]])
+
+  (fn task-send (task msg)
+    (word! (long (+ task [(addr-parser $1.TASK-MAILBOX)])) msg))
+
+  (form task-peek [#[:lda $1.TASK-MAILBOX]])
+
+  (fn task-recv ()
+    (asm (ldx [$1.TASK-MAILBOX]) (lda 0) (sta [$1.TASK-MAILBOX]) (txa))))

wrap.fnl

@@ -10,6 +10,8 @@
 (local translate (require :core.doc.translate))
 (local files (require :game.files))
 
+(setmetatable _G nil)
+
 (command.add nil {
   "honeylisp:open-project" (fn []
     (core.command_view:enter "Open Project"
@@ -23,6 +25,14 @@
             (table.insert files item.filename)))
         (common.fuzzy_match files text))))})
 
+(fn selected-symbol []
+  (local ldoc core.active_view.doc)
+  (var (aline acol bline bcol) (ldoc:get_selection))
+  (when (and (= aline bline) (= acol bcol))
+    (set (aline acol) (translate.start_of_word ldoc aline acol))
+    (set (bline bcol) (translate.end_of_word ldoc bline bcol)))
+  (ldoc:get_text aline acol bline bcol))
+
 (command.add #(link.machine:connected?) {
   "honeylisp:upload" (fn []
     (local p (util.reload "game"))
@@ -48,18 +58,20 @@
     (editor.inline-eval vm-eval))
 })
 
+(command.add #(and (link.machine:connected?) link.machine.set-bp) {
+  "honeylisp:set-breakpoint" (fn []
+    (local word (selected-symbol))
+    (local p (require "game"))
+    (local addr (p:lookup-addr word))
+    (if addr (do (link.machine:set-bp addr)
+                 (core.log (.. "Set breakpoint at " addr)))
+      (core.log (.. "Unknown address for " word))))
+})
+
 (command.add (fn [] true) {
   "honeylisp:rebuild" #(util.reload "game")
 })
 
-(fn selected-symbol []
-  (local ldoc core.active_view.doc)
-  (var (aline acol bline bcol) (ldoc:get_selection))
-  (when (and (= aline bline) (= acol bcol))
-    (set (aline acol) (translate.start_of_word ldoc aline acol))
-    (set (bline bcol) (translate.end_of_word ldoc bline bcol)))
-  (ldoc:get_text aline acol bline bcol))
-
 (command.add "core.docview" {
   "fennel:eval" #(editor.inline-eval #(fv (fennel.eval $1 {:env _G :compiler-env _G}) {}))
   "lume:hotswap" (fn []
@@ -83,6 +95,7 @@
   "alt+v" "honeylisp:vm-eval"
   "alt+r" "lume:hotswap"
   "alt+a" "honeylisp:address"
+  "alt+b" "honeylisp:set-breakpoint"
   "alt+l" "honeylisp:reload"
 })