bugfixes, debug tools, loops, working full map drawing routine
This commit is contained in:
parent
9e6c849faf
commit
a524f23dfe
58
asm.fnl
58
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)]
|
||||
|
|
|
|||
211
test.fnl
211
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)
|
||||
|
|
@ -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,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
|
||||
|
|
@ -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
15
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 [])
|
||||
|
|
|
|||
Loading…
Reference in a new issue