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

constants, getters, setters, true, false. I should start making stuff!!

Browse source
This commit is contained in:
Jeremy Penner 2021-08-14 20:52:43 -04:00
parent 48f181bd32
commit e84fbd2c95
2 changed files with 63 additions and 44 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

16
neutgs/init.fnl
View file

@ -13,6 +13,15 @@
(fn add (lhs rhs) (+ lhs rhs))
(const screen 0xe12000)
(const screen-size 0x9d00)
(global word screen-offset 0)
(getter screen-cursor (+ screen screen-offset))
(setter screen-cursor (pixels)
(word! screen-cursor pixels)
(set! screen-offset (+ screen-offset 2)))
(global word UserID)
(fn main ()
(TLStartUp)
@ -22,10 +31,9 @@
(MTStartUp)
(GrafOn)
(let (screen 0xe12000 i 0)
(while (< i 0x9d00)
(word! (+ screen i) (Random))
(set! i (+ i 2))))
(set! screen-offset 0)
(while (< screen-offset screen-size)
(set! screen-cursor (+ 0x2345 screen-offset)))
(GrafOff)

91
ssc/init.fnl
View file

@ -31,9 +31,6 @@
; Expressions are of the form [:function arg1 arg2 arg3]
; args are either strings (symbols) or numbers
; TODO:
; * implement "getters" (subroutine that runs when referenced by name without an explicit call)
(import-macros {:sss ! : compile} :ssc.macros)
(local Object (require :core.object))
(local lume (require :lib.lume))
@ -57,6 +54,9 @@
(set self.locals [])
(set self.modules {})
(set self.globals {})
(set self.constants {})
(set self.getters {})
(set self.setters {})
(if opts.boot (self:compile (table.unpack opts.boot))
(self:compile (!
(start-symbol boot)
@ -195,12 +195,29 @@
(fn Ssc.cmp-to-bool [self op ...] (self:expr-poly [:if [op ...] self.TRUE self.FALSE]))
(fn Ssc.compile-function [self name args ...]
(assert (not (self:defining?)) "Can't nest function definitions")
(local arglocals (self:parse-parameters args))
(set self.locals (lume.concat arglocals [{:type :word :comment :returnaddr}]))
; todo: maybe handle mutually recursive functions? (compile-expr only has access to currently-defined functions)
(local (c-function etype) (self:expr-poly [:do ...]))
(self.org:append name c-function [:rts])
(assert (= (length self.locals) (+ (length args) 1))
(.. "Left locals on stack?? Expected " (tostring (+ (length args) 1)) " got " (tostring (length self.locals))))
(set self.locals [])
{:arity (length args) :args arglocals :org self.org :type etype : name})
(set Ssc.forms
{:asm (fn [self ...] (if (self:defining?) [:block ...] (self.org:append ...)))
:asm-long (fn [self ...] (values [:block ...] :long))
: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) [] ...)))
:setter (lambda [self name arg ...]
(assert (= (length arg) 1))
(tset self.setters name (self:compile-function (.. :-set- name) arg ...)))
:require (lambda [self name]
(when (= (. self.modules name) nil)
(let [mod (util.reload name)
@ -227,17 +244,7 @@
compiled-cleanup (icollect [i-half (countiter (/ (length bindings) 2))]
(self:drop (. bindings (- (length bindings) (* i-half 2) -1))))]
(values (lume.concat [:block] compiled-bindings [compiled-body] compiled-cleanup) etype)))
:fn (lambda [self name args ...]
(assert (not (self:defining?)) "Can't nest function definitions")
(local arglocals (self:parse-parameters args))
(set self.locals (lume.concat arglocals [{:type :word :comment :returnaddr}]))
; todo: maybe handle mutually recursive functions? (compile-expr only has access to currently-defined functions)
(local (c-function etype) (self:expr-poly [:do ...]))
(self.org:append name c-function [:rts])
(tset self.functions name {:arity (length args) :args arglocals :org self.org :type etype})
(assert (= (length self.locals) (+ (length args) 1))
(.. "Left locals on stack?? Expected " (tostring (+ (length args) 1)) " got " (tostring (length self.locals))))
(set self.locals []))
:fn (lambda [self name args ...] (tset self.functions name (self:compile-function name args ...)))
:if (lambda [self test iftrue ?iffalse]
(let [(c-true truetype) (self:expr-poly iftrue)
(c-false falsetype) (when ?iffalse (self:expr-poly ?iffalse))
@ -318,17 +325,19 @@
(values [:block c-ref [:ldy 0] [:lda [[self.LONG_LO]] :y] [:tax] [:iny] [:iny] [:lda [[self.LONG_LO]] :y] [:sta self.LONG_HI] [:stx self.LONG_LO]]
:long)))
: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]]
(lume.push block c-value c-lo c-hi)
block))
(if (and (= (type lhs) :string) (. self.setters lhs))
(self:compile-function-call (. self.setters 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]]
(lume.push block c-value c-lo c-hi)
block)))
})
(fn Ssc.local-offset [self name-or-index]
@ -349,11 +358,6 @@
(set etype (. self.locals i :type))))
etype)
(fn Ssc.set-long [self loexpr hiexpr]
[:block loexpr [:sta self.LONG_LO] hiexpr [:sta self.LONG_HI]])
(fn Ssc.set-long-local [self loc]
(self:set-long [:lda (self:local-offset loc) :s] [:lda (+ (self:local-offset loc) 2) :s]))
(fn Ssc.type-expr [self expr] (let [(_ etype) (self:expr-poly expr)] etype))
; opgen - a small structure that allows for reading a value with many different addressing modes
@ -395,7 +399,11 @@
(. 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)))
(if (= (type expr) :number) (self:opgen-const expr)
(= expr true) (self:opgen-const self.TRUE)
(= expr false) (self:opgen-const self.FALSE)
(and (= (type expr) :string) (. self.constants expr)) (self:opgen (. self.constants expr))
(self:opgen-lhs expr)))
(fn Ssc.push-opgen [self expr]
(or (self:opgen expr)
@ -410,22 +418,25 @@
(fn Ssc.push-arguments [self paramdefs args]
(icollect [iarg arg (ipairs args)]
(let [atype (. paramdefs iarg :type)
c-arg (: self (.. :expr- atype) arg)
c-push (self:push nil c-arg atype)]
c-push)))
(let [atype (. paramdefs iarg :type)
c-arg (: self (.. :expr- atype) arg)
c-push (self:push nil c-arg atype)]
c-push)))
(fn Ssc.compile-function-call [self f args]
(let [pre (self:push-arguments f.args args)
post (icollect [_ (countiter (length args))] (self:drop))]
(values (lume.concat [:block] pre [[:jsr f.name]] post) f.type)))
(fn Ssc.expr-poly [self expr]
(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))
; TODO: Global scope
(where getter (= (type getter) :string) (. self.getters getter))
(self:compile-function-call (. self.getters getter) [])
(where [func & args] (= (?. self.functions func :arity) (length args)))
(let [f (. self.functions func)
pre (self:push-arguments f.args args)
post (icollect [_ (countiter (length args))] (self:drop))]
(values (lume.concat [:block] pre [[:jsr func]] post) f.type))
(self:compile-function-call (. self.functions func) args)
(where [form & args] (. self.forms form))
(let [f (. self.forms form)
(cexpr etype) (f self (table.unpack args))]