First vaguely working hot code reload, allow programs to depend on each other, draw coloured tiles in editor

asm/asm.fnl

@@ -92,17 +92,6 @@
   {: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))
@@ -115,7 +104,7 @@
 
        (self.parent:lookup-addr name)))})
 
-(fn program []
+(fn program [prg-base]
   ; dat - anything that takes up space in the assembled output (op, dw, db, etc)
   ;   takes the form [:op args]
   ; pdat - a parsed dat; takes the form {:type type :addr addr ...}
@@ -214,15 +203,16 @@
     (each [_ pdat (ipairs block.pdats)]
       (process-pdat pdat :patch nil block-env)))
 
-  (fn pdat-processor.block.allocate [block addr]
+  (fn pdat-processor.block.allocate [block addr base-org]
     (var size 0)
-    (set block.addr addr)
+    (local baseaddr (if base-org (+ base-org.addr base-org.size) addr))
+    (set block.addr baseaddr)
     (each [_ pdat (ipairs block.pdats)]
-      (set pdat.addr (+ addr size))
+      (set pdat.addr (+ baseaddr size))
       (process-pdat pdat :allocate nil pdat.addr)
       (local pdatsize (process-pdat pdat :size pdat.size))
       (set pdat.size pdatsize)
-      (set pdat.addr (+ addr size))
+      (set pdat.addr (+ baseaddr size))
       (set size (+ size pdatsize)))
     (set block.size size))
 
@@ -244,6 +234,7 @@
    : dat-parser
    : pdat-processor
    : new-block
+   : prg-base
    :parse-dats (fn [self block dats] (parse-dats block dats))
    :dbg
    (fn [self ...]
@@ -273,15 +264,16 @@
    :is-zp?
    (fn [self name]
      (local org (. self.symbol-to-org name))
-     (if org
+     (if org (< org 0x100)
-       (< org 0x100)
+         self.prg-base (self.prg-base:is-zp? name)
        (< (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 ...)))
+     (if org (: (make-env (. self.org-to-block org) self) lookup name ...)
+         self.prg-base (self.prg-base:env-lookup name lookup ...)
+         nil))
 ;   :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)
@@ -289,13 +281,13 @@
    :pass
    (fn [self passname]
      (each [org block (pairs self.org-to-block)]
-       (: self passname org block)))
+       (: self passname org block (if self.prg-base (. self.prg-base.org-to-block org) nil))))
    :gather-symbols
    (fn [self org block]
      (each [_ name (ipairs (process-pdat block :symbols []))]
        (tset self.symbol-to-org name org)))
    :patch    (fn [self org block] (process-pdat block :patch nil self))
-   :allocate (fn [self org block] (process-pdat block :allocate nil org))
+   :allocate (fn [self org block base-org] (process-pdat block :allocate nil org base-org))
    :generate (fn [self org block] (process-pdat block :generate nil self))
    :debug-pass (fn [self org block] (self:dbg org block))
    :assemble
@@ -310,9 +302,10 @@
        (set self.dbgfile nil))
      self)
    :upload
-   (fn [self machine]
+   (fn [self machine only-self]
+     (when (and (not only-self) self.prg-base) (self.prg-base:upload machine))
      (each [org block (pairs self.org-to-block)]
-       (machine:write org block.bytes)))
+       (machine:write block.addr block.bytes)))
   })
 
 {:new program}

asm/vm.fnl

@@ -285,6 +285,9 @@
   (fn vm.until [self ...]
     [:block :start [:vm ...] [:ref :bz] [:ref :start]])
 
+  (fn vm.forever [self ...]
+    [:block :start [:vm ...] [:vm :jmp :start]])
+    
   (fn vm.for [self ...]
     [:vm :>r (vm:while [:rtop] :r> :dec :>r ...) :rdrop])
 

editor/tiledraw.fnl

