honeylisp/test.fnl

(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