honeylisp/test.fnl

(local {: program} (require "asm"))
(local {: stream : kvstream : one} (require "stream"))

(local prg (program))
(local code1 (prg:org 0xc00))

; (prg:block :print-chars-forever 0x0c00
;   :start
;     [:dex]
;     [:txa]
;     [:jsr :0xfded]
;     [:jmp :start])
(local vm {
  :IP   :0x40
  :IPH  :0x41
  :W    :0x42
  :WH   :0x43
  :ROFF :0x44
  :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)]))))
  })
(fn inc16 [l h]
  [:block
    [:inc l]
    [:bne :done]
    [:inc h]
   :done
  ])
(fn add16 [l h]
  [:block
    [:adc l]
    [:bcc :go]
    [:inc h]
    :go
  ])

(code1:append :next
  [:lda vm.IP]  [:sta vm.W]
  [:lda vm.IPH] [:sta vm.WH]
  [:lda 2] (add16 vm.IP vm.IPH)
  [:jmp [vm.W]])

(vm:def
  [:pla] [:sta vm.IP] [:pla] [:sta vm.IPH]
  (inc16 vm.IP vm.IPH))

(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]
 :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])

(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 :>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.ST1 :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.ST1H :x] ; y: b (b c a)
)

(vm:def "@"
  [: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]]
  [:lda [vm.IPH] :y] [:sta [vm.TOP :x]]
  [:lda 2] (add16 vm.IP vm.IPH))

(prg:assemble)
(set prg.start-symbol :mixed-hires)
prg