@@ -0,0 +1,59 @@
+(fn pal-from-bit [bit]
+  (if bit
+    (values [20 207 253] [255 106 60])
+    (values [255 68 253] [20 245 60])))
+
+(fn pal-from-byte [byte]
+  (pal-from-bit (not= 0 (bit.band byte 0x80))))
+
+(fn putpixel [x y color]
+  (when color
+    (love.graphics.setColor (/ (. color 1) 255) (/ (. color 2) 255) (/ (. color 3) 255))
+    (love.graphics.points (+ x 0.5) (+ y 0.5))))
+
+(fn tile-to-sprite [tile]
+  (local canvas (love.graphics.newCanvas 14 16))
+  (canvas:setFilter :nearest :nearest)
+  (local scissor [(love.graphics.getScissor)])
+  (love.graphics.setScissor)
+  (love.graphics.setCanvas canvas)
+  (love.graphics.clear 0 0 0)
+  (for [y 0 15]
+    (local byte1 (string.byte (tile:sub (+ y 1) (+ y 1))))
+    (local byte2 (string.byte (tile:sub (+ y 17) (+ y 17))))
+    (local pal1 [(pal-from-byte byte1)])
+    (local pal2 [(pal-from-byte byte2)])
+    (var prevstate :off)
+    (var state :off)
+    (for [x 0 13]
+      (local byte (if (< x 7) byte1 byte2))
+      (local bitx (if (< x 7) x (- x 7)))
+      (local bit  (not= 0 (bit.band byte (bit.lshift 1 bitx))))
+      (local prevpal (if (< x 8) pal1 pal2))
+      (local pal     (if (< x 7) pal1 pal2))
+      (local prevart (. prevpal (+ 1 (% x 2))))
+      (local art     (. pal (+ 1 (% x 2))))
+      (set prevstate state)
+      (set state
+        (match [prevstate bit]
+          [:off false]     :off
+          [:off true]      :rising
+          [:rising false]  :falling
+          [:rising true]   :on
+          [:falling false] :off
+          [:falling true]  :rising
+          [:on true]       :on
+          [:on false]      :falling))
+      (local white [255 255 255])
+      (local (prevcolor color)
+        (match [prevstate state]
+          [_ :on]            (values white white)
+          [:off :rising]     (values nil art)
+          [:falling :rising] (values prevart art)))
+      (putpixel (- x 1) y prevcolor)
+      (putpixel x y color)))
+  (love.graphics.setCanvas)
+  (love.graphics.setScissor (table.unpack scissor))
+  canvas)
+
+{: tile-to-sprite : pal-from-bit : pal-from-byte}

editor/tileedit.fnl

@@ -2,13 +2,14 @@
 (local command (require :core.command))
 (local style (require :core.style))
 (local View (require :core.view))
-(local tile (require :game.tile))
+(local tiles (require :game.tiles))
+(local tiledraw (require :editor.tiledraw))
 (local lume (require :lib.lume))
 
 (local TileView (View:extend))
 
 (local pixel-size 24)
-
+(local sprite-scale 4)
 (local xy-to-ibit [])
 (for [x 0 15] (tset xy-to-ibit x []))
 (for [y 0 15]
@@ -43,10 +44,7 @@
     (tile:sub (+ ibyte 2))))
 
 (fn draw-bit-color [bit x y]
-  (local (bgcolor color)
+  (local (bgcolor color) (tiledraw.pal-from-bit bit))
-    (if bit
-      (values [20 207 253] [255 106 60])
-      (values [255 68 253] [20 245 60])))
   (renderer.draw_rect x y pixel-size pixel-size bgcolor)
   (renderer.draw_rect (+ x 3) (+ y 3) (- pixel-size 6) (- pixel-size 6) color))
 
@@ -63,30 +61,40 @@
 
 (fn TileView.new [self]
   (self.super.new self)
-  (set self.tiles (tile.loadtiles))
+  (set self.tiles (tiles.loadtiles))
-  (set self.itile 1))
+  (set self.itile 1)
+  (set self.tilesprites []))
 
 (fn TileView.tile [self] (or (. self.tiles self.itile) (string.rep "\0" 32)))
