honeylisp/test.fnl

313 lines
6.9 KiB
Fennel

(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))
(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])
:push
(fn [self v]
(local l (bit.band v 0xff))
(local h (bit.band (bit.rshift v 8) 0xff))
[:block
[:inx]
[:inx]
[: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 (table.unpack (lume.concat [...] [(self:ret)]))))
:word
(fn [self name ...]
(code1:append name [:jsr :subroutine] [:vm ...] [:vm :ret]))
:inline
(fn [self ...]
[:block [:jsr :subroutine] [:vm ...] [:vm :restore]])
})
(fn inc16 [l h]
[:block
[:inc l]
[:bne :done]
[:inc h]
:done
])
(fn add16 [l h]
[:block
[:clc]
[:adc l]
[:sta l]
[:bcc :go]
[:inc h]
:go
])
(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)
[: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 :0xc053])
(vm:def :drop (vm:drop))
(vm:def :dup
[:inx] [:inx]
[: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
[:inx] [:inx]
[: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 vm.TOP vm.TOPH)
[:lda [vm.TOP :x]]
[:sta vm.TOPH :x]
[:sty vm.TOP :x])
(vm:def :lit
[:inx] [:inx] [: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 :.
[:lda vm.TOPH :x]
[:jsr mon.hexout]
[:lda vm.TOP :x]
[:jsr mon.hexout]
[:lda (achar " ")]
[:jsr mon.putchar]
(vm: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))
(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"])
(tiles:append :testtile [:bytes "12345678901234567890123456789012"])
;; 19x11 means full map is 209 bytes
(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
:quit])
(prg:assemble)
prg