From 3c22f6fe2edf5f7951d9be7c01724527b1d97478 Mon Sep 17 00:00:00 2001 From: Jeremy Penner Date: Mon, 5 Oct 2020 23:47:25 -0400 Subject: [PATCH] Restructure for more reliable reload, modularity --- asm.fnl | 264 +++++++++++++++--------------- main.lua | 5 - neut.fnl | 156 ++++++++++++++++++ test.fnl | 479 ------------------------------------------------------- util.fnl | 41 ++++- vm.fnl | 337 ++++++++++++++++++++++++++++++++++++++ wrap.fnl | 10 +- 7 files changed, 664 insertions(+), 628 deletions(-) create mode 100644 neut.fnl delete mode 100644 test.fnl create mode 100644 vm.fnl diff --git a/asm.fnl b/asm.fnl index 9f23dc2..544c346 100644 --- a/asm.fnl +++ b/asm.fnl @@ -1,6 +1,5 @@ (local lume (require "lume")) -(local {: stream : kvstream : one} (require "stream")) - +(local {: int8-to-bytes : int16-to-bytes} (require "util")) (local opcodes {}) ; op mode arg @@ -33,7 +32,7 @@ modemap)) (fn without-modes [modemap ...] - (let [newmodemap (table.clone modemap)] + (let [newmodemap (lume.clone modemap)] (each [_ mode (pairs [...])] (tset newmodemap mode nil)) newmodemap)) @@ -89,43 +88,6 @@ [_] [nil nil] _ (error (.. "Unrecognized syntax" (fv op))))) -; dat - anything that takes up space in the assembled output (op, dw, db, etc) -; takes the form [:op args] -; pdat - a parsed dat; takes the form {:type type :addr addr ...} -(local dat-parser {}) -(fn new-block [] {:type :block :pdats [] :symbols {}}) - -(fn parse-dats [block dats] - (each [_ dat (ipairs dats)] - (if (= (type dat) "string") - (tset block.symbols dat (+ (length block.pdats) 1)) - (let [opcode (. dat 1) - parser (. dat-parser opcode) - pdat - (if - parser (parser dat block) - (. opcodes opcode) (dat-parser.op dat) - (error (.. "Unrecognized opcode " (fv opcode))))] - (table.insert block.pdats pdat)))) - block) - -(fn dat-parser.op [op] - (let [[mode arg] (parse-mode-arg op)] - {:type :op :opcode (. op 1) : mode : arg})) - -(fn dat-parser.block [block] - (let [dats (table.clone block)] - (table.remove dats 1) - (parse-dats (new-block) dats))) - -(fn dat-parser.db [db] {:type :var :init (. db 2) :size 1}) -(fn dat-parser.dw [dw] {:type :var :init (. dw 2) :size 2}) -(fn dat-parser.bytes [bytes] {:type :raw :bytes (. bytes 2)}) -(fn dat-parser.ref [ref] {:type :ref :target (. ref 2)}) -(fn dat-parser.flatten [flat block] - (parse-dats block (lume.slice flat 2)) - nil) - (fn make-env [block parent] {:parent parent :block block @@ -153,102 +115,136 @@ (self.parent:lookup-addr name)))}) -(fn lo [v] (bit.band v 0xff)) -(fn hi [v] (bit.band (bit.rshift v 8) 0xff)) -(fn int8-to-bytes [i] - (string.char (lo i))) -(fn int16-to-bytes [i] - (string.char (lo i) (hi i))) - -(local pdat-processor { - :op {} - :var {} - :ref {} - :raw {} - :block {} -}) - -(fn process-pdat [pdat process default ...] - (pp pdat) - (local processor (. pdat-processor pdat.type process)) - (if processor (processor pdat ...) default)) - -(fn pdat-processor.op.patch [op env] - (when (and op.mode (= (op.mode:sub 1 4) :addr)) - (let [zp-mode (.. :zp (op.mode:sub 5)) - abs-mode (.. :abs (op.mode:sub 5)) - is-zp (and ((. opcodes op.opcode) zp-mode) (env:is-zp? op.arg))] - (set op.mode (if is-zp zp-mode abs-mode))))) - -(fn pdat-processor.raw.size [raw] (length raw.bytes)) -(fn pdat-processor.op.size [op] (size op.mode)) -(fn pdat-processor.var.size [d] d.size) -(fn pdat-processor.ref.size [r] 2) - -(fn pdat-processor.op.bytes [op env] - (local bytegen (. opcodes op.opcode)) -; (pp op) - (if bytegen - (let [opbyte (bytegen op.mode) - argbytes - (if - (and (= op.mode :imm) (= (type op.arg) "function")) - (int8-to-bytes (op.arg env)) - - (= op.mode :imm) (int8-to-bytes op.arg) - (= op.mode :rel) - (int8-to-bytes (- (env:lookup-addr op.arg) (+ op.addr 2))) - (= (size op.mode) 2) (int8-to-bytes (env:lookup-addr op.arg)) - (= (size op.mode) 3) (int16-to-bytes (env:lookup-addr op.arg)) - "")] - (if opbyte - (.. (int8-to-bytes opbyte) argbytes) - (error (.. op.opcode " doesn't support mode " op.mode)))) - "")) -(fn pdat-processor.var.bytes [d env] - (match d.size - 1 (int8-to-bytes (or d.init 0)) - 2 (int16-to-bytes (or d.init 0)) - n (string.rep "\0" n))) -(fn pdat-processor.ref.bytes [ref env] - (int16-to-bytes (env:lookup-addr ref.target))) - -(fn pdat-processor.block.symbols [block] - (lume.keys block.symbols)) - -(fn pdat-processor.block.patch [block env] - (local block-env (make-env block env)) - (each [_ pdat (ipairs block.pdats)] - (process-pdat pdat :patch nil block-env))) - -(fn pdat-processor.block.allocate [block addr] - (var size 0) - (set block.addr addr) - (each [_ pdat (ipairs block.pdats)] - (set pdat.addr (+ addr size)) - (process-pdat pdat :allocate nil pdat.addr) - (local pdatsize (process-pdat pdat :size pdat.size)) - (set pdat.size pdatsize) - (set pdat.addr (+ addr size)) - (set size (+ size pdatsize))) - (set block.size size)) - -(fn pdat-processor.block.generate [block env] - (local block-env (make-env block env)) - (var bytes "") - (each [_ pdat (ipairs block.pdats)] - (process-pdat pdat :generate nil block-env) - (local pdatbytes (process-pdat pdat :bytes pdat.bytes block-env)) - (assert (= (type pdatbytes) :string) (.. "failed to generate bytes: " (fv pdat))) - (set pdat.bytes pdatbytes) - (set bytes (.. bytes pdatbytes))) - (set block.bytes bytes)) - (fn program [] + ; dat - anything that takes up space in the assembled output (op, dw, db, etc) + ; takes the form [:op args] + ; pdat - a parsed dat; takes the form {:type type :addr addr ...} + (local dat-parser {}) + (fn new-block [] {:type :block :pdats [] :symbols {}}) + + (fn parse-dats [block dats] + (each [_ dat (ipairs dats)] + (if (= (type dat) "string") + (tset block.symbols dat (+ (length block.pdats) 1)) + (let [opcode (. dat 1) + parser (. dat-parser opcode) + pdat + (if + parser (parser dat block) + (. opcodes opcode) (dat-parser.op dat) + (error (.. "Unrecognized opcode " (fv opcode))))] + (table.insert block.pdats pdat)))) + block) + + (fn dat-parser.op [op] + (let [[mode arg] (parse-mode-arg op)] + {:type :op :opcode (. op 1) : mode : arg})) + + (fn dat-parser.block [block] + (let [dats (lume.clone block)] + (table.remove dats 1) + (parse-dats (new-block) dats))) + + (fn dat-parser.db [db] {:type :var :init (. db 2) :size 1}) + (fn dat-parser.dw [dw] {:type :var :init (. dw 2) :size 2}) + (fn dat-parser.bytes [bytes] {:type :raw :bytes (. bytes 2)}) + (fn dat-parser.ref [ref] {:type :ref :target (. ref 2)}) + (fn dat-parser.flatten [flat block] + (parse-dats block (lume.slice flat 2)) + nil) + + (local pdat-processor { + :op {} + :var {} + :ref {} + :raw {} + :block {} + }) + + (fn process-pdat [pdat process default ...] + (pp pdat) + (local processor (. pdat-processor pdat.type process)) + (if processor (processor pdat ...) default)) + + (fn pdat-processor.op.patch [op env] + (when (and op.mode (= (op.mode:sub 1 4) :addr)) + (let [zp-mode (.. :zp (op.mode:sub 5)) + abs-mode (.. :abs (op.mode:sub 5)) + is-zp (and ((. opcodes op.opcode) zp-mode) (env:is-zp? op.arg))] + (set op.mode (if is-zp zp-mode abs-mode))))) + + (fn pdat-processor.raw.size [raw] (length raw.bytes)) + (fn pdat-processor.op.size [op] (size op.mode)) + (fn pdat-processor.var.size [d] d.size) + (fn pdat-processor.ref.size [r] 2) + + (fn pdat-processor.op.bytes [op env] + (local bytegen (. opcodes op.opcode)) + ; (pp op) + (if bytegen + (let [opbyte (bytegen op.mode) + argbytes + (if + (and (= op.mode :imm) (= (type op.arg) "function")) + (int8-to-bytes (op.arg env)) + + (= op.mode :imm) (int8-to-bytes op.arg) + (= op.mode :rel) + (int8-to-bytes (- (env:lookup-addr op.arg) (+ op.addr 2))) + (= (size op.mode) 2) (int8-to-bytes (env:lookup-addr op.arg)) + (= (size op.mode) 3) (int16-to-bytes (env:lookup-addr op.arg)) + "")] + (if opbyte + (.. (int8-to-bytes opbyte) argbytes) + (error (.. op.opcode " doesn't support mode " op.mode)))) + "")) + (fn pdat-processor.var.bytes [d env] + (match d.size + 1 (int8-to-bytes (or d.init 0)) + 2 (int16-to-bytes (or d.init 0)) + n (string.rep "\0" n))) + (fn pdat-processor.ref.bytes [ref env] + (int16-to-bytes (env:lookup-addr ref.target))) + + (fn pdat-processor.block.symbols [block] + (lume.keys block.symbols)) + + (fn pdat-processor.block.patch [block env] + (local block-env (make-env block env)) + (each [_ pdat (ipairs block.pdats)] + (process-pdat pdat :patch nil block-env))) + + (fn pdat-processor.block.allocate [block addr] + (var size 0) + (set block.addr addr) + (each [_ pdat (ipairs block.pdats)] + (set pdat.addr (+ addr size)) + (process-pdat pdat :allocate nil pdat.addr) + (local pdatsize (process-pdat pdat :size pdat.size)) + (set pdat.size pdatsize) + (set pdat.addr (+ addr size)) + (set size (+ size pdatsize))) + (set block.size size)) + + (fn pdat-processor.block.generate [block env] + (local block-env (make-env block env)) + (var bytes "") + (each [_ pdat (ipairs block.pdats)] + (process-pdat pdat :generate nil block-env) + (local pdatbytes (process-pdat pdat :bytes pdat.bytes block-env)) + (assert (= (type pdatbytes) :string) (.. "failed to generate bytes: " (fv pdat))) + (set pdat.bytes pdatbytes) + (set bytes (.. bytes pdatbytes))) + (set block.bytes bytes)) + {:type :program :org-to-block {} :symbol-to-org {} :start-symbol :main + : dat-parser + : pdat-processor + : new-block + :parse-dats (fn [self block dats] (parse-dats block dats)) :dbg (fn [self ...] (when self.dbgfile @@ -311,12 +307,12 @@ (self:pass :generate) (when self.dbgfile (self.dbgfile:close) - (set self.dbgfile nil))) + (set self.dbgfile nil)) + self) :upload (fn [self machine] (each [org block (pairs self.org-to-block)] (machine:write org block.bytes))) }) -{: program : dat-parser : pdat-processor : new-block : parse-dats : lo : hi} - +{:new program} diff --git a/main.lua b/main.lua index 43bc95a..06b9f29 100644 --- a/main.lua +++ b/main.lua @@ -6,11 +6,6 @@ pp = function(x) print(fv(x)) end lume = require("lume") luars232 = require("luars232") -function reload(modname) - package.loaded[modname] = nil - return require(modname) -end - _coroutine_resume = coroutine.resume function coroutine.resume(...) local state,result = _coroutine_resume(...) diff --git a/neut.fnl b/neut.fnl new file mode 100644 index 0000000..8c384f1 --- /dev/null +++ b/neut.fnl @@ -0,0 +1,156 @@ +(local lume (require "lume")) +(local asm (require "asm")) +(local VM (require "vm")) +(local {: lo : hi} (require "util")) + +(local prg (asm.new)) +; (prg:debug-to "test.dbg") + +(local tiles (prg:org 0x6100)) +(local vm (VM.new prg)) +(local code1 vm.code) + +(local mon { + :hexout :0xfdda + :putchar :0xfded + :bell :0xff3a +}) + +(fn achar [c] (bit.bor (string.byte c) 0x80)) +(fn astr [s] + (-> [(string.byte s 1 -1)] + (lume.map #(bit.bor $1 0x80)) + (-> (table.unpack) (string.char)))) + +; a handful of debugging words +(vm:def :. + [:lda vm.TOPH :x] + [:jsr mon.hexout] + [:lda vm.TOP :x] + [:jsr mon.hexout] + [:lda (achar " ")] + [:jsr mon.putchar] + (vm:drop)) + +(vm:def :stacklen + (vm:reserve) + [:txa] [:lsr :a] [:sta vm.TOP :x] + [:lda 0] [:sta vm.TOPH :x]) + +(vm:word :.s + :stacklen (prg:parse-addr vm.TOP) :swap + (vm:for :dup :get :. :inc :inc) :drop) + +; Graphics routines +(vm:def :mixed-hires + [:sta :0xc050] + [:sta :0xc057] + [:sta :0xc052]) + +; starting address: +; 0x2000 + (x*2) + (y%4 * 0x100) + ((y/4) * 0x28) +; x between 0-19 +; y between 0-12 +; yx - 16-bit value, low byte x, high byte y +(code1:append :screeny-lookup [:bytes "\0\040\080"]) +(vm:def :tile>screen ; yx -- p + [:lda vm.TOPH :x] ; a=y + [:lsr :a] [:lsr :a] ; a=y/4 + [:tay] ; y=y/4 + [:lda 0x03] + [:and vm.TOPH :x] ; a=y%4 + [:ora 0x20] ; a=0x20 + y%4 + [:sta vm.TOPH :x] ; high byte is set (and y is wiped) + [:lda vm.TOP :x] ; a=x + [:asl :a] ; a = x*2 + [:clc] + [:adc :screeny-lookup :y] ; a=x*2 + (y/4)*0x28 + [:sta vm.TOP :x] ; low byte is set +) + +; note: the graphical tile data must not cross a page boundary! +; TODO: add support to the assembler for enforcing that +(fn draw-block [] + [:block + [:clc] + [:ldy 8] + :loop + [:lda [vm.TOP :x]] + [:sta [vm.ST1 :x]] + [:inc vm.TOP :x] + [:lda vm.ST1H :x] + [:adc 4] + [:sta vm.ST1H :x] + [:dey] + [:bne :loop]]) + +(fn draw-vertical-block [] + [:block + (draw-block) + [:lda vm.ST1H :x] + [:sbc 31] ; with carry clear this is 32 + [:sta vm.ST1H :x] + [:lda vm.ST1 :x] + [:ora 0x80] + [:sta vm.ST1 :x] + (draw-block)]) + +(vm:def :drawtile ; p gfx -- + (draw-vertical-block) + [:lda vm.ST1H :x] + [:sbc 31] + [:sta vm.ST1H :x] + [:lda vm.ST1 :x] + [:sbc 0x7f] + [:sta vm.ST1 :x] + (draw-vertical-block) + (vm:drop) (vm:drop)) + +(vm:def :cleargfx + (vm:push 0x4000) + [:block :page + [:dec vm.TOPH :x] + [:lda 0] + [:block :start + [:sta [vm.TOP :x]] + [:inc vm.TOP :x] + [:bne :start]] + [:lda vm.TOPH :x] + [:cmp 0x20] + [:bne :page]] + (vm:drop)) + +(vm:word :drawmaprow ; pscreen pmap -- pmap + 20 (vm:for + :2dup :bget :lookup-tile :drawtile + :inc :swap :inc :inc :swap) :swap :drop) + +(vm:word :drawmap + :lit :map 0x0c00 (vm:until 0x100 :- + :dup :tile>screen ; pmap yx pscreen + : [(string.byte s 1 -1)] - (lume.map #(bit.bor $1 0x80)) - (-> (table.unpack) (string.char)))) - -(code1:append :next - [:ldy 0] - [:lda [vm.IP] :y] [:sta vm.W] - (inc16 vm.IP vm.IPH) - [:lda [vm.IP] :y] [:sta vm.WH] - (inc16 vm.IP vm.IPH) - -; [:lda vm.WH] -; [:jsr mon.hexout] -; [:lda vm.W] -; [:jsr mon.hexout] -; [:lda (achar " ")] -; [:jsr mon.putchar] - - [:jmp [vm.W]]) - -(code1:append :reset - [:lda #(lo ($1:lookup-addr :quit))] - [:sta vm.IP] - [:lda #(hi ($1:lookup-addr :quit))] - [:sta vm.IPH] - [:lda 0] - [:sta vm.ROFF] - [:ldx 0xfe] - [:rts]) - -(vm:def - :subroutine ; usage: [jsr :subroutine] followed by bytecode - [:ldy vm.ROFF] - [:lda vm.IP] [:sta vm.RSTACK :y] [:iny] - [:lda vm.IPH] [:sta vm.RSTACK :y] [:iny] - [:sty vm.ROFF] - :interpret ; usage: [jsr :interpret] followed by bytecode - [:pla] [:sta vm.IP] [:pla] [:sta vm.IPH] - (inc16 vm.IP vm.IPH)) - -(vm:def :ret - [:ldy vm.ROFF] - [:dey] [:lda vm.RSTACK :y] [:sta vm.IPH] - [:dey] [:lda vm.RSTACK :y] [:sta vm.IP] - [:sty vm.ROFF]) - -(code1:append :native [:jmp [vm.IP]]) -(code1:append :quit [:rts]) -(code1:append :restore - [:lda vm.IP] [:sta vm.W] - [:lda vm.IPH] [:sta vm.WH] - [:ldy vm.ROFF] - [:dey] [:lda vm.RSTACK :y] [:sta vm.IPH] - [:dey] [:lda vm.RSTACK :y] [:sta vm.IP] - [:sty vm.ROFF] - [:jmp [vm.W]]) - - (vm:def :mixed-hires - [:sta :0xc050] - [:sta :0xc057] - [:sta :0xc052]) - -(vm:def :drop (vm:drop)) - -(vm:def :dup - (vm:reserve) - [:lda vm.ST1H :x] - [:sta vm.TOPH :x] - [:lda vm.ST1 :x] - [:sta vm.TOP :x]) - -(vm:def :swap - [:lda vm.TOP :x] - [:ldy vm.ST1 :x] - [:sty vm.TOP :x] - [:sta vm.ST1 :x] - [:lda vm.TOPH :x] - [:ldy vm.ST1H :x] - [:sty vm.TOPH :x] - [:sta vm.ST1H :x]) - -(vm:def :over - (vm:reserve) - [:lda vm.ST2H :x] - [:sta vm.TOPH :x] - [:lda vm.ST2 :x] - [:sta vm.TOP :x]) -(vm:word :2dup :over :over) - -(vm:def :>rot ; (a b c -- c a b) - [:lda vm.TOP :x] ; a: c (a b c) - [:ldy vm.ST2 :x] ; y: a (a b c) - [:sta vm.ST2 :x] ; a: c (c b c) - [:lda vm.ST1 :x] ; a: b (c b c) - [:sta vm.TOP :x] ; a: b (c b b) - [:sty vm.ST1 :x] ; y: a (c a b) - [:lda vm.TOPH :x] ; a: c (a b c) - [:ldy vm.ST2H :x] ; y: a (a b c) - [:sta vm.ST2H :x] ; a: c (c b c) - [:lda vm.ST1H :x] ; a: b (c b c) - [:sta vm.TOPH :x] ; a: b (c b b) - [:sty vm.ST1H :x] ; y: a (c a b) -) -(vm:def :r ; v -- - [:ldy vm.ROFF] - [:lda vm.TOP :x] [:sta vm.RSTACK :y] [:iny] - [:lda vm.TOPH :x] [:sta vm.RSTACK :y] [:iny] - [:sty vm.ROFF] - (vm:drop)) - -(vm:def :r> ; -- v - (vm:reserve) - [:ldy vm.ROFF] - [:dey] [:lda vm.RSTACK :y] [:sta vm.TOPH :x] - [:dey] [:lda vm.RSTACK :y] [:sta vm.TOP :x] - [:sty vm.ROFF]) - -(vm:def :rtop ; -- v - (vm:reserve) - [:ldy vm.ROFF] - [:dey] [:lda vm.RSTACK :y] [:sta vm.TOPH :x] - [:dey] [:lda vm.RSTACK :y] [:sta vm.TOP :x]) - -(vm:def :rdrop - [:ldy vm.ROFF] [:dey] [:dey] [:sty vm.ROFF]) - -(vm:def :bz ; f -- - [:block - [:lda vm.TOP :x] - [:bne :skip] - [:lda vm.TOPH :x] - [:beq :dojmp] - :skip - (vm:drop) - [:lda 2] (add16 vm.IP vm.IPH) (vm:ret) - :dojmp (vm:drop)] - :jmp - ; ugh I don't have enough registers for this; a (one-byte?) relative jump would maybe be better - [:ldy 0] [:lda [vm.IP] :y] [:sta vm.W] - [:iny] [:lda [vm.IP] :y] [:sta vm.IPH] - [:lda vm.W] [:sta vm.IP]) - -(fn vm.while [self preamble ...] - [:block - :start - [:vm (table.unpack preamble)] - [:ref :bz] [:ref :end] - [:vm ...] - [:ref :jmp] [:ref :start] - :end]) - -(fn vm.until [self ...] - [:block :start [:vm ...] [:ref :bz] [:ref :start]]) - -(fn vm.for [self ...] - [:vm :>r (vm:while [:rtop] [:vm ...] :r> :dec :>r) :rdrop]) - -(vm:def :+ ; a b -- c - [:clc] - [:lda vm.ST1 :x] [:adc vm.TOP :x] [:sta vm.ST1 :x] - [:lda vm.ST1H :x] [:adc vm.TOPH :x] [:sta vm.ST1H :x] - (vm:drop)) - -(vm:def :- ; a b -- c - [:sec] - [:lda vm.ST1 :x] [:sbc vm.TOP :x] [:sta vm.ST1 :x] - [:lda vm.ST1H :x] [:sbc vm.TOPH :x] [:sta vm.ST1H :x] - (vm:drop)) - -(vm:def :inc ; a -- a+1 - (inc16-stk vm.TOP vm.TOPH)) - -(vm:def :dec ; a -- a-1 - [:block - [:lda vm.TOP :x] - [:bne :declow] - [:dec vm.TOPH :x] - :declow - [:dec vm.TOP :x]]) - -(vm:def :not ; f - !f - [:block - [:lda vm.TOP :x] - [:bne :zero] - [:lda vm.TOPH :x] - [:bne :zero] - [:lda 0xff] [:sta vm.TOP :x] [:sta vm.TOPH :x] (vm:ret) - :zero - [:lda 0] [:sta vm.TOP :x] [:sta vm.TOPH :x]]) - -(vm:def := ; a b -- f - [:block - [:lda vm.ST1 :x] - [:cmp vm.TOP :x] - [:bne :noteq] - [:lda vm.ST1H :x] - [:cmp vm.TOP :x] - [:bne :noteq] - [:lda 0xff] (vm:drop) [:sta vm.TOP :x] [:sta vm.TOPH :x] (vm:ret) - :noteq - [:lda 0] (vm:drop) [:sta vm.TOP :x] [:sta vm.TOPH :x]]) - -(vm:def :. - [:lda vm.TOPH :x] - [:jsr mon.hexout] - [:lda vm.TOP :x] - [:jsr mon.hexout] - [:lda (achar " ")] - [:jsr mon.putchar] - (vm:drop)) - -(vm:def :stacklen - (vm:reserve) - [:txa] [:lsr :a] [:sta vm.TOP :x] - [:lda 0] [:sta vm.TOPH :x]) - -(vm:word :.s - :stacklen (prg:parse-addr vm.TOP) :swap - (vm:for :dup :get :. :inc :inc) :drop) - -; starting address: -; 0x2000 + (x*2) + (y%4 * 0x100) + ((y/4) * 0x28) -; x between 0-19 -; y between 0-12 -; yx - 16-bit value, low byte x, high byte y -(code1:append :screeny-lookup [:bytes "\0\040\080"]) -(vm:def :tile>screen ; yx -- p - [:lda vm.TOPH :x] ; a=y - [:lsr :a] [:lsr :a] ; a=y/4 - [:tay] ; y=y/4 - [:lda 0x03] - [:and vm.TOPH :x] ; a=y%4 - [:ora 0x20] ; a=0x20 + y%4 - [:sta vm.TOPH :x] ; high byte is set (and y is wiped) - [:lda vm.TOP :x] ; a=x - [:asl :a] ; a = x*2 - [:clc] - [:adc :screeny-lookup :y] ; a=x*2 + (y/4)*0x28 - [:sta vm.TOP :x] ; low byte is set -) - -; note: the graphical tile data must not cross a page boundary! -; TODO: add support to the assembler for enforcing that -(fn draw-block [] - [:block - [:clc] - [:ldy 8] - :loop - [:lda [vm.TOP :x]] - [:sta [vm.ST1 :x]] - [:inc vm.TOP :x] - [:lda vm.ST1H :x] - [:adc 4] - [:sta vm.ST1H :x] - [:dey] - [:bne :loop]]) - -(fn draw-vertical-block [] - [:block - (draw-block) - [:lda vm.ST1H :x] - [:sbc 31] ; with carry clear this is 32 - [:sta vm.ST1H :x] - [:lda vm.ST1 :x] - [:ora 0x80] - [:sta vm.ST1 :x] - (draw-block)]) - -(vm:def :drawtile ; p gfx -- - (draw-vertical-block) - [:lda vm.ST1H :x] - [:sbc 31] - [:sta vm.ST1H :x] - [:lda vm.ST1 :x] - [:sbc 0x7f] - [:sta vm.ST1 :x] - (draw-vertical-block) - (vm:drop) (vm:drop)) - -(vm:def :cleargfx - (vm:push 0x4000) - [:block :page - [:dec vm.TOPH :x] - [:lda 0] - [:block :start - [:sta [vm.TOP :x]] - [:inc vm.TOP :x] - [:bne :start]] - [:lda vm.TOPH :x] - [:cmp 0x20] - [:bne :page]] - (vm:drop)) - -(vm:word :drawmaprow ; pscreen pmap -- pmap - 20 (vm:for - :2dup :bget :lookup-tile :drawtile - :inc :swap :inc :inc :swap) :swap :drop) - -(vm:word :drawmap - :lit :map 0x0c00 (vm:until 0x100 :- - :dup :tile>screen ; pmap yx pscreen - :rot ; (a b c -- c a b) + [:lda vm.TOP :x] ; a: c (a b c) + [:ldy vm.ST2 :x] ; y: a (a b c) + [:sta vm.ST2 :x] ; a: c (c b c) + [:lda vm.ST1 :x] ; a: b (c b c) + [:sta vm.TOP :x] ; a: b (c b b) + [:sty vm.ST1 :x] ; y: a (c a b) + [:lda vm.TOPH :x] ; a: c (a b c) + [:ldy vm.ST2H :x] ; y: a (a b c) + [:sta vm.ST2H :x] ; a: c (c b c) + [:lda vm.ST1H :x] ; a: b (c b c) + [:sta vm.TOPH :x] ; a: b (c b b) + [:sty vm.ST1H :x] ; y: a (c a b) + ) + (vm:def :r ; v -- + [:ldy vm.ROFF] + [:lda vm.TOP :x] [:sta vm.RSTACK :y] [:iny] + [:lda vm.TOPH :x] [:sta vm.RSTACK :y] [:iny] + [:sty vm.ROFF] + (vm:drop)) + + (vm:def :r> ; -- v + (vm:reserve) + [:ldy vm.ROFF] + [:dey] [:lda vm.RSTACK :y] [:sta vm.TOPH :x] + [:dey] [:lda vm.RSTACK :y] [:sta vm.TOP :x] + [:sty vm.ROFF]) + + (vm:def :rtop ; -- v + (vm:reserve) + [:ldy vm.ROFF] + [:dey] [:lda vm.RSTACK :y] [:sta vm.TOPH :x] + [:dey] [:lda vm.RSTACK :y] [:sta vm.TOP :x]) + + (vm:def :rdrop + [:ldy vm.ROFF] [:dey] [:dey] [:sty vm.ROFF]) + + (vm:def :bz ; f -- + [:block + [:lda vm.TOP :x] + [:bne :skip] + [:lda vm.TOPH :x] + [:beq :dojmp] + :skip + (vm:drop) + [:lda 2] (add16 vm.IP vm.IPH) (vm:ret) + :dojmp (vm:drop)] + :jmp + ; ugh I don't have enough registers for this; a (one-byte?) relative jump would maybe be better + [:ldy 0] [:lda [vm.IP] :y] [:sta vm.W] + [:iny] [:lda [vm.IP] :y] [:sta vm.IPH] + [:lda vm.W] [:sta vm.IP]) + + (fn vm.while [self preamble ...] + [:block + :start + [:vm (table.unpack preamble)] + [:ref :bz] [:ref :end] + [:vm ...] + [:ref :jmp] [:ref :start] + :end]) + + (fn vm.until [self ...] + [:block :start [:vm ...] [:ref :bz] [:ref :start]]) + + (fn vm.for [self ...] + [:vm :>r (vm:while [:rtop] :r> :dec :>r ...) :rdrop]) + + (vm:def :+ ; a b -- c + [:clc] + [:lda vm.ST1 :x] [:adc vm.TOP :x] [:sta vm.ST1 :x] + [:lda vm.ST1H :x] [:adc vm.TOPH :x] [:sta vm.ST1H :x] + (vm:drop)) + + (vm:def :- ; a b -- c + [:sec] + [:lda vm.ST1 :x] [:sbc vm.TOP :x] [:sta vm.ST1 :x] + [:lda vm.ST1H :x] [:sbc vm.TOPH :x] [:sta vm.ST1H :x] + (vm:drop)) + + (vm:def :inc ; a -- a+1 + (inc16-stk vm.TOP vm.TOPH)) + + (vm:def :dec ; a -- a-1 + [:block + [:lda vm.TOP :x] + [:bne :declow] + [:dec vm.TOPH :x] + :declow + [:dec vm.TOP :x]]) + + (vm:def :not ; f - !f + [:block + [:lda vm.TOP :x] + [:bne :zero] + [:lda vm.TOPH :x] + [:bne :zero] + [:lda 0xff] [:sta vm.TOP :x] [:sta vm.TOPH :x] (vm:ret) + :zero + [:lda 0] [:sta vm.TOP :x] [:sta vm.TOPH :x]]) + + (vm:def := ; a b -- f + [:block + [:lda vm.ST1 :x] + [:cmp vm.TOP :x] + [:bne :noteq] + [:lda vm.ST1H :x] + [:cmp vm.TOP :x] + [:bne :noteq] + [:lda 0xff] (vm:drop) [:sta vm.TOP :x] [:sta vm.TOPH :x] (vm:ret) + :noteq + [:lda 0] (vm:drop) [:sta vm.TOP :x] [:sta vm.TOPH :x]]) + vm) + +{:new mk-vm} diff --git a/wrap.fnl b/wrap.fnl index 07112a1..e925529 100644 --- a/wrap.fnl +++ b/wrap.fnl @@ -1,5 +1,5 @@ (require "lite") -(require "util") +(local util (require "util")) (local lume (require "lume")) (local imgui (require "imgui")) (local serial (require "serial")) @@ -19,12 +19,12 @@ }) (command.add #(machine:connected?) { "honeylisp:upload" (fn [] - (local p (reload "test")) + (local p (util.reload "neut")) (p:upload machine) (core.log (string.format "%x" (p:lookup-addr p.start-symbol)))) }) (command.add (fn [] true) { - "honeylisp:rebuild" #(reload "test") + "honeylisp:rebuild" #(util.reload "neut") }) (fn selected-symbol [] @@ -52,11 +52,11 @@ (: :gsub "^data%." "") (: :gsub "%.init$" ""))) (core.log (.. "Hotswapping " modname)) - (local (mod err) (lume.hotswap modname)) + (local (mod err) (util.hotswap modname)) (when (not= err nil) (print err) (error err))) "honeylisp:address" (fn [] (local word (selected-symbol)) - (local p (require "test")) + (local p (require "neut")) (core.log (string.format "%s %x" word (or (p:lookup-addr word) -1))) ) })