bugfixes, debug tools, loops, working full map drawing routine

asm.fnl

@@ -123,12 +123,24 @@
 (fn dat-parser.bytes [bytes] {:type :raw :bytes (. bytes 2)})
 (fn dat-parser.ref [ref]     {:type :ref :target (. ref 2)})
 (fn dat-parser.flatten [flat block]
-  (parse-dats block (lume.slice flat 2)))
+  (parse-dats block (lume.slice flat 2))
+  nil)
 
 (fn make-env [block parent]
   {:parent parent
    :block block
    :is-zp? (fn [self name] (self.parent:is-zp? name))
+   :lookup-pdat
+   (fn [self name]
+     (local ipdat (. self.block.symbols name))
+     (if
+       (and ipdat (> ipdat (length self.block.pdats)))
+       nil
+
+       ipdat (. self.block.pdats ipdat)
+
+       (self.parent:lookup-pdat name)))
+
    :lookup-addr
    (fn [self name]
      (local ipdat (. self.block.symbols name))
@@ -141,7 +153,6 @@
 
        (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]
@@ -158,6 +169,7 @@
 })
 
 (fn process-pdat [pdat process default ...]
+  (pp pdat)
   (local processor (. pdat-processor pdat.type process))
   (if processor (processor pdat ...) default))
 
@@ -237,6 +249,16 @@
    :org-to-block {}
    :symbol-to-org {}
    :start-symbol :main
+   :dbg
+   (fn [self ...]
+     (when self.dbgfile
+       (for [i 1 (select :# ...)]
+         (when (not= i 1) (self.dbgfile:write " "))
+         (self.dbgfile:write (fv (select i ...))))
+       (self.dbgfile:write "\n")))
+   :debug-to
+   (fn [self filename]
+     (set self.dbgfile (io.open filename :w)))
    :org
    (fn [self org]
      (var block (. self.org-to-block org))
@@ -244,21 +266,30 @@
        (set block (new-block))
        (tset self.org-to-block org block))
      {: block
-      :append (fn [self ...] (parse-dats self.block [...]) self)})
+      : org
+      :prg self
+      :ptr (fn [self] (tostring self.org))
+      :append (fn [self ...] (self.prg:dbg self.org ...) (parse-dats self.block [...]) self)})
+   :parse-addr
+   (fn [self name]
+     (local addr (tonumber name))
+     (if addr addr (error (.. "Symbol '" name "' not found"))))
    :is-zp?
    (fn [self name]
      (local org (. self.symbol-to-org name))
-     (if (not= org nil)
+     (if org
        (< org 0x100)
-       (< (tonumber name) 0x100)))
+       (< (self:parse-addr name) 0x100)))
+   :env-lookup
+   (fn [self name lookup ...]
+     (local org (. self.symbol-to-org name))
+     (and org (: (make-env (. self.org-to-block org) self) lookup name ...)))
+;   :lookup-symbol (fn [self addr]) TODO
+   :lookup-pdat (fn [self name] (self:env-lookup name :lookup-pdat))
    :lookup-addr
    (fn [self name]
 ;       (print "looking up" name "in" self)
-      (local org (. self.symbol-to-org name))
+      (or (self:env-lookup name :lookup-addr) (self:parse-addr name)))
-      (local addr (and org (: (make-env (. self.org-to-block org) self) :lookup-addr name)))
-      (if (not= addr nil)
-        addr
-        (tonumber name)))
    :pass
    (fn [self passname]
      (each [org block (pairs self.org-to-block)]
@@ -270,12 +301,17 @@
    :patch    (fn [self org block] (process-pdat block :patch nil self))
    :allocate (fn [self org block] (process-pdat block :allocate nil org))
    :generate (fn [self org block] (process-pdat block :generate nil self))
+   :debug-pass (fn [self org block] (self:dbg org block))
    :assemble
    (fn [self]
      (self:pass :gather-symbols)
      (self:pass :patch)
      (self:pass :allocate)
-     (self:pass :generate))
+     (self:pass :debug-pass)
+     (self:pass :generate)
+     (when self.dbgfile
+       (self.dbgfile:close)
+       (set self.dbgfile nil)))
    :upload
    (fn [self machine]
      (each [org block (pairs self.org-to-block)]

test.fnl

@@ -6,6 +6,8 @@
 (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))]
@@ -17,7 +19,7 @@
       (parse-dats block [[:ref bytecode]])
 
       (= (type bytecode) :table)
-      (parse-dats block bytecode)
+      (parse-dats block [bytecode])
 
       (error (.. "VM can't parse " (fv bytecode)))))
   block)
