From bae9bdf768ac46ada88bbab920ff81dea557abfd Mon Sep 17 00:00:00 2001 From: Jeremy Penner Date: Sun, 20 Sep 2020 21:39:17 -0400 Subject: [PATCH] Working Forthy example! --- asm.fnl | 50 ++++++++++++++++++++----------- test.fnl | 91 ++++++++++++++++++++++++++++++++++++++++++-------------- 2 files changed, 100 insertions(+), 41 deletions(-) diff --git a/asm.fnl b/asm.fnl index b08d4c5..2fed658 100644 --- a/asm.fnl +++ b/asm.fnl @@ -77,7 +77,7 @@ (fn parse-mode-arg [op] (match op [_ :a] [:a nil] - ([_ imm] ? (= (type imm) "number")) [:imm imm] + ([_ imm] ? (or (= (type imm) "number") (= (type imm) "function"))) [:imm imm] ([opcode addr] ? (and (= (type addr) "string") (= (opcode:sub 1 1) "b"))) [:rel addr] ; branch [_ addr :x] [:addr-x addr] [_ [addr] :y] [:zp*-y addr] @@ -92,20 +92,20 @@ ; 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] - (var index (+ (length block.pdats) 1)) (each [_ dat (ipairs dats)] (if (= (type dat) "string") - (tset block.symbols dat index) + (tset block.symbols dat (+ (length block.pdats) 1)) (let [opcode (. dat 1) parser (. dat-parser opcode) pdat (if - parser (parser dat) + parser (parser dat block) (. opcodes opcode) (dat-parser.op dat) (error (.. "Unrecognized opcode " (fv opcode))))] - (table.insert block.pdats pdat) - (set index (+ index 1))))) + (table.insert block.pdats pdat)))) block) (fn dat-parser.op [op] @@ -115,11 +115,14 @@ (fn dat-parser.block [block] (let [dats (table.clone block)] (table.remove dats 1) - (parse-dats {:type :block :pdats [] :symbols {}} dats))) + (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}) +(fn dat-parser.ref [ref] {:type :ref :target (. ref 2)}) +(fn dat-parser.flatten [flat block] + (parse-dats block (lume.slice flat 2))) (fn make-env [block parent] {:parent parent @@ -137,18 +140,26 @@ (self.parent:lookup-addr name)))}) + +(fn lo [v] (bit.band v 0xff)) +(fn hi [v] (bit.band (bit.rshift v 8) 0xff)) (fn int8-to-bytes [i] - (string.char (bit.band i 0xff))) + (string.char (lo i))) (fn int16-to-bytes [i] - (string.char (bit.band i 0xff) (bit.band (bit.rshift i 8) 0xff))) + (string.char (lo i) (hi i))) (local pdat-processor { :op {} :var {} + :ref {} :raw {} :block {} }) +(fn process-pdat [pdat process default ...] + (local processor (. pdat-processor pdat.type process)) + (if processor (processor pdat ...) default)) + (fn pdat-processor.op.patch [op env] (when (and op.mode (= (op.mode:sub 1 4) :addr)) (let [zp-mode (.. :zp (op.mode:sub 5)) @@ -159,6 +170,7 @@ (fn pdat-processor.raw.size [raw] (length raw.bytes)) (fn pdat-processor.op.size [op] (size op.mode)) (fn pdat-processor.var.size [d] d.size) +(fn pdat-processor.ref.size [r] 2) (fn pdat-processor.op.bytes [op env] (local bytegen (. opcodes op.opcode)) @@ -167,11 +179,14 @@ (let [opbyte (bytegen op.mode) argbytes (if + (and (= op.mode :imm) (= (type op.arg) "function")) + (int8-to-bytes (op.arg env)) + (= op.mode :imm) (int8-to-bytes op.arg) (= op.mode :rel) - (int8-to-bytes (- (env:lookup-addr op.arg env) (+ op.addr 2))) - (= (size op.mode) 2) (int8-to-bytes (env:lookup-addr op.arg env)) - (= (size op.mode) 3) (int16-to-bytes (env:lookup-addr op.arg env)) + (int8-to-bytes (- (env:lookup-addr op.arg) (+ op.addr 2))) + (= (size op.mode) 2) (int8-to-bytes (env:lookup-addr op.arg)) + (= (size op.mode) 3) (int16-to-bytes (env:lookup-addr op.arg)) "")] (if opbyte (.. (int8-to-bytes opbyte) argbytes) @@ -182,10 +197,8 @@ 1 (int8-to-bytes (or d.init 0)) 2 (int16-to-bytes (or d.init 0)) n (string.rep "\0" n))) - -(fn process-pdat [pdat process default ...] - (local processor (. pdat-processor pdat.type process)) - (if processor (processor pdat ...) default)) +(fn pdat-processor.ref.bytes [ref env] + (int16-to-bytes (env:lookup-addr ref.target))) (fn pdat-processor.block.symbols [block] (lume.keys block.symbols)) @@ -226,7 +239,7 @@ (fn [self org] (var block (. self.org-to-block org)) (when (not block) - (set block {:type :block :pdats [] :symbols {}}) + (set block (new-block)) (tset self.org-to-block org block)) {: block :append (fn [self ...] (parse-dats self.block [...]) self)}) @@ -267,4 +280,5 @@ (machine:write org block.bytes))) }) -{: program} +{: program : dat-parser : pdat-processor : new-block : parse-dats : lo : hi} + diff --git a/test.fnl b/test.fnl index 221cec3..14c1a6a 100644 --- a/test.fnl +++ b/test.fnl @@ -1,23 +1,38 @@ -(local {: program} (require "asm")) +(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)) -; (prg:block :print-chars-forever 0x0c00 -; :start -; [:dex] -; [:txa] -; [:jsr :0xfded] -; [:jmp :start]) +(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 :0x40 - :IPH :0x41 - :W :0x42 - :WH :0x43 - :ROFF :0x44 + :IP :0x60 + :IPH :0x61 + :W :0x62 + :WH :0x63 + :ROFF :0x64 :TOP :0x80 - :TOPH :0x81 + :TOPH :0x81 :ST1 :0x7e :ST1H :0x7f :ST2 :0x7c @@ -40,7 +55,11 @@ :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])) }) + (fn inc16 [l h] [:block [:inc l] @@ -50,27 +69,38 @@ ]) (fn add16 [l h] [:block + [:clc] [:adc l] + [:sta 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) + [: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]]) -(vm:def - [:pla] [:sta vm.IP] [:pla] [:sta vm.IPH] - (inc16 vm.IP vm.IPH)) +(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)) @@ -147,10 +177,25 @@ (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)) + [: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 (string.byte " ") ] + [:jsr mon.putchar] + (vm:drop)) + +(code1:append :main + [:jsr :reset] + [:jsr :interpret] + [:vm 0xbabe 0xcafe :. :. :quit]) (prg:assemble) -(set prg.start-symbol :mixed-hires) + prg