Implement macros, symbol expansion (replaces constants, getters)

neutgs/init.fnl

@@ -36,14 +36,14 @@
     (while (not (GetNextEvent keyDownMask (far-ref event-buffer)))
       (yield)))
 
-  (const screen-addr 0xe12000)
+  (define screen-addr 0xe12000)
-  (const screen-size 0x9d00)
+  (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))
+  (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))

ssc/iigs/graphics.fnl

@@ -92,7 +92,7 @@
 #(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"
@@ -118,11 +118,12 @@
   (form drawfn [(lambda [ssc name ...]
     (assert (not (ssc:defining?)) "drawfn must be defined at top level")
     (set ssc.locals nil) ; locals cannot be used
+    (local fname (.. "<drawfn " name ">"))
     (local asm (ssc:expr-poly (lume.concat [:do ...] [[:asm [:jmp :draw-object-finished]]])))
     (set ssc.locals [])
-    (ssc:expr-poly [:form name (fn [ssc] (assert (= ssc.locals nil) (.. name " must be called from a drawfn")) [:jmp name])])
+    (ssc:expr-poly [:form name (fn [ssc] (assert (= ssc.locals nil) (.. name " must be called from a drawfn")) [:jmp fname])])
-    (ssc:expr-poly [:getter name [:ref name]])
+    (ssc:expr-poly [:define name [:ref fname]])
-    (ssc.org:append name asm))])
+    (ssc.org:append fname asm))])
 
   (drawfn pei-slam-tile
     (asm (tsc) (tcd) (adc 7) (tcs)

ssc/iigs/toolbox.fnl

@@ -47,7 +47,7 @@
       (ssc.org:append [:dw (match (type toolset-id) :number toolset-id :string (. ssc.constants toolset-id))]
                       [:dw version])))])
 
-  (const ToolsetToolLocator 0x01)
+  (define ToolsetToolLocator 0x01)
   (def-toolbox 0x0201 TLStartUp () void)
   (def-toolbox 0x0301 TLShutDown () void)
   (def-toolbox 0x0401 TLVersion () word)
@@ -61,7 +61,7 @@
   (def-toolbox 0x1201 TLTextMountVolume ((long line1Ptr) (long line2Ptr) (long button1Ptr) (long button2Ptr)) word)
   (def-toolbox 0x1001 UnloadOneTool (toolNumber) void)
 
-  (const ToolsetIntegerMath 0x0b)
+  (define ToolsetIntegerMath 0x0b)
   (def-toolbox 0x020b IMStartUp () void)
   (def-toolbox 0x030b IMShutDown () void)
   (def-toolbox 0x040b IMVersion () word)
@@ -101,7 +101,7 @@
   (def-toolbox 0x200b X2Fix ((long extendPtr)) long)
   (def-toolbox 0x210b X2Frac ((long extendPtr)) long)
 
-  (const ToolsetMemoryManager 0x02)
+  (define ToolsetMemoryManager 0x02)
   (def-toolbox 0x0202 MMStartUp () word)
   (def-toolbox 0x0302 MMShutDown (userID) void)
   (def-toolbox 0x0402 MMVersion () word)
@@ -132,7 +132,7 @@
   (def-toolbox 0x2502 SetPurgeAll (userID newPurgeLevel) void)
   (def-toolbox 0x1d02 TotalMem () long)
 
-  (const ToolsetText 0x0c)
+  (define ToolsetText 0x0c)
   (def-toolbox 0x020c TextStartUp () void)
   (def-toolbox 0x030c TextShutDown () void)
   (def-toolbox 0x040c TextVersion () word)
@@ -166,7 +166,7 @@
   (def-toolbox 0x1a0c WriteLine ((long strPtr)) void)
   (def-toolbox 0x1c0c WriteString ((long strPtr)) void)
 
-  (const ToolsetMisc 0x03)
+  (define ToolsetMisc 0x03)
   (def-toolbox 0x0203 MTStartUp () void)
   (def-toolbox 0x0303 MTShutDown () void)
   (def-toolbox 0x0403 MTVersion () word)
@@ -208,28 +208,28 @@
   (def-toolbox 0x1003 SetVector (vectorRefNum (long vectorPtr)) void)
   (def-toolbox 0x1103 GetVector (vectorRefNum) long)
 
-  (const ToolsetEventManager 0x06)
+  (define ToolsetEventManager 0x06)
-  (const nullEvt 0)
+  (define nullEvt 0)
-  (const mouseDownEvt 1)
+  (define mouseDownEvt 1)
-  (const mouseUpEvt 2)
+  (define mouseUpEvt 2)
-  (const keyDownEvt 3)
+  (define keyDownEvt 3)
-  (const autoKeyEvt 5)
+  (define autoKeyEvt 5)
-  (const updateEvt 6)
+  (define updateEvt 6)
-  (const activeFlag 0x0001)
+  (define activeFlag 0x0001)
-  (const changeFlag 0x0002)
+  (define changeFlag 0x0002)
-  (const btn1State 0x0040)
+  (define btn1State 0x0040)
-  (const btn0State 0x0080)
+  (define btn0State 0x0080)
-  (const appleKey 0x0100)
+  (define appleKey 0x0100)
-  (const shiftKey 0x0200)
+  (define shiftKey 0x0200)
-  (const capsLock 0x0400)
+  (define capsLock 0x0400)
-  (const optionKey 0x0800)
+  (define optionKey 0x0800)
-  (const controlKey 0x1000)
+  (define controlKey 0x1000)
-  (const keyPad 0x2000)
+  (define keyPad 0x2000)
-  (const mDownMask 0x0002)
+  (define mDownMask 0x0002)
-  (const mUpMask 0x0004)
+  (define mUpMask 0x0004)
-  (const keyDownMask 0x0008)
+  (define keyDownMask 0x0008)
-  (const autoKeyMask 0x0020)
+  (define autoKeyMask 0x0020)
-  (const updateMask 0x0040)
+  (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)
@@ -249,7 +249,7 @@
   (def-toolbox 0x1006 TickCount () long)
   (def-toolbox 0x0f06 WaitMouseUp (buttonNum) word)
 
