diff --git a/UdpDebug.dsk b/UdpDebug.dsk new file mode 100644 index 0000000..da10e9e Binary files /dev/null and b/UdpDebug.dsk differ diff --git a/asm/65816.fnl b/asm/65816.fnl index 9f344db..4e052fd 100644 --- a/asm/65816.fnl +++ b/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] diff --git a/ssc/iigs/bootstub.fnl b/ssc/iigs/bootstub.fnl index ad7877f..845d442 100644 --- a/ssc/iigs/bootstub.fnl +++ b/ssc/iigs/bootstub.fnl @@ -1,12 +1,16 @@ (import-macros {:sss ! : compile} :ssc.macros) +(local link (require :link)) #(compile $1 - (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 + (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) diff --git a/ssc/iigs/u2-debug.fnl b/ssc/iigs/u2-debug.fnl index 76a9642..8bd5c14 100644 --- a/ssc/iigs/u2-debug.fnl +++ b/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 diff --git a/ssc/iigs/uthernet2.fnl b/ssc/iigs/uthernet2.fnl index c649111..ce4dfe8 100644 --- a/ssc/iigs/uthernet2.fnl +++ b/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 diff --git a/ssc/init.fnl b/ssc/init.fnl index 1bdfa86..745ed3e 100644 --- a/ssc/init.fnl +++ b/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}])) - ; todo: maybe handle mutually recursive functions? (compile-expr only has access to currently-defined functions) - (local (c-function etype) (self:expr-poly [:do ...])) - (self.org:append name c-function [:rts]) + (set self.locals (lume.concat arglocals [{:type returnaddr-type :comment :returnaddr}])) + (local (c-function etype) (self:expr-poly body)) + (self.org:append name c-function (table.unpack post-body)) (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)]