From a524f23dfe2ed9d10373211f1aaf7e189b4b08a1 Mon Sep 17 00:00:00 2001 From: Jeremy Penner Date: Sun, 4 Oct 2020 15:10:56 -0400 Subject: [PATCH] bugfixes, debug tools, loops, working full map drawing routine --- asm.fnl | 58 ++++++++++++--- test.fnl | 215 ++++++++++++++++++++++++++++++++++++++++++++++++------- wrap.fnl | 15 ++-- 3 files changed, 249 insertions(+), 39 deletions(-) diff --git a/asm.fnl b/asm.fnl index e058edb..9f23dc2 100644 --- a/asm.fnl +++ b/asm.fnl @@ -123,12 +123,24 @@ (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))) + (parse-dats block (lume.slice flat 2)) + nil) (fn make-env [block parent] {:parent parent :block block :is-zp? (fn [self name] (self.parent:is-zp? name)) + :lookup-pdat + (fn [self name] + (local ipdat (. self.block.symbols name)) + (if + (and ipdat (> ipdat (length self.block.pdats))) + nil + + ipdat (. self.block.pdats ipdat) + + (self.parent:lookup-pdat name))) + :lookup-addr (fn [self name] (local ipdat (. self.block.symbols name)) @@ -141,7 +153,6 @@ (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] @@ -158,6 +169,7 @@ }) (fn process-pdat [pdat process default ...] + (pp pdat) (local processor (. pdat-processor pdat.type process)) (if processor (processor pdat ...) default)) @@ -237,6 +249,16 @@ :org-to-block {} :symbol-to-org {} :start-symbol :main + :dbg + (fn [self ...] + (when self.dbgfile + (for [i 1 (select :# ...)] + (when (not= i 1) (self.dbgfile:write " ")) + (self.dbgfile:write (fv (select i ...)))) + (self.dbgfile:write "\n"))) + :debug-to + (fn [self filename] + (set self.dbgfile (io.open filename :w))) :org (fn [self org] (var block (. self.org-to-block org)) @@ -244,21 +266,30 @@ (set block (new-block)) (tset self.org-to-block org block)) {: block - :append (fn [self ...] (parse-dats self.block [...]) self)}) + : org + :prg self + :ptr (fn [self] (tostring self.org)) + :append (fn [self ...] (self.prg:dbg self.org ...) (parse-dats self.block [...]) self)}) + :parse-addr + (fn [self name] + (local addr (tonumber name)) + (if addr addr (error (.. "Symbol '" name "' not found")))) :is-zp? (fn [self name] (local org (. self.symbol-to-org name)) - (if (not= org nil) + (if org (< org 0x100) - (< (tonumber name) 0x100))) + (< (self:parse-addr name) 0x100))) + :env-lookup + (fn [self name lookup ...] + (local org (. self.symbol-to-org name)) + (and org (: (make-env (. self.org-to-block org) self) lookup name ...))) +; :lookup-symbol (fn [self addr]) TODO + :lookup-pdat (fn [self name] (self:env-lookup name :lookup-pdat)) :lookup-addr (fn [self name] ; (print "looking up" name "in" self) - (local org (. self.symbol-to-org name)) - (local addr (and org (: (make-env (. self.org-to-block org) self) :lookup-addr name))) - (if (not= addr nil) - addr - (tonumber name))) + (or (self:env-lookup name :lookup-addr) (self:parse-addr name))) :pass (fn [self passname] (each [org block (pairs self.org-to-block)] @@ -270,12 +301,17 @@ :patch (fn [self org block] (process-pdat block :patch nil self)) :allocate (fn [self org block] (process-pdat block :allocate nil org)) :generate (fn [self org block] (process-pdat block :generate nil self)) + :debug-pass (fn [self org block] (self:dbg org block)) :assemble (fn [self] (self:pass :gather-symbols) (self:pass :patch) (self:pass :allocate) - (self:pass :generate)) + (self:pass :debug-pass) + (self:pass :generate) + (when self.dbgfile + (self.dbgfile:close) + (set self.dbgfile nil))) :upload (fn [self machine] (each [org block (pairs self.org-to-block)] diff --git a/test.fnl b/test.fnl index 07e2cfd..ce6f141 100644 --- a/test.fnl +++ b/test.fnl @@ -6,6 +6,8 @@ (local code1 (prg:org 0xc00)) (local tiles (prg:org 0x6100)) +(prg:debug-to "test.dbg") + (fn dat-parser.vm [bytecodes] (local block (new-block)) (each [_ bytecode (ipairs (lume.slice bytecodes 2))] @@ -17,7 +19,7 @@ (parse-dats block [[:ref bytecode]]) (= (type bytecode) :table) - (parse-dats block bytecode) + (parse-dats block [bytecode]) (error (.. "VM can't parse " (fv bytecode))))) block) @@ -34,20 +36,19 @@ :WH :0x63 :ROFF :0x64 :TOP :0x80 - :TOPH :0x81 + :TOPH :0x81 :ST1 :0x7e :ST1H :0x7f :ST2 :0x7c :ST2H :0x7d :RSTACK :0x6000 :ret (fn [self] [:jmp :next]) + :reserve (fn [self] [:block [:inx] [:inx]]) :push (fn [self v] (local l (bit.band v 0xff)) (local h (bit.band (bit.rshift v 8) 0xff)) - [:block - [:inx] - [:inx] + [:block (self:reserve) [:lda l] [:sta self.TOP :x] [:lda h] @@ -56,14 +57,17 @@ :drop (fn [self] [:block [:dex] [:dex]]) :def (fn [self name ...] - (code1:append name (table.unpack (lume.concat [...] [(self:ret)])))) + (code1:append name [:flatten ...] (self:ret))) :word (fn [self name ...] (code1:append name [:jsr :subroutine] [:vm ...] [:vm :ret])) :inline (fn [self ...] [:block [:jsr :subroutine] [:vm ...] [:vm :restore]]) - }) + :asm + (fn [self ...] + [:block [:vm :native] [:block ...] [:jsr :interpret]]) +}) (fn inc16 [l h] [:block @@ -72,6 +76,14 @@ [:inc h] :done ]) +(fn dec16 [l h] + [:block + [:lda l] + [:bne :declow] + [:dec h] + :declow + [:dec l]]) + (fn add16 [l h] [:block [:clc] @@ -81,6 +93,13 @@ [:inc h] :go ]) +(fn inc16-stk [l h] + [:block + [:inc l :x] + [:bne :done] + [:inc h :x] + :done]) + (fn achar [c] (bit.bor (string.byte c) 0x80)) (fn astr [s] (-> [(string.byte s 1 -1)] @@ -93,6 +112,14 @@ (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 @@ -132,15 +159,15 @@ [:sty vm.ROFF] [:jmp [vm.W]]) -(vm:def :mixed-hires + (vm:def :mixed-hires [:sta :0xc050] [:sta :0xc057] - [:sta :0xc053]) + [:sta :0xc052]) (vm:def :drop (vm:drop)) (vm:def :dup - [:inx] [:inx] + (vm:reserve) [:lda vm.ST1H :x] [:sta vm.TOPH :x] [:lda vm.ST1 :x] @@ -157,7 +184,7 @@ [:sta vm.ST1H :x]) (vm:def :over - [:inx] [:inx] + (vm:reserve) [:lda vm.ST2H :x] [:sta vm.TOPH :x] [:lda vm.ST2 :x] @@ -196,18 +223,133 @@ (vm:def :get [:lda [vm.TOP :x]] [:tay] - (inc16 vm.TOP vm.TOPH) + (inc16-stk vm.TOP vm.TOPH) [:lda [vm.TOP :x]] [:sta vm.TOPH :x] [:sty vm.TOP :x]) +(vm:def :set ; v p -- + [:lda vm.ST1 :x] + [:sta [vm.TOP :x]] + (inc16-stk vm.TOP vm.TOPH) + [:lda vm.ST1H :x] + [:sta [vm.TOP :x]] + (vm:drop) (vm:drop)) + +(vm:def :bget ; p -- b + [:lda [vm.TOP :x]] [:sta vm.TOP :x] + [:lda 0] [:sta vm.TOPH :x]) + +(vm:def :bset ; b p -- + [:lda vm.ST1 :x] [:sta [vm.TOP :x]] + (vm:drop) (vm:drop)) + (vm:def :lit - [:inx] [:inx] [:ldy 0] + (vm:reserve) [:ldy 0] [:lda [vm.IP] :y] [:sta vm.TOP :x] (inc16 vm.IP vm.IPH) [:lda [vm.IP] :y] [:sta vm.TOPH :x] (inc16 vm.IP vm.IPH)) +(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] @@ -217,6 +359,15 @@ [: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 @@ -244,7 +395,7 @@ [:block [:clc] [:ldy 8] - :loop + :loop [:lda [vm.TOP :x]] [:sta [vm.ST1 :x]] [:inc vm.TOP :x] @@ -274,8 +425,7 @@ [:sbc 0x7f] [:sta vm.ST1 :x] (draw-vertical-block) - (vm:drop) (vm:drop) - ) + (vm:drop) (vm:drop)) (vm:def :cleargfx (vm:push 0x4000) @@ -291,20 +441,37 @@ [:bne :page]] (vm:drop)) -(tiles:append :blanktile [:bytes "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"]) +(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 + :screen :lit :testtile :drawtile - 0x0200 :tile>screen :lit :testtile :drawtile - 0x0002 :tile>screen :lit :testtile :drawtile - 0x0202 :tile>screen :lit :testtile :drawtile - 0x0606 :tile>screen :lit :testtile :drawtile - 0x0913 :tile>screen :lit :testtile :drawtile + :cleargfx :drawmap :quit]) (prg:assemble) diff --git a/wrap.fnl b/wrap.fnl index d1addc9..07112a1 100644 --- a/wrap.fnl +++ b/wrap.fnl @@ -26,6 +26,15 @@ (command.add (fn [] true) { "honeylisp:rebuild" #(reload "test") }) + +(fn selected-symbol [] + (local ldoc core.active_view.doc) + (var (aline acol bline bcol) (ldoc:get_selection)) + (when (and (= aline bline) (= acol bcol)) + (set (aline acol) (translate.start_of_word ldoc aline acol)) + (set (bline bcol) (translate.end_of_word ldoc bline bcol))) + (ldoc:get_text aline acol bline bcol)) + (command.add "core.docview" { "fennel:eval" (fn [] (let [ldoc core.active_view.doc @@ -46,10 +55,7 @@ (local (mod err) (lume.hotswap modname)) (when (not= err nil) (print err) (error err))) "honeylisp:address" (fn [] - (local ldoc core.active_view.doc) - (local (aline acol) (translate.start_of_word ldoc (ldoc:get_selection))) - (local (bline bcol) (translate.end_of_word ldoc (ldoc:get_selection))) - (local word (ldoc:get_text aline acol bline bcol)) + (local word (selected-symbol)) (local p (require "test")) (core.log (string.format "%s %x" word (or (p:lookup-addr word) -1))) ) @@ -57,6 +63,7 @@ (keymap.add { "alt+e" "fennel:eval" "alt+r" "lume:hotswap" + "alt+a" "honeylisp:address" }) (fn love.load [])