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

bugfixes, debug tools, loops, working full map drawing routine

Browse source
This commit is contained in:
Jeremy Penner 2020-10-04 15:10:56 -04:00
parent 9e6c849faf
commit a524f23dfe
3 changed files with 249 additions and 39 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

58
asm.fnl
View file

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

207
test.fnl
View file

@ -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)
@ -41,13 +43,12 @@
: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,13 +57,16 @@
: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]
@ -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
@ -135,12 +162,12 @@
(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
@ -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
:<rot :drawmaprow :swap ; pmap yx
:dup :not) :drop :drop)
(vm:def :lookup-tile ; itile -- ptile
; each tile is 32 bytes; 2^5
; we save some cycles by storing the indices as lllhhhhh, so we don't need to shift them'
[:lda vm.TOP :x] [:tay]
[:and 0x1f]
[:clc] [:adc #(hi tiles.org)]
[:sta vm.TOPH :x]
[:tya] [:and 0xe0]
[:sta vm.TOP :x])
(tiles:append :blanktile [:bytes "\0\0\0\0\0\0\0\0\0\255\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0 \0\0\0\0\0\0"])
(tiles:append :testtile [:bytes "12345678901234567890123456789012"])
(tiles:append [:bytes "zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz"])
;; 19x11 means full map is 209 bytes
(: (prg:org 0x6800) :append :map [:bytes (string.rep "\0\032\064" 85)])
(code1:append :main
[:jsr :reset]
[:jsr :interpret]
[:vm :mixed-hires
:cleargfx
0x0000 :tile>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)

15
wrap.fnl
View file

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