Restructure for more reliable reload, modularity
This commit is contained in:
parent
a524f23dfe
commit
3c22f6fe2e
96
asm.fnl
96
asm.fnl
|
|
@ -1,6 +1,5 @@
|
||||||
(local lume (require "lume"))
|
(local lume (require "lume"))
|
||||||
(local {: stream : kvstream : one} (require "stream"))
|
(local {: int8-to-bytes : int16-to-bytes} (require "util"))
|
||||||
|
|
||||||
(local opcodes {})
|
(local opcodes {})
|
||||||
|
|
||||||
; op mode arg
|
; op mode arg
|
||||||
|
|
@ -33,7 +32,7 @@
|
||||||
modemap))
|
modemap))
|
||||||
|
|
||||||
(fn without-modes [modemap ...]
|
(fn without-modes [modemap ...]
|
||||||
(let [newmodemap (table.clone modemap)]
|
(let [newmodemap (lume.clone modemap)]
|
||||||
(each [_ mode (pairs [...])]
|
(each [_ mode (pairs [...])]
|
||||||
(tset newmodemap mode nil))
|
(tset newmodemap mode nil))
|
||||||
newmodemap))
|
newmodemap))
|
||||||
|
|
@ -89,43 +88,6 @@
|
||||||
[_] [nil nil]
|
[_] [nil nil]
|
||||||
_ (error (.. "Unrecognized syntax" (fv op)))))
|
_ (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]
|
(fn make-env [block parent]
|
||||||
{:parent parent
|
{:parent parent
|
||||||
:block block
|
:block block
|
||||||
|
|
@ -153,12 +115,43 @@
|
||||||
|
|
||||||
(self.parent:lookup-addr name)))})
|
(self.parent:lookup-addr name)))})
|
||||||
|
|
||||||
(fn lo [v] (bit.band v 0xff))
|
(fn program []
|
||||||
(fn hi [v] (bit.band (bit.rshift v 8) 0xff))
|
; dat - anything that takes up space in the assembled output (op, dw, db, etc)
|
||||||
(fn int8-to-bytes [i]
|
; takes the form [:op args]
|
||||||
(string.char (lo i)))
|
; pdat - a parsed dat; takes the form {:type type :addr addr ...}
|
||||||
(fn int16-to-bytes [i]
|
(local dat-parser {})
|
||||||
(string.char (lo i) (hi i)))
|
(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 {
|
(local pdat-processor {
|
||||||
:op {}
|
:op {}
|
||||||
|
|
@ -244,11 +237,14 @@
|
||||||
(set bytes (.. bytes pdatbytes)))
|
(set bytes (.. bytes pdatbytes)))
|
||||||
(set block.bytes bytes))
|
(set block.bytes bytes))
|
||||||
|
|
||||||
(fn program []
|
|
||||||
{:type :program
|
{:type :program
|
||||||
:org-to-block {}
|
:org-to-block {}
|
||||||
:symbol-to-org {}
|
:symbol-to-org {}
|
||||||
:start-symbol :main
|
:start-symbol :main
|
||||||
|
: dat-parser
|
||||||
|
: pdat-processor
|
||||||
|
: new-block
|
||||||
|
:parse-dats (fn [self block dats] (parse-dats block dats))
|
||||||
:dbg
|
:dbg
|
||||||
(fn [self ...]
|
(fn [self ...]
|
||||||
(when self.dbgfile
|
(when self.dbgfile
|
||||||
|
|
@ -311,12 +307,12 @@
|
||||||
(self:pass :generate)
|
(self:pass :generate)
|
||||||
(when self.dbgfile
|
(when self.dbgfile
|
||||||
(self.dbgfile:close)
|
(self.dbgfile:close)
|
||||||
(set self.dbgfile nil)))
|
(set self.dbgfile nil))
|
||||||
|
self)
|
||||||
:upload
|
:upload
|
||||||
(fn [self machine]
|
(fn [self machine]
|
||||||
(each [org block (pairs self.org-to-block)]
|
(each [org block (pairs self.org-to-block)]
|
||||||
(machine:write org block.bytes)))
|
(machine:write org block.bytes)))
|
||||||
})
|
})
|
||||||
|
|
||||||
{: program : dat-parser : pdat-processor : new-block : parse-dats : lo : hi}
|
{:new program}
|
||||||
|
|
||||||
|
|
|
||||||
5
main.lua
5
main.lua
|
|
@ -6,11 +6,6 @@ pp = function(x) print(fv(x)) end
|
||||||
lume = require("lume")
|
lume = require("lume")
|
||||||
luars232 = require("luars232")
|
luars232 = require("luars232")
|
||||||
|
|
||||||
function reload(modname)
|
|
||||||
package.loaded[modname] = nil
|
|
||||||
return require(modname)
|
|
||||||
end
|
|
||||||
|
|
||||||
_coroutine_resume = coroutine.resume
|
_coroutine_resume = coroutine.resume
|
||||||
function coroutine.resume(...)
|
function coroutine.resume(...)
|
||||||
local state,result = _coroutine_resume(...)
|
local state,result = _coroutine_resume(...)
|
||||||
|
|
|
||||||
156
neut.fnl
Normal file
156
neut.fnl
Normal file
|
|
@ -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
|
||||||
|
:<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 :drawmap
|
||||||
|
:quit])
|
||||||
|
|
||||||
|
(prg:assemble)
|
||||||
479
test.fnl
479
test.fnl
|
|
@ -1,479 +0,0 @@
|
||||||
(local lume (require "lume"))
|
|
||||||
(local {: program : dat-parser : new-block : parse-dats : lo : hi} (require "asm"))
|
|
||||||
(local {: stream : kvstream : one} (require "stream"))
|
|
||||||
|
|
||||||
(local prg (program))
|
|
||||||
(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))]
|
|
||||||
(if
|
|
||||||
(= (type bytecode) :number)
|
|
||||||
(parse-dats block [[:ref :lit] [:dw bytecode]])
|
|
||||||
|
|
||||||
(= (type bytecode) :string)
|
|
||||||
(parse-dats block [[:ref bytecode]])
|
|
||||||
|
|
||||||
(= (type bytecode) :table)
|
|
||||||
(parse-dats block [bytecode])
|
|
||||||
|
|
||||||
(error (.. "VM can't parse " (fv bytecode)))))
|
|
||||||
block)
|
|
||||||
(local mon {
|
|
||||||
:hexout :0xfdda
|
|
||||||
:putchar :0xfded
|
|
||||||
:bell :0xff3a
|
|
||||||
})
|
|
||||||
|
|
||||||
(local vm {
|
|
||||||
:IP :0x60
|
|
||||||
:IPH :0x61
|
|
||||||
:W :0x62
|
|
||||||
:WH :0x63
|
|
||||||
:ROFF :0x64
|
|
||||||
:TOP :0x80
|
|
||||||
: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 (self:reserve)
|
|
||||||
[:lda l]
|
|
||||||
[:sta self.TOP :x]
|
|
||||||
[:lda h]
|
|
||||||
[:sta self.TOPH :x]
|
|
||||||
])
|
|
||||||
:drop (fn [self] [:block [:dex] [:dex]])
|
|
||||||
:def
|
|
||||||
(fn [self name ...]
|
|
||||||
(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
|
|
||||||
[:inc l]
|
|
||||||
[:bne :done]
|
|
||||||
[:inc h]
|
|
||||||
:done
|
|
||||||
])
|
|
||||||
(fn dec16 [l h]
|
|
||||||
[:block
|
|
||||||
[:lda l]
|
|
||||||
[:bne :declow]
|
|
||||||
[:dec h]
|
|
||||||
:declow
|
|
||||||
[:dec l]])
|
|
||||||
|
|
||||||
(fn add16 [l h]
|
|
||||||
[:block
|
|
||||||
[:clc]
|
|
||||||
[:adc l]
|
|
||||||
[:sta l]
|
|
||||||
[:bcc :go]
|
|
||||||
[: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)]
|
|
||||||
(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 :<rot ; (a b c -- b c a)
|
|
||||||
[:lda vm.TOP :x] ; a: c (a b c)
|
|
||||||
[:ldy vm.ST1 :x] ; y: b (a b c)
|
|
||||||
[:sta vm.ST1 :x] ; a: c (a c c)
|
|
||||||
[:lda vm.ST2 :x] ; a: a (a c c)
|
|
||||||
[:sta vm.TOP :x] ; a: a (a c a)
|
|
||||||
[:sty vm.ST2 :x] ; y: b (b c a)
|
|
||||||
[:lda vm.TOPH :x] ; a: c (a b c)
|
|
||||||
[:ldy vm.ST1H :x] ; y: b (a b c)
|
|
||||||
[:sta vm.ST1H :x] ; a: c (a c c)
|
|
||||||
[:lda vm.ST2H :x] ; a: a (a c c)
|
|
||||||
[:sta vm.TOPH :x] ; a: a (a c a)
|
|
||||||
[:sty vm.ST2H :x] ; y: b (b c a)
|
|
||||||
)
|
|
||||||
|
|
||||||
(vm:def :get
|
|
||||||
[:lda [vm.TOP :x]]
|
|
||||||
[:tay]
|
|
||||||
(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
|
|
||||||
(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]
|
|
||||||
[: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 :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 :drawmap
|
|
||||||
:quit])
|
|
||||||
|
|
||||||
(prg:assemble)
|
|
||||||
|
|
||||||
prg
|
|
||||||
41
util.fnl
41
util.fnl
|
|
@ -1,9 +1,40 @@
|
||||||
(fn table.clone [tbl]
|
(local lume (require "lume"))
|
||||||
(let [newtbl {}]
|
|
||||||
(each [k v (pairs tbl)]
|
|
||||||
(tset newtbl k v))
|
|
||||||
newtbl))
|
|
||||||
(fn string.fromhex [str]
|
(fn string.fromhex [str]
|
||||||
(str:gsub ".." (fn [cc] (string.char (tonumber cc 16)))))
|
(str:gsub ".." (fn [cc] (string.char (tonumber cc 16)))))
|
||||||
(fn string.tohex [str]
|
(fn string.tohex [str]
|
||||||
(str:gsub "." (fn [c] (string.format "%02X" (string.byte c)))))
|
(str:gsub "." (fn [c] (string.format "%02X" (string.byte c)))))
|
||||||
|
|
||||||
|
(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)))
|
||||||
|
|
||||||
|
(fn reload [modname]
|
||||||
|
(tset package.loaded modname nil)
|
||||||
|
(require modname))
|
||||||
|
|
||||||
|
; lume.hotswap really assumes your module is a table
|
||||||
|
(fn hotswap [modname]
|
||||||
|
(if (= (type (. package.loaded modname)) :table)
|
||||||
|
(lume.hotswap modname)
|
||||||
|
(reload modname)))
|
||||||
|
|
||||||
|
(fn mk-swappable-fn [table k]
|
||||||
|
(fn [...] ((. table k) ...)))
|
||||||
|
|
||||||
|
(fn swappable [table]
|
||||||
|
(local s {})
|
||||||
|
(each [k v (pairs table)]
|
||||||
|
(if (= (type v) :function)
|
||||||
|
(tset s k (mk-swappable-fn table k))
|
||||||
|
(tset s k v)))
|
||||||
|
s)
|
||||||
|
|
||||||
|
(fn swappable-require [modname]
|
||||||
|
(swappable (require modname)))
|
||||||
|
|
||||||
|
{: lo : hi : int8-to-bytes : int16-to-bytes : reload : hotswap : swappable :require swappable-require}
|
||||||
|
|
||||||
|
|
|
||||||
337
vm.fnl
Normal file
337
vm.fnl
Normal file
|
|
@ -0,0 +1,337 @@
|
||||||
|
(local lume (require "lume"))
|
||||||
|
(local {: lo : hi} (require "util"))
|
||||||
|
|
||||||
|
(fn inc16-stk [l h]
|
||||||
|
[:block
|
||||||
|
[:inc l :x]
|
||||||
|
[:bne :done]
|
||||||
|
[:inc h :x]
|
||||||
|
:done])
|
||||||
|
|
||||||
|
(fn inc16 [l h]
|
||||||
|
[:block
|
||||||
|
[:inc l]
|
||||||
|
[:bne :done]
|
||||||
|
[:inc h]
|
||||||
|
:done
|
||||||
|
])
|
||||||
|
|
||||||
|
(fn dec16 [l h]
|
||||||
|
[:block
|
||||||
|
[:lda l]
|
||||||
|
[:bne :declow]
|
||||||
|
[:dec h]
|
||||||
|
:declow
|
||||||
|
[:dec l]])
|
||||||
|
|
||||||
|
(fn add16 [l h]
|
||||||
|
[:block
|
||||||
|
[:clc]
|
||||||
|
[:adc l]
|
||||||
|
[:sta l]
|
||||||
|
[:bcc :go]
|
||||||
|
[:inc h]
|
||||||
|
:go
|
||||||
|
])
|
||||||
|
|
||||||
|
(fn mk-vm [prg options]
|
||||||
|
(local code1 (prg:org 0xc00))
|
||||||
|
|
||||||
|
(fn prg.dat-parser.vm [bytecodes]
|
||||||
|
(local block (prg:new-block))
|
||||||
|
(each [_ bytecode (ipairs (lume.slice bytecodes 2))]
|
||||||
|
(if
|
||||||
|
(= (type bytecode) :number)
|
||||||
|
(prg:parse-dats block [[:ref :lit] [:dw bytecode]])
|
||||||
|
|
||||||
|
(= (type bytecode) :string)
|
||||||
|
(prg:parse-dats block [[:ref bytecode]])
|
||||||
|
|
||||||
|
(= (type bytecode) :table)
|
||||||
|
(prg:parse-dats block [bytecode])
|
||||||
|
|
||||||
|
(error (.. "VM can't parse " (fv bytecode)))))
|
||||||
|
block)
|
||||||
|
(local vm {
|
||||||
|
:IP :0x60
|
||||||
|
:IPH :0x61
|
||||||
|
:W :0x62
|
||||||
|
:WH :0x63
|
||||||
|
:ROFF :0x64
|
||||||
|
:TOP :0x80
|
||||||
|
:TOPH :0x81
|
||||||
|
:ST1 :0x7e
|
||||||
|
:ST1H :0x7f
|
||||||
|
:ST2 :0x7c
|
||||||
|
:ST2H :0x7d
|
||||||
|
:RSTACK :0x6000
|
||||||
|
:code code1
|
||||||
|
: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 (self:reserve)
|
||||||
|
[:lda l]
|
||||||
|
[:sta self.TOP :x]
|
||||||
|
[:lda h]
|
||||||
|
[:sta self.TOPH :x]
|
||||||
|
])
|
||||||
|
:drop (fn [self] [:block [:dex] [:dex]])
|
||||||
|
:def
|
||||||
|
(fn [self name ...]
|
||||||
|
(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]])
|
||||||
|
})
|
||||||
|
|
||||||
|
(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 :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 :<rot ; (a b c -- b c a)
|
||||||
|
[:lda vm.TOP :x] ; a: c (a b c)
|
||||||
|
[:ldy vm.ST1 :x] ; y: b (a b c)
|
||||||
|
[:sta vm.ST1 :x] ; a: c (a c c)
|
||||||
|
[:lda vm.ST2 :x] ; a: a (a c c)
|
||||||
|
[:sta vm.TOP :x] ; a: a (a c a)
|
||||||
|
[:sty vm.ST2 :x] ; y: b (b c a)
|
||||||
|
[:lda vm.TOPH :x] ; a: c (a b c)
|
||||||
|
[:ldy vm.ST1H :x] ; y: b (a b c)
|
||||||
|
[:sta vm.ST1H :x] ; a: c (a c c)
|
||||||
|
[:lda vm.ST2H :x] ; a: a (a c c)
|
||||||
|
[:sta vm.TOPH :x] ; a: a (a c a)
|
||||||
|
[:sty vm.ST2H :x] ; y: b (b c a)
|
||||||
|
)
|
||||||
|
|
||||||
|
(vm:def :get
|
||||||
|
[:lda [vm.TOP :x]]
|
||||||
|
[:tay]
|
||||||
|
(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
|
||||||
|
(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] :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}
|
||||||
10
wrap.fnl
10
wrap.fnl
|
|
@ -1,5 +1,5 @@
|
||||||
(require "lite")
|
(require "lite")
|
||||||
(require "util")
|
(local util (require "util"))
|
||||||
(local lume (require "lume"))
|
(local lume (require "lume"))
|
||||||
(local imgui (require "imgui"))
|
(local imgui (require "imgui"))
|
||||||
(local serial (require "serial"))
|
(local serial (require "serial"))
|
||||||
|
|
@ -19,12 +19,12 @@
|
||||||
})
|
})
|
||||||
(command.add #(machine:connected?) {
|
(command.add #(machine:connected?) {
|
||||||
"honeylisp:upload" (fn []
|
"honeylisp:upload" (fn []
|
||||||
(local p (reload "test"))
|
(local p (util.reload "neut"))
|
||||||
(p:upload machine)
|
(p:upload machine)
|
||||||
(core.log (string.format "%x" (p:lookup-addr p.start-symbol))))
|
(core.log (string.format "%x" (p:lookup-addr p.start-symbol))))
|
||||||
})
|
})
|
||||||
(command.add (fn [] true) {
|
(command.add (fn [] true) {
|
||||||
"honeylisp:rebuild" #(reload "test")
|
"honeylisp:rebuild" #(util.reload "neut")
|
||||||
})
|
})
|
||||||
|
|
||||||
(fn selected-symbol []
|
(fn selected-symbol []
|
||||||
|
|
@ -52,11 +52,11 @@
|
||||||
(: :gsub "^data%." "")
|
(: :gsub "^data%." "")
|
||||||
(: :gsub "%.init$" "")))
|
(: :gsub "%.init$" "")))
|
||||||
(core.log (.. "Hotswapping " modname))
|
(core.log (.. "Hotswapping " modname))
|
||||||
(local (mod err) (lume.hotswap modname))
|
(local (mod err) (util.hotswap modname))
|
||||||
(when (not= err nil) (print err) (error err)))
|
(when (not= err nil) (print err) (error err)))
|
||||||
"honeylisp:address" (fn []
|
"honeylisp:address" (fn []
|
||||||
(local word (selected-symbol))
|
(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)))
|
(core.log (string.format "%s %x" word (or (p:lookup-addr word) -1)))
|
||||||
)
|
)
|
||||||
})
|
})
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue