Implement macros, symbol expansion (replaces constants, getters)
This commit is contained in:
parent
5e46b908bd
commit
6a92211024
|
@ -36,14 +36,14 @@
|
|||
(while (not (GetNextEvent keyDownMask (far-ref event-buffer)))
|
||||
(yield)))
|
||||
|
||||
(const screen-addr 0xe12000)
|
||||
(const screen-size 0x9d00)
|
||||
(define screen-addr 0xe12000)
|
||||
(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))
|
||||
|
|
|
@ -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 [:getter name [:ref name]])
|
||||
(ssc.org:append name asm))])
|
||||
(ssc:expr-poly [:form name (fn [ssc] (assert (= ssc.locals nil) (.. name " must be called from a drawfn")) [:jmp fname])])
|
||||
(ssc:expr-poly [:define name [:ref fname]])
|
||||
(ssc.org:append fname asm))])
|
||||
|
||||
(drawfn pei-slam-tile
|
||||
(asm (tsc) (tcd) (adc 7) (tcs)
|
||||
|
|
|
@ -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)
|
||||
(const nullEvt 0)
|
||||
(const mouseDownEvt 1)
|
||||
(const mouseUpEvt 2)
|
||||
(const keyDownEvt 3)
|
||||
(const autoKeyEvt 5)
|
||||
(const updateEvt 6)
|
||||
(const activeFlag 0x0001)
|
||||
(const changeFlag 0x0002)
|
||||
(const btn1State 0x0040)
|
||||
(const btn0State 0x0080)
|
||||
(const appleKey 0x0100)
|
||||
(const shiftKey 0x0200)
|
||||
(const capsLock 0x0400)
|
||||
(const optionKey 0x0800)
|
||||
(const controlKey 0x1000)
|
||||
(const keyPad 0x2000)
|
||||
(const mDownMask 0x0002)
|
||||
(const mUpMask 0x0004)
|
||||
(const keyDownMask 0x0008)
|
||||
(const autoKeyMask 0x0020)
|
||||
(const updateMask 0x0040)
|
||||
(define ToolsetEventManager 0x06)
|
||||
(define nullEvt 0)
|
||||
(define mouseDownEvt 1)
|
||||
(define mouseUpEvt 2)
|
||||
(define keyDownEvt 3)
|
||||
(define autoKeyEvt 5)
|
||||
(define updateEvt 6)
|
||||
(define activeFlag 0x0001)
|
||||
(define changeFlag 0x0002)
|
||||
(define btn1State 0x0040)
|
||||
(define btn0State 0x0080)
|
||||
(define appleKey 0x0100)
|
||||
(define shiftKey 0x0200)
|
||||
(define capsLock 0x0400)
|
||||
(define optionKey 0x0800)
|
||||
(define controlKey 0x1000)
|
||||
(define keyPad 0x2000)
|
||||
(define mDownMask 0x0002)
|
||||
(define mUpMask 0x0004)
|
||||
(define keyDownMask 0x0008)
|
||||
(define autoKeyMask 0x0020)
|
||||
(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)
|
||||
|
|
|
@ -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))
|
||||
|
|
46
ssc/init.fnl
46
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.getters {})
|
||||
(set self.constants {:true 0xffff true 0xffff :false 0 false 0})
|
||||
(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))
|
||||
:getter (lambda [self name ...] (tset self.getters name (self:compile-function (.. :-get- name) [] ...)))
|
||||
:define (lambda [self name val] (tset self.constants name val))
|
||||
: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]
|
||||
(tset self.functions name {:arity (length args) :args (self:parse-parameters args) :org self.org :type etype : name :call-instruction :jsr}))
|
||||
: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 (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))
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
|
Loading…
Reference in a new issue