Better pointer handling, implement set!

neutgs/init.fnl

@@ -6,6 +6,7 @@
   (require :ssc.iigs.toolbox)
 
   (asm pascalhex (db 5) hexbuf (bytes "     "))
+
   (fn printnum (num)
     (long! (ref hexbuf) (HexIt num))
     (WriteString (far-ref pascalhex)))
@@ -17,7 +18,12 @@
       (IMStartUp)
       (TextStartUp)
 
-      (printnum (add 1 2))
+      (let (x 1)
+        (printnum x)
+        (set! x (+ x 1))
+        (printnum x)
+        (set! (long-at (ref hexbuf)) 0x6b636548)
+        (WriteString (far-ref pascalhex)))
 
       (TextShutDown)
       (IMShutDown)

ssc/iigs/toolbox.fnl

@@ -40,8 +40,6 @@
                      (values block (if (= (type return-type) :string) return-type :void))))]
       (ssc:expr-poly [:form name call])))])
 
-  ; todo: some kind of type system, or wrappers for 32-bit pointers, god
-
   ; toolbox locator
   (def-toolbox 0x0201 TLStartUp () void)
   (def-toolbox 0x0301 TLShutDown () void)

ssc/init.fnl

@@ -5,8 +5,9 @@
 ; optimizations are a non-goal; if you want to tune the generated code, go ahead and write
 ; the assembly directly.
 
-; * Values default to 16-bit integers, like Forth or BCPL.
+; * 3 data types: word (2 bytes), long (4 bytes), void (0 bytes).
-; * 32-bit integers are also handled, and the "last value" is stored in a separate "register" in the direct page.
+; * 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.
@@ -14,15 +15,14 @@
 ;     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 register.
+; * 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 register.
+; * 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:
-;     * bank-local address (16 bits)
+;     * LONG (32-bit "register")
-;     * long address (24 bits)
 ;     * Last suspended value of S
 ;     * Mailbox
 ;     * Pointer to next task
@@ -32,8 +32,8 @@
 ; args are either strings (symbols) or numbers
 
 ; TODO:
-; * implement read / write (pointers)
+; * implement global definitions
-; * implement write (locals)
+; * fix comparisons
 ; * implement loops
 ; * implement "getters" (subroutine that runs when referenced by name without an explicit call)
 
@@ -55,6 +55,7 @@
   (set self.functions {})
   (set self.locals [])
   (set self.modules {})
+  (set self.globals {})
   (if opts.boot (self:compile (table.unpack opts.boot))
     (self:compile (!
       (start-symbol boot)
@@ -146,7 +147,7 @@
 (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-addressible val))
+  (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))
@@ -154,9 +155,8 @@
     (values (lume.concat [:block] setup [acc] operations cleanup) etype)))
 
 (set Ssc.forms
-  {:asm (fn [self ...]
+  {:asm (fn [self ...] (if (self:defining?) [:block ...] (self.org:append ...)))
-          (if (self:defining?) [:block ...]
+   :asm-long (fn [self ...] (values [:block ...] :long))
-            (self.org:append ...)))
    :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))
@@ -222,7 +222,8 @@
                         (= const -1) [:inc] (= const -2) [:block [:inc] [:inc]]
                       [:block [:sec] (lo :sbc)])
               :long [:block [:sec] (lo :lda) [:sbc self.LONG_LO] [:sta self.LONG_LO]
-                                   (if hi (hi :lda) [:lda 0]) [:sbc self.LONG_HI] [:sta self.LONG_HI]]))))
+                                   (if hi (hi :lda) [:lda 0]) [:sbc self.LONG_HI] [:sta self.LONG_HI]]))
+          first ...))
     := (lambda [self lhs rhs] (boolop self lhs rhs :beq))
     :not= (lambda [self lhs rhs] (boolop self lhs rhs :bne))
     :< (lambda [self lhs rhs] (boolop self lhs rhs :bmi))
