Tile-drawing routines, serial / monitor support

asm.fnl

@@ -1,3 +1,4 @@
+(local lume (require "lume"))
 (local {: stream : kvstream : one} (require "stream"))
 
 (local opcodes {})
@@ -119,7 +120,7 @@
 
 (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.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)))
@@ -131,7 +132,7 @@
    :lookup-addr
    (fn [self name]
      (local ipdat (. self.block.symbols name))
-     (print "looking up" name "in" self)
+;      (print "looking up" name "in" self)
      (if
        (and ipdat (> ipdat (length self.block.pdats)))
        (+ self.block.addr self.block.size)
@@ -174,7 +175,7 @@
 
 (fn pdat-processor.op.bytes [op env]
   (local bytegen (. opcodes op.opcode))
-  (pp op)
+;   (pp op)
   (if bytegen
     (let [opbyte (bytegen op.mode)
           argbytes
@@ -226,6 +227,7 @@
   (each [_ pdat (ipairs block.pdats)]
     (process-pdat pdat :generate nil block-env)
     (local pdatbytes (process-pdat pdat :bytes pdat.bytes block-env))
+    (assert (= (type pdatbytes) :string) (.. "failed to generate bytes: " (fv pdat)))
     (set pdat.bytes pdatbytes)
     (set bytes (.. bytes pdatbytes)))
   (set block.bytes bytes))
@@ -251,7 +253,7 @@
        (< (tonumber name) 0x100)))
    :lookup-addr
    (fn [self name]
-      (print "looking up" name "in" self)
+;       (print "looking up" name "in" self)
       (local org (. self.symbol-to-org name))
       (local addr (and org (: (make-env (. self.org-to-block org) self) :lookup-addr name)))
       (if (not= addr nil)

machine.fnl

@@ -39,6 +39,7 @@
    (when self.socket
      (self.socket:close)
      (set self.socket nil)))
+ :connected? (fn [self] self.socket)
  :cmd (fn [self cmd] (self.socket:send (.. cmd "\n")))
  :response
  (fn [self]

main.lua

@@ -4,6 +4,7 @@ table.insert(package.loaders, fennel.make_searcher({correlate=true}))
 fv = require("lib.fennelview")
 pp = function(x) print(fv(x)) end
 lume = require("lume")
+luars232 = require("luars232")
 
 function reload(modname)
 	package.loaded[modname] = nil

serial.fnl

@@ -0,0 +1,55 @@
+; using https://github.com/srdgame/librs232
+(local rs232 (require :luars232))
+(local command (require "core.command"))
+
+(fn check [err ...]
+  (when (not= err rs232.RS232_ERR_NOERROR) (error (rs232.error_tostring err)))
+  ...)
+
+(fn open []
+  (local port (check (rs232.open "/dev/ttyUSB0")))
+  (port:set_baud_rate rs232.RS232_BAUD_9600)
+  (port:set_data_bits rs232.RS232_DATA_8)
+  (port:set_parity rs232.RS232_PARITY_NONE)
+  (port:set_stop_bits rs232.RS232_STOP_1)
+  (port:set_flow_control rs232.RS232_FLOW_HW)
+  port)
+
+(local machine
+{:connect
+ (fn [self]
+   (when (not self.port)
+     (set self.port (open))))
+ :disconnect
+ (fn [self]
+   (when self.port
+     (check (self.port:close))
+     (set self.port nil)))
+ :connected? (fn [self] self.port)
+ :cmd
+ (fn [self cmd]
+   (check (self.port:write (.. cmd "\r"))
+   (love.timer.sleep 0.08)))
+ :write
+ (fn [self addr bytes]
+   (var bytes-to-write bytes)
+   (var addrout addr)
+   (while (> (length bytes-to-write) 0)
+     (local bytesout (bytes-to-write:sub 1 10))
+     (local hexbytes (bytesout:gsub "." (fn [c] (string.format "%02X " (string.byte c)))))
+     (self:cmd (.. (string.format "%04X:" addrout) hexbytes))
+     (set bytes-to-write (bytes-to-write:sub 11))
+     (set addrout (+ addrout 10))))
+ :monitor (fn [self] (self:cmd "CALL-151"))
+})
+
+(command.add #(not (machine:connected?)) {
+  "serial:connect" #(machine:connect)
+})
+
+(command.add #(machine:connected?) {
+  "serial:disconnect" #(machine:disconnect)
+  "serial:start-monitor" #(machine:monitor)
+})
+
+machine

test.fnl

@@ -1,8 +1,10 @@
+(local lume (require "lume"))
 (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))
+(local tiles (prg:org 0x6100))
 
 (fn dat-parser.vm [bytecodes]
   (local block (new-block))
@@ -47,9 +49,9 @@
       [:inx]
       [:inx]
       [:lda l]
-      [:sta [self.TOP :x]]
+      [:sta self.TOP :x]
       [:lda h]
-      [:sta [self.TOPH :x]]
+      [:sta self.TOPH :x]
     ])
   :drop (fn [self] [:block [:dex] [:dex]])
   :def
@@ -58,6 +60,9 @@
   :word
   (fn [self name ...]
     (code1:append name [:jsr :subroutine] [:vm ...] [:vm :ret]))
+  :inline
+  (fn [self ...]
+    [:block [:jsr :subroutine] [:vm ...] [:vm :restore]])
   })
 
 (fn inc16 [l h]
@@ -76,6 +81,11 @@
     [:inc h]
     :go
   ])
