Working Forthy example!

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)
+        (table.insert block.pdats pdat))))
-        (set index (+ index 1)))))
   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)))
+              (int8-to-bytes (- (env:lookup-addr op.arg) (+ op.addr 2)))
-            (= (size op.mode) 2) (int8-to-bytes (env:lookup-addr op.arg env))
+            (= (size op.mode) 2) (int8-to-bytes (env:lookup-addr op.arg))
-            (= (size op.mode) 3) (int16-to-bytes (env:lookup-addr op.arg env))
+            (= (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 pdat-processor.ref.bytes [ref env]
-(fn process-pdat [pdat process default ...]
+  (int16-to-bytes (env:lookup-addr ref.target)))
-  (local processor (. pdat-processor pdat.type process))
-  (if processor (processor pdat ...) default))
 
 (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}
+

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
+(fn dat-parser.vm [bytecodes]
-;   :start
+  (local block (new-block))
-;     [:dex]
+  (each [_ bytecode (ipairs (lume.slice bytecodes 2))]
-;     [:txa]
+    (if
-;     [:jsr :0xfded]
+      (= (type bytecode) :number)
-;     [:jmp :start])
+      (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
+  :IP   :0x60
-  :IPH  :0x41
+  :IPH  :0x61
-  :W    :0x42
+  :W    :0x62
-  :WH   :0x43
+  :WH   :0x63
-  :ROFF :0x44
+  :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]
+  [:ldy 0]
-  [:lda vm.IPH] [:sta vm.WH]
+  [:lda [vm.IP] :y]  [:sta vm.W]
-  [:lda 2] (add16 vm.IP vm.IPH)
+  (inc16 vm.IP vm.IPH)
+  [:lda [vm.IP] :y] [:sta vm.WH]
+  (inc16 vm.IP vm.IPH)
   [:jmp [vm.W]])
 
-(vm:def
+(code1:append :reset
-  [:pla] [:sta vm.IP] [:pla] [:sta vm.IPH]
+  [:lda #(lo ($1:lookup-addr :quit))]
-  (inc16 vm.IP vm.IPH))
+  [: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.IP] :y] [:sta vm.TOP :x]
-  [:lda [vm.IPH] :y] [:sta [vm.TOP :x]]
+  (inc16 vm.IP vm.IPH)
-  [:lda 2] (add16 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