-  (const ToolsetQuickDraw 0x04)
+  (define ToolsetQuickDraw 0x04)
   (def-toolbox 0x0204 QDStartUp (dPageAddr masterSCB maxWidth userID) void)
   (def-toolbox 0x0304 QDShutDown () void)
   (def-toolbox 0x0404 QDVersion () word)

ssc/iigs/u2-debug.fnl

@@ -32,7 +32,7 @@
 
   (asm u2-debug-buffer (bytes [(string.rep "\x00" 1500)]))
 
-  (fn u2-debug-server-poll ()) ; predefine, will be overwritten. wastes a byte (rts).
+  (predef-fn u2-debug-server-poll () void far)
 
   (fn u2-debug-server-cmd-write (msgid)
     (let (addr (long-at (ref u2-debug-buffer))

ssc/init.fnl

@@ -5,7 +5,7 @@
 ; optimizations are a non-goal; if you want to tune the generated code, go ahead and write
 ; the assembly directly.
 
-; * 3 data types: word (2 bytes), long (4 bytes), void (0 bytes).
+; * 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.
@@ -47,8 +47,8 @@
   (set self.locals [])
   (set self.modules {})
   (set self.globals {})
-  (set self.constants {:true 0xffff :false 0})
+  (set self.constants {:true 0xffff true 0xffff :false 0 false 0})
-  (set self.getters {})
+  (set self.macros (lume.clone (or opts.macros self.__index.macros)))
   (set self.setters {})
   (set self.dp-vars 0)
   (set self.LONG_LO (self:alloc-dp-var))
@@ -201,6 +201,7 @@
 (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)))
@@ -231,8 +232,8 @@
    :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))
-   :const (lambda [self name val] (tset self.constants name val))
+   :define (lambda [self name val] (tset self.constants name val))
-   :getter (lambda [self name ...] (tset self.getters name (self:compile-function (.. :-get- name) [] ...)))
+   :macro (lambda [self name func] (tset self.macros name func))
    :setter (lambda [self name arg ...]
      (assert (= (length arg) 1))
      (tset self.setters name (self:compile-function (.. :-set- name) arg ...)))
@@ -264,8 +265,8 @@
             (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]
+   :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 :jsr}))
+                (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)
@@ -275,7 +276,6 @@
                cl-false (if (not= iffalse nil) [[:bra :-if-done-] :-if-false- c-false :-if-done-]
                                                [:-if-false-])]
            (values (lume.concat block cl-false) etype)))
-   :when (lambda [self test ...] (self:expr-poly [:if test [:do ...]]))
    :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 ...])]
@@ -321,11 +321,6 @@
     :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]])
-    ; 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] (self:expr-poly [:set! [:byte-at ref] value]))
-    :word! (lambda [self ref value] (self:expr-poly [:set! [:word-at ref] value]))
-    :long! (lambda [self ref value] (self:expr-poly [:set! [:long-at ref] value]))
     :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))
@@ -360,6 +355,15 @@
                           :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])
+  })
 
 (fn Ssc.local-offset [self name-or-index]
   (var offset nil)
@@ -413,9 +417,6 @@
 
 (fn Ssc.opgen [self expr]
   (if (= (type expr) :number) (self:opgen-const expr)
-      (= expr true) (self:opgen-const self.constants.true)
-      (= expr false) (self:opgen-const self.constants.false)
-      (and (= (type expr) :string) (. self.constants expr)) (self:opgen (. self.constants expr))
     (self:opgen-lhs expr)))
 
 (fn Ssc.push-opgen [self expr]
@@ -456,16 +457,25 @@
   (let [m (getmetatable expr)]
     (when (and m m.filename) (set self.expr-metadata m))))
 
+(fn Ssc.expr-expand [self expr]
+  (let [mt (getmetatable expr)
+        expanded (match expr
+                   (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)))
+                   [f & args] (lume.concat [f] (icollect [_ arg (ipairs args)] (self:expr-expand arg)))
+                   _ expr)
+        _ (when (= (type expanded) :table) (setmetatable expanded mt))]
+    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 getter (= (type getter) :string) (. self.getters getter))
-                    (self:compile-function-call (. self.getters getter) [])
                   (where [func & args] (= (?. self.functions func :arity) (length args)))
                     (self:compile-function-call (. self.functions func) args)
                   (where [form & args] (. self.forms form))

ssc/task.fnl

@@ -14,7 +14,7 @@
   (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
-  (const task-size 0x100)
+  (define task-size 0x100)
   (global word first-task)
   (global word last-task)