+(fn achar [c] (bit.bor (string.byte c) 0x80))
+(fn astr [s]
+  (-> [(string.byte s 1 -1)]
+    (lume.map #(bit.bor $1 0x80))
+    (-> (table.unpack) (string.char))))
 
 (code1:append :next
   [:ldy 0]
@@ -113,6 +123,14 @@
 
 (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 :mixed-hires
   [:sta :0xc050]
@@ -138,6 +156,14 @@
   [:sty vm.TOPH :x]
   [:sta vm.ST1H :x])
 
+(vm:def :over
+  [:inx] [:inx]
+  [: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)
@@ -158,16 +184,16 @@
   [: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)
+  [:sty vm.ST2 :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)
+  [:sty vm.ST2H :x] ; y: b (b c a)
 )
 
-(vm:def "@"
+(vm:def :get
   [:lda [vm.TOP :x]]
   [:tay]
   (inc16 vm.TOP vm.TOPH)
@@ -187,14 +213,99 @@
   [:jsr mon.hexout]
   [:lda vm.TOP :x]
   [:jsr mon.hexout]
-  [:lda (string.byte " ")  ]
+  [:lda (achar " ")]
   [:jsr mon.putchar]
   (vm:drop))
 
+; starting address:
+; 0x2000 + (x*2) + (y%4 * 0x100) + ((y/4) * 0x28)
+; x between 0-19
+; y between 0-12
+; yx - 16-bit value, low byte x, high byte y
+(code1:append :screeny-lookup [:bytes "\0\040\080"])
+(vm:def :tile>screen ; yx -- p
+  [:lda vm.TOPH :x]         ; a=y
+  [:lsr :a] [:lsr :a]       ; a=y/4
+  [:tay]                    ; y=y/4
+  [:lda 0x03]
+  [:and vm.TOPH :x]         ; a=y%4
+  [:ora 0x20]               ; a=0x20 + y%4
+  [:sta vm.TOPH :x]         ; high byte is set (and y is wiped)
+  [:lda vm.TOP :x]          ; a=x
+  [:asl :a]                 ; a = x*2
+  [:clc]
+  [:adc :screeny-lookup :y] ; a=x*2 + (y/4)*0x28
+  [:sta vm.TOP :x]          ; low byte is set
+)
+
+; note: the graphical tile data must not cross a page boundary!
+; TODO: add support to the assembler for enforcing that
+(fn draw-block []
+  [:block
+    [:clc]
+    [:ldy 8]
+    :loop
+    [:lda [vm.TOP :x]]
+    [:sta [vm.ST1 :x]]
+    [:inc vm.TOP :x]
+    [:lda vm.ST1H :x]
+    [:adc 4]
+    [:sta vm.ST1H :x]
+    [:dey]
+    [:bne :loop]])
+
+(fn draw-vertical-block []
+  [:block
+    (draw-block)
+    [:lda vm.ST1H :x]
+    [:sbc 31] ; with carry clear this is 32
+    [:sta vm.ST1H :x]
+    [:lda vm.ST1 :x]
+    [:ora 0x80]
+    [:sta vm.ST1 :x]
+    (draw-block)])
+
+(vm:def :drawtile ; p gfx --
+  (draw-vertical-block)
+  [:lda vm.ST1H :x]
+  [:sbc 31]
+  [:sta vm.ST1H :x]
+  [:lda vm.ST1 :x]
+  [:sbc 0x7f]
+  [:sta vm.ST1 :x]
+  (draw-vertical-block)
+  (vm:drop) (vm:drop)
+  )
+
+(vm:def :cleargfx
+  (vm:push 0x4000)
+  [:block :page
+    [:dec vm.TOPH :x]
+    [:lda 0]
+    [:block :start
+      [:sta [vm.TOP :x]]
+      [:inc vm.TOP :x]
+      [:bne :start]]
+    [:lda vm.TOPH :x]
+    [:cmp 0x20]
+    [: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"])
+(tiles:append :testtile [:bytes "12345678901234567890123456789012"])
+;; 19x11 means full map is 209 bytes
 (code1:append :main
   [:jsr :reset]
   [:jsr :interpret]
-  [:vm 0xbabe 0xcafe :. :. :quit])
+  [:vm :mixed-hires
+    :cleargfx
+    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

@@ -1,17 +1,31 @@
 (require "lite")
 (require "util")
+(local lume (require "lume"))
 (local imgui (require "imgui"))
-(local machine (require "machine"))
+(local serial (require "serial"))
+(local gsplus (require "machine"))
 (local core (require "core"))
 (local command (require "core.command"))
 (local keymap (require "core.keymap"))
+(local translate (require "core.doc.translate"))
 
-(fn upload [] (: (reload "test") :upload machine))
+(var machine (if (and (pcall #(serial:connect)) (serial:connected?)) serial gsplus))
 
-(command.add (fn [] machine.socket) {
+(command.add #(not= machine serial) {
-  "honeylisp:upload" upload
+  "serial:switch-machine" #(set machine serial)
+})
+(command.add #(not= machine gsplus) {
+  "gsplus:switch-machine" #(set machine gsplus)
+})
+(command.add #(machine:connected?) {
+  "honeylisp:upload" (fn []
+    (local p (reload "test"))
+    (p:upload machine)
+    (core.log (string.format "%x" (p:lookup-addr p.start-symbol))))
+})
+(command.add (fn [] true) {
+  "honeylisp:rebuild" #(reload "test")
 })
-
 (command.add "core.docview" {
   "fennel:eval" (fn []
     (let [ldoc core.active_view.doc
@@ -31,6 +45,14 @@
     (core.log (.. "Hotswapping " modname))
     (local (mod err) (lume.hotswap modname))
     (when (not= err nil) (print err) (error err)))
+  "honeylisp:address" (fn []
+    (local ldoc core.active_view.doc)
+    (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)))
+  )
 })
 (keymap.add {
   "alt+e" "fennel:eval"