(local lume (require "lib.lume")) (local {: lo : hi} (require "lib.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 :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}