diff --git a/link/mame.fnl b/link/mame.fnl index adb55c0..4e234b8 100644 --- a/link/mame.fnl +++ b/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)) diff --git a/ssc/init.fnl b/ssc/init.fnl index 46db988..7e59ce0 100644 --- a/ssc/init.fnl +++ b/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: -; arg1 arg2 return-address -; * The caller is responsible for removing arg1 + arg2 from the stack once the function returns. -; * The caller is responsible for preserving the X and Y registers, if this is desirable. +; * To call a function taking arguments [arg1 arg2 arg3], all 3 arguments should be pushed to the stack before calling. +; When the function takes control, the stack should look like this: +; arg1 arg2 arg3 return-address +; * 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)) - (when opts.stmtforms (set self.stmtforms opts.stmtforms)) - (set self.functions {})) + (set self.forms (lume.clone (or opts.forms self.__index.forms))) + (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))) - nil - min))) + (fn [_ iprev] + (let [i (if iprev (+ iprev 1) 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]] - ;:string TODO: oh shit I need to keep track of local scoping etc - (where [func & args] (= (?. self.functions func :arity) (length args)) - (. self.functions func :returns-value)) - (let [pre (icollect [_ arg (ipairs args)] (self:compile-expr arg)) - post (if (<= (length args) 1) [] (icollect [_ (countiter (- (length args) 1))] [:ply]))] + (where num (= (type num) :number)) [:lda num] + (where loc (= (type loc) :string) (self:local-offset loc)) [:lda (self:local-offset loc) :s] + ; TODO: Global scope + (where [func & args] (= (?. self.functions func :arity) (length args))) + (let [pre (icollect [_ arg (ipairs args)] [:block (self:compile-expr arg) (self:push)]) + post (icollect [_ (countiter (length args))] (self:drop))] (lume.concat [:block] pre [[:jsr func]] post)) - (where [form & args] (. self.exprforms form)) - ((. self.exprforms form) self (table.unpack args)) + (where [form & args] (. self.forms form)) + ((. self.forms form) self (table.unpack args)) _ (error (.. "Unrecognized expression " (fv expr))))) Ssc