@@ -243,7 +244,35 @@
     :long! (lambda [self ref value] [:block (self:push nil (self:expr-word 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)])
-    :deref (lambda [self ref] [:block (self:push nil (self:expr-word ref) :word) [:lda [1 :s] :y] (self:drop)])
+    :word-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] (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)
+                   [: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)]
+
+                   (= 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]]))
+
+    :set! (lambda [self lhs value]
+            (let [(c-value etype) (self:expr-poly value)
+                  {: lo : hi} (self:opgen-lhs lhs)
+                  c-lo (match etype
+                         :word (lo :sta)
+                         :long [:block [:lda self.LONG_LO] (lo :sta)])
+                  c-hi (when hi (match etype
+                                  :word [:block [:lda 0] (hi :sta)]
+                                  :long [:block [:lda self.LONG_HI] (hi :sta)]))
+                  block [:block]]
+              (pp c-value)
+              (lume.push block c-value c-lo c-hi)
+              block))
   })
 
 (fn Ssc.local-offset [self name-or-index]
@@ -271,21 +300,52 @@
 
 (fn Ssc.type-expr [self expr] (let [(_ etype) (self:expr-poly expr)] etype))
 
-(fn Ssc.addressible-const [self const]
+; opgen - a small structure that allows for reading a value with many different addressing modes
-  {:lo #[$1 (bit.band const 0xffff)] :hi (let [hi (bit.rshift (bit.band 0xffff0000) 16)] (if (or (= hi 0) (= hi 0xffff)) nil #[$1 hi])) : const})
+; :lo and :hi keys are functions that, when called with an opcode, returns that opcode with the appropriate argument to work on
-(fn Ssc.addressible-loc [self loc]
+; 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.
-  {:lo #[$1 (self:local-offset loc) :s] :hi (when (= (self:local-type loc) :long) #[$1 (+ (self:local-offset loc) 2)])})
+; :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.addressible [self expr]
+(fn Ssc.opgen-local [self loc]
-  (match (type expr)
+  {:lo #[$1 (self:local-offset loc) :s] :hi (when (= (self:local-type loc) :long) #[$1 (+ (self:local-offset loc) 2) :s])})
-    :number                                  (self:addressible-const expr)
-    (where :string (self:local-offset expr)) (self:addressible-loc expr)))
 
-(fn Ssc.push-addressible [self expr]
+(fn Ssc.opgen-symbol [self name etype]
-  (or (self:addressible expr)
+  {: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
+
+(fn Ssc.opgen-global [self name] (self:opgen-symbol name (. self.globals name :type)))
+
+(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-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 [_ [:long-at [:ref name]]] (string? name)) (self:opgen-symbol name :long)
+    (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) (self:opgen-lhs expr)))
+
+(fn Ssc.push-opgen [self expr]
+  (or (self:opgen expr)
       (let [c (self:push nil (self:expr-poly expr))
             iloc (length (self.locals))]
-        (lume.merge (self:addressible-loc iloc) {:setup #c :cleanup #(self:drop)}))))
+        (lume.merge (self:opgen-local iloc) {:setup #c :cleanup #(self:drop)}))))
 
 (fn Ssc.parse-parameters [self params]
   (icollect [_ param (ipairs params)] (match param
@@ -301,9 +361,9 @@
 
 (fn Ssc.expr-poly [self expr]
   (match expr
-    (where lit (?. (self:addressible lit) :hi)) (let [{: lo : hi} (self:addressible lit)]
+    (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:addressible lit) :lo)) (let [{: lo} (self:addressible lit)] (values (lo :lda) :word))
+    (where lit (?. (self:opgen lit) :lo)) (let [{: lo} (self:opgen lit)] (values (lo :lda) :word))
     ; TODO: Global scope
     (where [func & args] (= (?. self.functions func :arity) (length args)))
       (let [f (. self.functions func)