Add globals, test various pointer setting

asm/asm.fnl

@@ -1,5 +1,5 @@
 (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"))
 
 (fn make-env [block parent]
   {:parent parent
@@ -75,6 +75,7 @@
 
   (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.dl [dl]       {:type :var :init (. dl 4) :size 4})
   (fn dat-parser.bytes [bytes] {:type :raw :bytes (. bytes 2)})
   (fn dat-parser.ref [ref]     {:type :ref :target (. ref 2)})
   (fn dat-parser.flatten [flat block]
@@ -127,6 +128,8 @@
     (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)))

lib/util.fnl

@@ -17,7 +17,9 @@
 (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]
@@ -114,7 +116,7 @@
     (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
+{: 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
  : reload : hotswap : swappable :require swappable-require : hot-table : nested-tset
  : readjson : writejson : file-exists : waitfor : in-coro : multival}

link/mame.fnl

@@ -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 \"\n\n\n\nCALL-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)

neutgs/init.fnl

@@ -12,23 +12,34 @@
     (WriteString (far-ref pascalhex)))
 
   (fn add (lhs rhs) (+ lhs rhs))
+
+  (global word UserID)
   (fn main ()
     (TLStartUp)
-    (let (userid (MMStartUp))
+    (set! UserID (MMStartUp))
-      (IMStartUp)
+    (IMStartUp)
-      (TextStartUp)
+    (TextStartUp)
 
-      (let (x 1)
+    (let (x 1)
-        (printnum x)
+      (printnum x)
-        (set! x (+ x 1))
+      (set! x (+ x 1))
-        (printnum x)
+      (printnum x))
-        (set! (long-at (ref hexbuf)) 0x6b636548)
+    (set! (long-at (ref hexbuf)) 0x6b636548)
-        (WriteString (far-ref pascalhex)))
+    (WriteString (far-ref pascalhex))
+    (long! (ref hexbuf) 0x74747542)
+    (WriteString (far-ref pascalhex))
+    (let (buf (ref hexbuf)
+          str (far-ref pascalhex))
+      (long! buf 0x6b726f42)
+      (WriteString str)
+      (word! (+ buf 2) 0x706f)
+      (WriteString str))
+    (printnum (hiword (long-at (far-ref pascalhex))))
+
+    (TextShutDown)
+    (IMShutDown)
+    (MMShutDown UserID)
+    (TLShutDown)))
 
-      (TextShutDown)
-      (IMShutDown)
-      (MMShutDown userid)
-      (TLShutDown)))
-)
 
 (ssc:assemble)

ssc/init.fnl

@@ -166,6 +166,13 @@
                       func (if (= (type mod) :function) mod mod.module)]
                   (tset self.modules name mod)
                   (func self))))
+   :global (lambda [self etype name ?const]
+             (tset self.globals name {:type etype : name})
+             (self.org:append name
+               (match etype
+                 :word [:dw ?const]
+                 :long [:dl ?const]
+                 _ (error (.. "Unrecognized type " (fv etype))))))
    :do (fn [self ...]
          (var etype-body :void)
          (local c-body (lume.concat [:block] (icollect [i (countiter (select :# ...))]
@@ -255,11 +262,12 @@
     :long-at (lambda [self ref]
                (local (c-ref etype) (self:expr-poly ref))
                (if (= etype :word)
-                   [:block (self:push nil c-ref :word) [:ldy 0] [:lda [1 :s] :y] [:sta self.LONG_LO] [:iny] [:iny] [:lda [1 :s] :y] [:sta self.LONG_HI] (self:drop)]
+                   (values [:block (self:push nil c-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)
-                   [:block c-ref [:ldy 0] [:lda [[self.LONG_LO]] :y]] [:tax] [:iny] [:iny] [:lda [[self.LONG_LO]] [:sta self.LONG_HI] [:stx self.LONG_LO]]))
+                   (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]
             (let [(c-value etype) (self:expr-poly value)
                   {: lo : hi} (self:opgen-lhs lhs)
@@ -380,7 +388,7 @@
 
 (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"))
+    (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]
@@ -388,7 +396,7 @@
     (match etype
       :long c
       :word [:block c [:sta self.LONG_LO] [:lda 0] [:sta self.LONG_HI]]
-      _ (error "Unexpected type " etype " in " (fv expr) " - wanted long or word"))))
+      _ (error (.. "Unexpected type " (fv etype) " in " (fv expr) " - wanted long or word")))))
 
 (fn Ssc.compile [self ...]
   (for [i 1 (select :# ...)]