refactor set!, byte-at, word-at, long-at

lib/util.fnl

@@ -128,8 +128,10 @@
       (let [i (if iprev (+ iprev step) min)]
         (when (if (> step 0) (<= i max) (>= i max)) i)))))
 
+(fn condlist [...] (let [l []] (lume.push l ...) l))
+
 {: int8-to-bytes : int16-to-bytes : int24-to-bytes : int32-to-bytes : bytes-to-uint8 : bytes-to-uint16 : bytes-to-uint24
- : splice : lo : hi : loword : hiword
+ : splice : lo : hi : loword : hiword : condlist
  : reload : hotswap : swappable :require swappable-require : hot-table : nested-tset : pairoff : countiter
  : readjson : writejson : file-exists : waitfor : in-coro : multival}
 

link/udpdebug.fnl

@@ -3,7 +3,7 @@
 (local {: int16-to-bytes : int32-to-bytes : lo} (require :lib.util))
 
 (local config {
-  :host "pi.local"
+  :host "rat.local"
   :port 6502
 })
 
@@ -53,6 +53,7 @@
          (let [msgid (string.byte (data:sub 1 1))
                cmd   (string.byte (data:sub 2 2))
                pendingfn (. self.pending msgid)]
+           (print msgid cmd)
            (when pendingfn
              (tset self.pending msgid nil)
              (pendingfn self cmd (data:sub 3))))))))

ssc/iigs/bootstub.fnl

@@ -3,14 +3,14 @@
 
 #(compile $1
    (start-symbol boot)
-   [(when (not= link.name :udpdebug) (! ;udpdebug boots into 16-bit mode
+   [(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
             (jsr boot)
             (sec) (xce))) ; re-enter emulation mode
-   ))]
+   )))]
 
    (org 0x060000)
    (require ssc.iigs.toolbox)

ssc/iigs/u2-debug.fnl

@@ -1,6 +1,8 @@
 (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

ssc/iigs/uthernet2.fnl

@@ -15,7 +15,7 @@
       U2-ADDR-LO (reg 0xc086)
       U2-DATA (reg 0xc087)]
   #(compile $1