@@ -41,13 +43,12 @@
   :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
+    [:block (self:reserve)
-      [:inx]
-      [:inx]
       [:lda l]
       [:sta self.TOP :x]
       [:lda h]
@@ -56,14 +57,17 @@
   :drop (fn [self] [:block [:dex] [:dex]])
   :def
   (fn [self name ...]
-    (code1:append name (table.unpack (lume.concat [...] [(self:ret)]))))
+    (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
@@ -72,6 +76,14 @@
     [:inc h]
    :done
   ])
+(fn dec16 [l h]
+  [:block
+    [:lda l]
+    [:bne :declow]
+    [:dec h]
+   :declow
+    [:dec l]])
+
 (fn add16 [l h]
   [:block
     [:clc]
@@ -81,6 +93,13 @@
     [: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)]
@@ -93,6 +112,14 @@
   (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
@@ -132,15 +159,15 @@
   [:sty vm.ROFF]
   [:jmp [vm.W]])
 
-(vm:def :mixed-hires
+  (vm:def :mixed-hires
   [:sta :0xc050]
   [:sta :0xc057]
-  [:sta :0xc053])
+  [:sta :0xc052])
 
 (vm:def :drop (vm:drop))
 
 (vm:def :dup
-  [:inx] [:inx]
+  (vm:reserve)
   [:lda vm.ST1H :x]
   [:sta vm.TOPH :x]
   [:lda vm.ST1 :x]
@@ -157,7 +184,7 @@
   [:sta vm.ST1H :x])
 
 (vm:def :over
-  [:inx] [:inx]
+  (vm:reserve)
   [:lda vm.ST2H :x]
   [:sta vm.TOPH :x]
   [:lda vm.ST2 :x]
@@ -196,18 +223,133 @@
 (vm:def :get
   [:lda [vm.TOP :x]]
   [:tay]
-  (inc16 vm.TOP vm.TOPH)
+  (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
-  [:inx] [:inx] [:ldy 0]
+  (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]
@@ -217,6 +359,15 @@
   [: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
@@ -274,8 +425,7 @@
   [:sbc 0x7f]
   [:sta vm.ST1 :x]
   (draw-vertical-block)
-  (vm:drop) (vm:drop)
+  (vm:drop) (vm:drop))
-  )
 
 (vm:def :cleargfx
   (vm:push 0x4000)
@@ -291,20 +441,37 @@
     [:bne :page]]
   (vm:drop))
 
-(tiles:append :blanktile [:bytes "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"])
+(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
+    :cleargfx :drawmap
-    0x0000 :tile>screen :lit :testtile :drawtile
-    0x0200 :tile>screen :lit :testtile :drawtile
-    0x0002 :tile>screen :lit :testtile :drawtile
-    0x0202 :tile>screen :lit :testtile :drawtile
-    0x0606 :tile>screen :lit :testtile :drawtile
-    0x0913 :tile>screen :lit :testtile :drawtile
     :quit])
 
 (prg:assemble)

wrap.fnl

@@ -26,6 +26,15 @@
 (command.add (fn [] true) {
   "honeylisp:rebuild" #(reload "test")
 })
+
+(fn selected-symbol []
+  (local ldoc core.active_view.doc)
+  (var (aline acol bline bcol) (ldoc:get_selection))
+  (when (and (= aline bline) (= acol bcol))
+    (set (aline acol) (translate.start_of_word ldoc aline acol))
+    (set (bline bcol) (translate.end_of_word ldoc bline bcol)))
+  (ldoc:get_text aline acol bline bcol))
+
 (command.add "core.docview" {
   "fennel:eval" (fn []
     (let [ldoc core.active_view.doc
@@ -46,10 +55,7 @@
     (local (mod err) (lume.hotswap modname))
     (when (not= err nil) (print err) (error err)))
   "honeylisp:address" (fn []
-    (local ldoc core.active_view.doc)
+    (local word (selected-symbol))
-    (local (aline acol) (translate.start_of_word ldoc (ldoc:get_selection)))
-    (local (bline bcol) (translate.end_of_word ldoc (ldoc:get_selection)))
-    (local word (ldoc:get_text aline acol bline bcol))
     (local p (require "test"))
     (core.log (string.format "%s %x" word (or (p:lookup-addr word) -1)))
   )
@@ -57,6 +63,7 @@
 (keymap.add {
   "alt+e" "fennel:eval"
   "alt+r" "lume:hotswap"
+  "alt+a" "honeylisp:address"
 })
 
 (fn love.load [])