SpindleyQ/honeylisp
1
1
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

Implement macros, symbol expansion (replaces constants, getters)

Browse source
This commit is contained in:
Jeremy Penner 2021-09-26 20:32:17 -04:00
parent 5e46b908bd
commit 6a92211024
6 changed files with 66 additions and 55 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
neutgs/init.fnl
View file

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

7
ssc/iigs/graphics.fnl
View file

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

56
ssc/iigs/toolbox.fnl
View file

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

2
ssc/iigs/u2-debug.fnl
View file

@ -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
View file

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

2
ssc/task.fnl
View file

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