-    (fn u2-addr! (addr) (word! (ref [U2-ADDR-HI]) (byteswap addr)))
+    (form u2-addr! [#($1:expr-poly [:word! [:ref U2-ADDR-HI] [:byteswap $2]])])
     (form u2-read [#($1:expr-poly [:byte-at [:ref U2-DATA]])])
     (form u2-write [#($1:expr-poly [:byte! [:ref U2-DATA] $2])])
     (fn u2-read-word ()

ssc/init.fnl

@@ -37,7 +37,7 @@
 (local Ssc (Object:extend))
 (local Prg (require :asm.asm))
 (local util (require :lib.util))
-(local {: loword : hiword : pairoff : countiter} util)
+(local {: loword : hiword : pairoff : countiter : condlist} util)
 
 (fn Ssc.new [self ?opts]
   (local opts (or ?opts {}))
@@ -208,6 +208,23 @@
       [: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 [:block ...] :long))
@@ -306,61 +323,42 @@
     :byteswap (lambda [self word] [:block (self:expr-word word) [:xba]])
     ; TODO: maybe handle a few different addressing modes here? re-use if the value is already on the stack?
     ; TODO: automatically handle far-ref
-    :byte! (lambda [self ref value]
+    :byte! (lambda [self ref value] (self:expr-poly [:set! [:byte-at ref] value]))
-             (let [(c-addr reftype) (self:expr-poly ref)]
+    :word! (lambda [self ref value] (self:expr-poly [:set! [:word-at ref] value]))
-               (values (match reftype
+    :long! (lambda [self ref value] (self:expr-poly [:set! [:long-at ref] value]))
-                         :word [:block c-addr [:sta self.ADDR_LO] (self:expr-word value) [:ldy 0] [:sep 0x30] [:sta [self.ADDR_LO] :y] [:rep 0x30]]
-                         :long [:block c-addr [:lda self.LONG_LO] [:sta self.ADDR_LO] [:lda self.LONG_HI] [:sta self.ADDR_HI]
-                                       (self:expr-word value) [:sep 0x30] [:sta [[self.ADDR_LO]]] [:rep 0x30]]
-                         _ (error (.. "Unknown reference type " reftype)))
-                       :void)))
-    :word! (lambda [self ref value]
-             (let [(c-addr reftype) (self:expr-poly ref)]
-               (values (match reftype
-                         :word [:block c-addr [:sta self.ADDR_LO] (self:expr-word value) [:ldy 0] [:sta [self.ADDR_LO] :y]]
-                         :long [:block c-addr [:lda self.LONG_LO] [:sta self.ADDR_LO] [:lda self.LONG_HI] [:sta self.ADDR_HI]
-                                       (self:expr-word value) [:sta [[self.ADDR_LO]]]]
-                         _ (error (.. "Unknown reference type " reftype)))
-                       :void)))
-    :long! (lambda [self ref value] [:block (self:push nil ref :word)
-                                            (self:expr-long value) [:ldy 0] [:lda self.LONG_LO] [:sta [1 :s] :y] [:iny] [:iny] [:lda self.LONG_HI] [:sta [1 :s] :y]
-                                            (self:drop)])
     :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]
+    :byte-at (lambda [self ref] (self:compile-read-at ref :byte))
-               (local (c-ref etype) (self:expr-poly ref))
+    :word-at (lambda [self ref] (self:compile-read-at ref :word))
-               (if (= etype :word)
+    :long-at (lambda [self ref] (self:copmile-read-at ref :long))
-                   [:block (self:push nil ref :word) [:ldy 0] [:sep 0x30] [:lda [1 :s] :y] [:rep 0x30] [:and 0xff] (self:drop)]
-
-                   (= etype :long)
-                   [:block c-ref [:ldy 0] [:sep 0x30] [:lda [[self.LONG_LO]] :y] [:rep 0x30] [:and 0xff]]))
-    :word-at (lambda [self ref]
-               (local (c-ref etype) (self:expr-poly ref))
-               (if (= etype :word)
-                   [:block (self:push nil ref :word) [:ldy 0] [:lda [1 :s] :y] (self:drop)]
-
-                   (= etype :long)
-                   [:block c-ref [:ldy 0] [:lda [[self.LONG_LO]] :y]]))
-
-    :long-at (lambda [self ref]
-               (local (c-ref etype) (self:expr-poly ref))
-               (if (= etype :word)
-                   (values [:block (self:push nil ref :word) [:ldy 0] [:lda [1 :s] :y] [:sta self.LONG_LO] [:iny] [:iny] [:lda [1 :s] :y] [:sta self.LONG_HI] (self:drop)]
-                           :long)
-
-                   (= etype :long)
-                   (values [:block c-ref [:ldy 0] [:lda [[self.LONG_LO]] :y] [:tax] [:iny] [:iny] [:lda [[self.LONG_LO]] :y] [:sta self.LONG_HI] [:stx self.LONG_LO]]
-                           :long)))
     :set! (lambda [self lhs value]
             (if (and (= (type lhs) :string) (. self.setters lhs))
                 (self:compile-function-call (. self.setters lhs) [value])
-              (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))
+                (self:opgen-lhs lhs)
-                    {: lo : hi} (assert (self:opgen-lhs lhs) (.. (fv lhs) " not valid as a target of set!"))
+                (let [{:lo val-lo :hi val-hi : setup} (assert (self:expr-opgen value) (.. (fv value) " did not produce a value"))
-                    c-lo [:flatten (val-lo :lda) (lo :sta)]
+                      c-setup (when setup (setup))
-                    c-hi (when hi [:flatten (if val-hi (val-hi :lda) [:lda 0]) (hi :sta)])
+                      {: lo : hi} (self:opgen-lhs lhs)
-                    block [:block]]
+                      c-lo [:flatten (val-lo :lda) (lo :sta)]
-                (lume.push block c-setup c-lo c-hi)
+                      c-hi (when hi [:flatten (if val-hi (val-hi :lda) [:lda 0]) (hi :sta)])
-                block)))
+                      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!"))))
   })
 
 (fn Ssc.local-offset [self name-or-index]
@@ -396,7 +394,8 @@
   {: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]
-  {:lo #[$1 name] :hi (when (= etype :long) #[:block [:ldy 2] [$1 name :y]])}) ; this is stupid - the assembler should be able to calculate addr + 2
+  (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-global [self name] (self:opgen-symbol name (. self.globals name :type)))
 
@@ -405,22 +404,12 @@
     {: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-ref-global [self name etype]
-  (match (. self.globals name :type)
-    :word {:lo #[:block [:ldy 0] [$1 [name] :y]] :hi (when (= etype :long) #[:block [:ldy 2] [$1 [name] :y]])}
-    :long {:lo #[:block [:ldy 0] [$1 [[name]] :y]] :hi (when (= etype :long) #[:block [:ldy 2] [$1 [[name]] :y]])}))
-
-(fn string? [v] (= (type v) :string))
 (fn Ssc.opgen-lhs [self expr]
   (match [(type expr) expr]
     [:string _] (if (self:local-offset expr) (self:opgen-local expr)
                     (. self.globals expr)    (self:opgen-global expr))
-    (where [_ [:word-at [:ref name]]] (string? name)) (self:opgen-symbol name :word)
+    (where [_ [type-at [:ref name]]] (string? name) (xxxx-at type-at)) (self:opgen-symbol name (xxxx-at type-at))
-    (where [_ [:long-at [:ref name]]] (string? name)) (self:opgen-symbol name :long)
+    (where [_ [type-at name]] (string? name) (xxxx-at type-at) (self:local-offset name)) (self:opgen-ref-loc name (xxxx-at type-at))))
-    (where [_ [:word-at name]] (string? name)) (if (self:local-offset name) (self:opgen-ref-loc name :word)
-                                                   (. self.globals name)    (self:opgen-ref-global name :word))
-    (where [_ [:long-at name]] (string? name)) (if (self:local-offset name) (self:opgen-ref-loc name :long)
-                                                   (. self.globals name)    (self:opgen-ref-global name :long))))
 
 (fn Ssc.opgen [self expr]
   (if (= (type expr) :number) (self:opgen-const expr)