-(fn TileView.update-tile [self newtile] (tset self.tiles self.itile newtile))
+(fn TileView.update-tile [self newtile]
+  (tset self.tiles self.itile newtile)
+  (tset self.tilesprites self.itile nil))
 (fn TileView.set-bit [self ibyte ibit bit-set]
   (set self.ibyte ibyte)
   (set self.ibit ibit)
   (set self.bit-set bit-set)
   (self:update-tile (set-tile-bit (self:tile) ibyte ibit bit-set))
   true)
-
+(fn TileView.save [self] (tiles.savetiles self.tiles))
-(fn TileView.save [self] (tile.savetiles self.tiles))
 (fn TileView.select-rel [self ditile]
   (local itile (+ self.itile ditile))
   (when (>= itile 1) (set self.itile itile)))
 
+(fn TileView.tilesprite [self itile]
+  (when (and (= nil (. self.tilesprites itile)) (not= nil (. self.tiles itile)))
+    (tset self.tilesprites itile (tiledraw.tile-to-sprite (. self.tiles itile))))
+  (. self.tilesprites itile))
+
 (fn TileView.draw [self]
   (self:draw_background style.background)
   (local (x y) (values (+ self.position.x 10) (+ self.position.y 10)))
-  (local ybelow (draw-tile (self:tile) x y))
+  (draw-tile (self:tile) x y)
-  (local (byte bit) (map-bit (- (love.mouse.getX) x) (- (love.mouse.getY) y)))
+  (love.graphics.setColor 1 1 1 1)
-  (when (and byte bit)
+  (var tilex (+ self.position.x 10))
-    (renderer.draw_text style.font (: "%d, %d" :format byte bit) x ybelow style.text)))
+  (var tiley (+ self.position.y (* 18 (+ pixel-size 1))))
+  (each [itile _ (ipairs self.tiles)]
+    (love.graphics.draw (self:tilesprite itile) tilex tiley 0 sprite-scale sprite-scale)
+    (set tilex (+ tilex (* 16 sprite-scale)))))
 
 (fn TileView.selected-bit [self mx my]
   (local (x y) (values (+ self.position.x 10) (+ self.position.y 10)))

game/init.fnl

@@ -1,8 +1,9 @@
-(local lume (require "lib.lume"))
+(local lume (require :lib.lume))
-(local asm (require "asm.asm"))
+(local asm (require :asm.asm))
-(local VM (require "asm.vm"))
+(local VM (require :asm.vm))
-(local tile (require :game.tile))
+(local tile (require :game.tiles))
-(local {: lo : hi} (require "lib.util"))
+(local link (require :link))
+(local {: lo : hi} (require :lib.util))
 
 (local prg (asm.new))
 ; (prg:debug-to "test.dbg")
@@ -10,6 +11,7 @@
 (local tiles (prg:org 0x6100))
 (local vm (VM.new prg))
 (local code1 vm.code)
+(link.machine:stub code1 :next)
 
 (local mon {
   :hexout :0xfdda
@@ -146,17 +148,21 @@
   [:sta vm.TOP :x])
 
 (tile.appendtiles (tile.loadtiles) tiles)
-; (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"])
+; thought:
-; (tiles:append :stripetile [:bytes "zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz"])
+; hotswap-safe debug stub at root of call stack
+; but REPL debug stub should be very available as a task
 
 ; 19x11 means full map is 209 bytes
-(: (prg:org 0x6800) :append :map [:bytes (string.rep "\0\032\064" 85)])
+(: (prg:org 0x6800) :append :map [:bytes (string.rep "\0\032\064\096\128\160\192\224\001\033\065\097\129\161\193" 17)])
 (code1:append :main
   [:jsr :reset]
   [:jsr :interpret]
-  [:vm :hires; :mixed
+  [:vm :hires ; :mixed
-    :cleargfx :drawmap
+    :cleargfx
+    (vm:forever
+     :debug-stub :drawmap
+    )
 ;    0x0000 :tile>screen 0 :lookup-tile :drawtile
     :quit])
 

game/tiles.json

@@ -1 +1 @@
-["000000020A0820202A2020080A02000000010141511105045404051151410100","808080C0C0C0E0C0D0C8C04040404080808083858585828A9282820A08081980","007C0C0C0C0C7C007C7E7EAA88888800001F181818181F001F0F979590909000"]
+["000000020A0820404A4020080A02000000010141511005025302051051410100","00000000020A0820404A4020080A020000000101415110050253020510514101","808080C0C0C0E0C0D0C8C04040404080808083858585828A9282820A08081980","8080C0A0A0A0C0C0D0C8C0501010188080808183838782828A8A920202020380","8080E0B0B0B098C0D0D0C840404060808080878D8D8D99828A8A920202020780","8080C0E0E0E0B0C0D0C8C040404060808080838787878D828A92820202020780","007C0C0C0C0C7C007C7E7EAA88888800001F181818181F001F0F979590909000","007C2C0C0C2C7C007C7E7EAA88888800001F18191C191F001F0F979590909000","D5D5D5D5D5D5D5D5D5D5D5D5D5D5D5D5AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA","D5D5D5D5D5F5F5FDDDD5D5D5D5D5D5D5AAAAAAAAAEAEBFBFBFABAAAAAAAAAAAA","F7F7DDDDF7F7DDDDF7F7DDDDF7F7DDDDEEEEBBBBEEEEBBBBEEEEBBBBEEEEBBBB","F787A5B1B3B3B1B1B3B3B1B1B3B381DDEEE8B2A6E6E6A6A6E6E6A6A6E6E6A0BB","F78785818383818183838181838381DDEEE8B0A0E0E0A0A0E0E0A0A0E0E0A0BB","F7F7CDCDCFCF8981A3A3A5A5878FDDDDEEECA4A4E4E0A0A1E5E5A5A5E1E8BBBB","F7F7CDCDCFCF898123232525878FDDDDEEECA4A4E4E0A0216565252561E8BBBB"]

link/gsplus.fnl

@@ -1,7 +1,9 @@
-(local command (require "core.command"))
+(local command (require :core.command))
-(local {: spawn : kill } (require "lib.spawn"))
+(local {: spawn : kill } (require :lib.spawn))
-(local socket (require "socket"))
+(local socket (require :socket))
-(local json (require "lib.dkjson"))
+(local json (require :lib.dkjson))
+(local asm (require :asm.asm))
+(local lume (require :lib.lume))
 
 (local gsplus-path "/home/jeremy/src/gsplus/result/bin/GSplus")
 
@@ -16,6 +18,11 @@
   :b   " b%02X"
   :psr " p%06X"
 })
+(fn get-cpu-reg [response]
+  (-> response
+    (lume.filter #(= $1.type :cpu))
+    (. 1 :data)))
+
 (local machine
 {:boot
  (fn [self]
@@ -52,9 +59,9 @@
    (json.decode bytes))
  :cmd-response (fn [self cmd] (self:cmd cmd) (self:response))
  :hello (fn [self] (self:cmd-response "1"))
- :continue (fn [self] (self:cmd-response "3"))
+ :continue (fn [self] (self:cmd "3"))
  :step (fn [self] (self:cmd-response "2"))
- :getreg (fn [self] (self:cmd-response "4"))
+ :getreg (fn [self] (get-cpu-reg (self:cmd-response "4")))
  :set-bp (fn [self addr] (self:cmd-response (.. "8" (string.format "%06X" addr))))
  :delete-bp (fn [self addr] (self:cmd-response (.. "9" (string.format "%06X" addr))))
  :get-bp (fn [self] (self:cmd-response "A"))
@@ -77,16 +84,28 @@
  (fn [self addr k]
    (local fulladdr (bit.bor addr (bit.lshift (or k 0) 16)))
    (self:set-bp fulladdr)
-   (var retries 5)
+   ; wait for breakpoint to be hit
-   (while (> retries 0)
+   (var bp-response (self:response))
-     (local reg (. (self:getreg) 1 :data))
+   (self:delete-bp fulladdr)
-     (local pc (reg.PC:fromhex))
+   (when (not bp-response)
-     (local curr-k (reg.K:fromhex))
+     ; attempt to consume extra response in case the breakpoint was actually hit while sending the message to delete the breakpoint
-     (print (curr-k:tohex) (pc:tohex))
+     (set bp-response (self:response)))
-     (if (and (= pc addr) (= curr-k (or k 0)))
+   (when bp-response
-       (set retries 0)
+     (local reg (get-cpu-reg bp-response))
-       (do (love.timer.sleep 1) (set retries (- retries 1)))))
+     (local pc (tonumber reg.PC 16))
-   (self:delete-bp fulladdr))
+     (local curr-k (tonumber reg.K 16))
+     (and (= pc addr) (= curr-k (or k 0)))))
+
+ :jump (fn [self addr] (self:setreg {:PC addr}))
+ :do
+ (fn [self prg f]
+   (when (self:stop-at (prg:lookup-addr :debug-stub))
+     (f self)
+     (self:continue)
+     true))
+ :stub
+ (fn [self org post-debug-stub]
+   (org:append :debug-stub [:jmp post-debug-stub]))
 })
 
 (command.add #(not machine.pid) {

link/init.fnl

@@ -0,0 +1,10 @@
+(local link
+  {:switch
+   (fn [self name]
+     (set self.machine (require (.. "link." name)))
+     (set self.name name))})
+  
+(local serial (require :link.serial))
+(link:switch (if (and (pcall #(serial:connect)) (serial:connected?)) :serial :gsplus))
+
+link

link/serial.fnl

@@ -41,6 +41,7 @@
      (set bytes-to-write (bytes-to-write:sub 11))
      (set addrout (+ addrout 10))))
  :monitor (fn [self] (self:cmd "CALL-151"))
+ :stub (fn [self org post-debug-stub]) ; todo
 })
 
 (command.add #(not (machine:connected?)) {

wrap.fnl

@@ -2,26 +2,29 @@
 (local util (require "lib.util"))
 (local lume (require "lib.lume"))
 (local imgui (require "imgui"))
-(local serial (require "link.serial"))
+(local link (require "link"))
-(local gsplus (require "link.machine"))
 (local core (require "core"))
 (local command (require "core.command"))
 (local keymap (require "core.keymap"))
 (local translate (require "core.doc.translate"))
 
-(var machine (if (and (pcall #(serial:connect)) (serial:connected?)) serial gsplus))
+(command.add #(not= link.name :serial) {
-
+  "serial:switch-machine" #(link:switch :serial)
-(command.add #(not= machine serial) {
-  "serial:switch-machine" #(set machine serial)
 })
-(command.add #(not= machine gsplus) {
+(command.add #(not= link.name :gsplus) {
-  "gsplus:switch-machine" #(set machine gsplus)
+  "gsplus:switch-machine" #(link.switch :gsplus)
 })
-(command.add #(machine:connected?) {
+(command.add #(link.machine:connected?) {
   "honeylisp:upload" (fn []
     (local p (util.reload "game"))
-    (p:upload machine)
+    (p:upload link.machine)
     (core.log (string.format "%x" (p:lookup-addr p.start-symbol))))
+  "honeylisp:reload" (fn []
+    (local p-before (require :game))
+    (local p (util.reload :game))
+    (if (link.machine:do p-before #(p:upload $1))
+      (core.log "Reloaded!")
+      (core.log "Reload failed")))
 })
 (command.add (fn [] true) {
   "honeylisp:rebuild" #(util.reload "game")
@@ -64,6 +67,7 @@
   "alt+e" "fennel:eval"
   "alt+r" "lume:hotswap"
   "alt+a" "honeylisp:address"
+  "alt+l" "honeylisp:reload"
 })
 
 (fn love.load [])