Clean up expression logic, implement local variables

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))

ssc/init.fnl

@@ -8,12 +8,13 @@
 ; * All values are 16-bit integers, like Forth or BCPL.
 ; * 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], arg3 should be in the A register, and the stack should look like:
+; * To call a function taking arguments [arg1 arg2 arg3], all 3 arguments should be pushed to the stack before calling.
-;     arg1 arg2 return-address
+;   When the function takes control, the stack should look like this:
-; * The caller is responsible for removing arg1 + arg2 from the stack once the function returns.
+;     arg1 arg2 arg3 return-address
-; * The caller is responsible for preserving the X and Y registers, if this is desirable.
+; * 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 a function takes no arguments and 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 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.
@@ -28,6 +29,11 @@
 ; Compiler notes:
 ; Expressions are of the form [:function arg1 arg2 arg3]
 ; args are either strings (symbols) or numbers
+
+; TODO:
+; * implement read / write (pointers)
+; * implement functions
+; * implement custom special forms (macros?)
 (local Object (require :core.object))
 (local lume (require :lib.lume))
 (local Ssc (Object:extend))
@@ -36,53 +42,87 @@
 (fn Ssc.new [self ?opts]
   (local opts (or ?opts {}))
   (set self.prg (or opts.prg (Prg.new nil :65816)))
-  (when opts.exprforms (set self.exprforms opts.exprforms))
+  (set self.forms (lume.clone (or opts.forms self.__index.forms)))
-  (when opts.stmtforms (set self.stmtforms opts.stmtforms))
+  (set self.functions {})
-  (set self.functions {}))
+  (set self.locals []))
+
+(fn Ssc.push [self ?local]
+  (table.insert self.locals (or ?local [:tmp]))
+  [:pha])
+(fn Ssc.drop [self ?local]
+  (match (. self.locals (length self.locals))
+    [:tmp] (when (not= ?local nil) (error (.. "Internal stack error: expected " ?local ", got temporary")))
+    loc    (when (not= ?local loc) (error (.. "Internal stack error: expected " (or ?local "temporary") " temporary, got " loc))))
+  (tset self.locals (length self.locals) nil)
+  [:ply])
 
-(set Ssc.exprforms
-  {:+ (lambda [self first ...]
-        (local block [:block [:clc] (self:compile-expr first)])
-        (for [i 1 (select :# ...)]
-          (let [val (select i ...)]
-            (table.insert block
-              (match val
-                1 [:inc]
-                -1 [:dec]
-                (where val (= (type val) :number)) [:adc val]
-                _ [:block (self:compile-expr val) [:adc 0 :s] [:ply]]))))
-        block)
-   :- (lambda [self first ...]
-        (local block [:block [:sec] (self:compile-expr first)])
-        (for [i 1 (select :# ...)]
-          (let [val (select i ...)]
-            (table.insert block
-              (match val
-                1 [:dec]
-                -1 [:inc]
-                (where val (= (type val) :number)) [:sbc val]
-                _ [:block (self:compile-expr val) [:sbc 0 :s] [:ply]]))))
-        block)
-    :asm (lambda [self ...] [:block ...])
-  })
 (fn countiter [minmax ?max]
   (let [min (if ?max minmax 1)
         max (or ?max minmax)]
-    (values (fn [_ i] (if (>= i max) nil (+ i 1)))
+    (fn [_ iprev]
-            nil
+      (let [i (if iprev (+ iprev 1) min)]
-            min)))
+        (when (<= i max) i)))))
+
+(fn pairoff [l]
+  (fn [_ iprev] (let [i (if iprev (+ iprev 2) 1)]
+                          (when (< i (length l)) (values i (. l i) (. l (+ i 1)))))))
+
+(set Ssc.forms
+  {:asm (fn [self ...] [:block ...])
+   :do (fn [self ...] (lume.concat [:block] (icollect [i (countiter (select :# ...))] (self:compile-expr (select i ...)))))
+   :let (fn [self bindings ...]
+          (lume.concat [:block]
+                       (icollect [_ symbol expr (pairoff bindings)]
+                          [:block (self:compile-expr expr) (self:push symbol)])
+                       [(self:compile-expr [:do ...])]
+                       (icollect [i-half (countiter (/ (length bindings) 2))]
+                          (self:drop (. bindings (- (length bindings) (* i-half 2) -1))))))
+   :+ (lambda [self first ...]
+        (local block [:block (self:compile-expr first)])
+        (for [i 1 (select :# ...)]
+          (let [val (select i ...)]
+            (table.insert block
+              (match val
+                 1 [:inc]  2 [:block [:inc] [:inc]]
+                -1 [:dec] -2 [:block [:dec] [:dec]]
+                (where val (= (type val) :number)) [:block [:clc] [:adc val]]
+                (where sym (= (type sym) :string) (self:local-offset sym)) [:block [:clc] [:adc (self:local-offset sym) :s]]
+                _ [:block (self:push) (self:compile-expr val) [:clc] [:adc 0 :s] (self:drop)]))))
+        block)
+   :- (lambda [self first ...]
+        (let [block [:block (self:compile-expr first)]
+              nargs (select :# ...)]
+          (if (= nargs 0) (table.insert block [:block [:eor 0xffff] [:inc]]) ; negate with two's complement
+            (for [i 1 nargs]
+              (let [val (select i ...)]
+                (table.insert block
+                  (match val
+                     1 [:dec]  2 [:block [:dec] [:dec]]
+                    -1 [:inc] -2 [:block [:inc] [:inc]]
+                    (where val (= (type val) :number)) [:block [:sec] [:sbc val]]
+                    (where sym (= (type sym) :string) (self:local-offset sym)) [:block [:sec] [:sbc (self:local-offset sym) :s]]
+                    _ [:block (self:push) (self:compile-expr val) [:sec] [:sbc 0 :s] (self:drop)])))))
+          block))
+  })
+
+(fn Ssc.local-offset [self symbol]
+  (var offset nil)
+  (for [i 1 (length self.locals)]
+    (when (= (. self.locals i) symbol)
+      (set offset (* 2 (- (length self.locals) i)))))
+  offset)
 
 (fn Ssc.compile-expr [self expr]
   (match expr
-    (where num (= (type num) :number)) [:block [:pha] [:lda num]]
+    (where num (= (type num) :number)) [:lda num]
-    ;:string TODO: oh shit I need to keep track of local scoping etc
+    (where loc (= (type loc) :string) (self:local-offset loc)) [:lda (self:local-offset loc) :s]
-    (where [func & args] (= (?. self.functions func :arity) (length args))
+    ; TODO: Global scope
-                         (. self.functions func :returns-value))
+    (where [func & args] (= (?. self.functions func :arity) (length args)))
-      (let [pre (icollect [_ arg (ipairs args)] (self:compile-expr arg))
+      (let [pre (icollect [_ arg (ipairs args)] [:block (self:compile-expr arg) (self:push)])
-            post (if (<= (length args) 1) [] (icollect [_ (countiter (- (length args) 1))] [:ply]))]
+            post (icollect [_ (countiter (length args))] (self:drop))]
         (lume.concat [:block] pre [[:jsr func]] post))
-    (where [form & args] (. self.exprforms form))
+    (where [form & args] (. self.forms form))
-      ((. self.exprforms form) self (table.unpack args))
+      ((. self.forms form) self (table.unpack args))
     _ (error (.. "Unrecognized expression " (fv expr)))))
 
 Ssc