iigs: tested, unworking uthernet-ii debug stub

asm/65816.fnl

@@ -44,6 +44,7 @@
     (tset mnemonic-to-modemap mnemonic (or mode :nil) (- iop 1)))
   (each [mnemonic modemap (pairs mnemonic-to-modemap)]
     (tset opcodes mnemonic (fn [mode] (. modemap (or mode :nil))))))
+(set opcodes.jsl #(when (= $1 :abl) 0x22)) ; allow forced long subroutine calls
 
 (fn dp-addr [addr]
   (when (and (= (type addr) :string) (= (addr:sub 1 1) :d))
@@ -88,6 +89,7 @@
     (where [_ addr] (dp-addr addr)) [:dp addr]
     [_ [addr]] [:ind addr]
     [_ addr :y] [:aby addr]
+    [:jsl addr] [:abl addr] ; jsl is always long
     ; we'll assume local bank for now and fix up bankswitching in :patch
     [_ addr :x] [:abx addr]
     [_ addr] [:abs addr]

ssc/iigs/bootstub.fnl

@@ -1,12 +1,16 @@
 (import-macros {:sss ! : compile} :ssc.macros)
+(local link (require :link))
 
 #(compile $1
+   (start-symbol boot)
+   [(when (not= link.name :udpdebug) (! ;udpdebug boots into 16-bit mode
      (start-symbol boot-8)
      (org 0x1000)
      (fn boot-8 ()
        (asm (clc) (xce) (rep 0x30)  ; disable emulation mode, 16-bit index registers
             (jsr boot)
             (sec) (xce))) ; re-enter emulation mode
+   ))]
 
    (org 0x060000)
    (require ssc.iigs.toolbox)

ssc/iigs/u2-debug.fnl

@@ -1,12 +1,24 @@
 (import-macros {:sss ! : compile} :ssc.macros)
 (local {: cmd : response} (require :link.udpdebug))
 
+; -VEDRIVE
+; CAT,S1
+; BLOAD UDPDEBUG.SYSTEM, TSYS, A$2000
+; CALL-151
+; 2000S
+
 (local Ssc (require :ssc))
 
 (local ssc (Ssc))
 
 (compile ssc
-  (require ssc.iigs.bootstub)
+  (start-symbol boot-8)
+  (org 0x2000)
+  (fn boot-8 ()
+    (asm (clc) (xce) (rep 0x30)  ; disable emulation mode, 16-bit index registers
+         (jsr debug-server-loop)
+         (sec) (xce))) ; re-enter emulation mode
+
   (require ssc.stdlib)
   (require ssc.iigs.uthernet2)
 
@@ -64,7 +76,7 @@
         (= cmd [cmd.pause]) (u2-debug-server-cmd-pause msgid)
         (= cmd [cmd.ping])  (u2-debug-server-cmd-ping msgid)))
 
-  (fn u2-debug-server-poll ()
+  (far-fn u2-debug-server-poll ()
     (let (size (u2-rx-begin))
       (when (> size 0)
         (let (msgid (u2-read)
@@ -76,10 +88,16 @@
             (set! u2-debug-server-connected true))
           (u2-debug-server-cmd msgid cmd)))))
 
-  (fn main ()
+  (fn debug-server-loop ()
     (u2-init-debug-server)
     (while true (u2-debug-server-poll)))
 )
 
+(let [Prodos (require :asm.prodos)
+      prg (ssc:assemble)
+      disk (Prodos "ProDOS_Blank.dsk")]
+  (disk:update-volume-header {:name "UDP.DEBUG"})
+  (disk:add-file "UDPDEBUG.SYSTEM" Prodos.file-type.SYS 0x2000 (. (prg:org 0x2000) :block :bytes))
+  (disk:write "UdpDebug.dsk"))
 
 ssc

ssc/iigs/uthernet2.fnl

@@ -3,7 +3,7 @@
   :gateway [172 24 1 1]
   :netmask [255 255 255 0]
   :ip [172 24 1 6]
-  :slot 4
+  :slot 3
   :mac [0xAD 0xE9 0xA5 0x4A 0x6D 0x66]
 })
 
@@ -29,7 +29,7 @@
         (u2-write lo)))
 
     (fn u2-read-buf (addr count)
-      (asm (ldx count)
+      (asm (lda count) (tax)
            (ldy 0)
            (sep 0x20)
          loop
@@ -42,7 +42,7 @@
            (rep 0x20)))
 
     (fn u2-write-buf (addr count)
-      (asm (ldx count)
+      (asm (lda count) (tax)
            (ldy 0)
            (sep 0x20)
          loop
@@ -57,7 +57,7 @@
     (fn u2-write-farbuf ((long addr) count)
       (asm (lda addr) (sta [$1.ADDR_LO])
            (lda addr 2) (sta [$1.ADDR_HI])
-           (ldx count)
+           (lda count) (tax)
            (ldy 0)
            (sep 0x20)
          loop

ssc/init.fnl

@@ -184,17 +184,19 @@
 
 (fn Ssc.cmp-to-bool [self op ...] (self:expr-poly [:if [op ...] true false]))
 
-(fn Ssc.compile-function [self name args ...]
+(fn Ssc.compile-function-generic [self name args body post-body returnaddr-type call-instruction]
   (assert (not (self:defining?)) "Can't nest function definitions")
   (local arglocals (self:parse-parameters args))
-  (set self.locals (lume.concat arglocals [{:type :word :comment :returnaddr}]))
+  (set self.locals (lume.concat arglocals [{:type returnaddr-type :comment :returnaddr}]))
-  ; todo: maybe handle mutually recursive functions? (compile-expr only has access to currently-defined functions)
+  (local (c-function etype) (self:expr-poly body))
-  (local (c-function etype) (self:expr-poly [:do ...]))
+  (self.org:append name c-function (table.unpack post-body))
-  (self.org:append name c-function [:rts])
   (assert (= (length self.locals) (+ (length args) 1))
           (.. "Left locals on stack?? Expected " (tostring (+ (length args) 1)) " got " (tostring (length self.locals))))
   (set self.locals [])
-  {:arity (length args) :args arglocals :org self.org :type etype : name})
+  {:arity (length args) :args arglocals :org self.org :type etype : name : call-instruction})
+
+(fn Ssc.compile-function [self name args ...] (self:compile-function-generic name args [:do ...] [[:rts]] :word :jsr))
+(fn Ssc.compile-far-function [self name args ...] (self:compile-function-generic name args [:do [:asm [:phb] [:phk] [:plb]] ...] [[:plb] [:rtl]] :long :jsl))
 
 (fn Ssc.asm-localify [self block]
   (icollect [_ inst (ipairs block)]
@@ -244,6 +246,9 @@
                                         (self:drop (. bindings (- (length bindings) (* i-half 2) -1))))]
             (values (lume.concat [:block] compiled-bindings [compiled-body] compiled-cleanup) etype)))
    :fn (lambda [self name args ...] (tset self.functions name (self:compile-function name args ...)))
+   :far-fn (lambda [self name args ...] (tset self.functions name (self:compile-far-function name args ...)))
+   :predef-fn (lambda [self name args etype]
+                (tset self.functions name {:arity (length args) :args (self:parse-parameters args) :org self.org :type etype : name :call-instruction :jsr}))
    :if (lambda [self test iftrue ?else ...]
          (let [(c-true truetype) (self:expr-poly iftrue)
                iffalse (if (> (select :# ...) 0) [:if ?else ...] ?else)
@@ -456,7 +461,7 @@
 (fn Ssc.compile-function-call [self f args]
   (let [pre (self:push-arguments f.args args)
         post (icollect [_ (countiter (length args))] (self:drop))]
-    (values (lume.concat [:block] pre [[:jsr f.name]] post) f.type)))
+    (values (lume.concat [:block] pre [[f.call-instruction f.name]] post) f.type)))
 
 (fn Ssc.enter-expr [self expr]
   (let [m (getmetatable expr)]