iigs: tested, unworking uthernet-ii debug stub

This commit is contained in:
Jeremy Penner 2021-09-25 14:53:18 -04:00
parent ccfb52aeaa
commit 683296b4e8
6 changed files with 49 additions and 20 deletions

BIN
UdpDebug.dsk Normal file

Binary file not shown.

View file

@ -44,6 +44,7 @@
(tset mnemonic-to-modemap mnemonic (or mode :nil) (- iop 1))) (tset mnemonic-to-modemap mnemonic (or mode :nil) (- iop 1)))
(each [mnemonic modemap (pairs mnemonic-to-modemap)] (each [mnemonic modemap (pairs mnemonic-to-modemap)]
(tset opcodes mnemonic (fn [mode] (. modemap (or mode :nil)))))) (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] (fn dp-addr [addr]
(when (and (= (type addr) :string) (= (addr:sub 1 1) :d)) (when (and (= (type addr) :string) (= (addr:sub 1 1) :d))
@ -88,6 +89,7 @@
(where [_ addr] (dp-addr addr)) [:dp addr] (where [_ addr] (dp-addr addr)) [:dp addr]
[_ [addr]] [:ind addr] [_ [addr]] [:ind addr]
[_ addr :y] [:aby 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 ; we'll assume local bank for now and fix up bankswitching in :patch
[_ addr :x] [:abx addr] [_ addr :x] [:abx addr]
[_ addr] [:abs addr] [_ addr] [:abs addr]

View file

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

View file

@ -1,12 +1,24 @@
(import-macros {:sss ! : compile} :ssc.macros) (import-macros {:sss ! : compile} :ssc.macros)
(local {: cmd : response} (require :link.udpdebug)) (local {: cmd : response} (require :link.udpdebug))
; -VEDRIVE
; CAT,S1
; BLOAD UDPDEBUG.SYSTEM, TSYS, A$2000
; CALL-151
; 2000S
(local Ssc (require :ssc)) (local Ssc (require :ssc))
(local ssc (Ssc)) (local ssc (Ssc))
(compile 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.stdlib)
(require ssc.iigs.uthernet2) (require ssc.iigs.uthernet2)
@ -64,7 +76,7 @@
(= cmd [cmd.pause]) (u2-debug-server-cmd-pause msgid) (= cmd [cmd.pause]) (u2-debug-server-cmd-pause msgid)
(= cmd [cmd.ping]) (u2-debug-server-cmd-ping 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)) (let (size (u2-rx-begin))
(when (> size 0) (when (> size 0)
(let (msgid (u2-read) (let (msgid (u2-read)
@ -76,10 +88,16 @@
(set! u2-debug-server-connected true)) (set! u2-debug-server-connected true))
(u2-debug-server-cmd msgid cmd))))) (u2-debug-server-cmd msgid cmd)))))
(fn main () (fn debug-server-loop ()
(u2-init-debug-server) (u2-init-debug-server)
(while true (u2-debug-server-poll))) (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

View file

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

View file

@ -184,17 +184,19 @@
(fn Ssc.cmp-to-bool [self op ...] (self:expr-poly [:if [op ...] true false])) (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") (assert (not (self:defining?)) "Can't nest function definitions")
(local arglocals (self:parse-parameters args)) (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)) (assert (= (length self.locals) (+ (length args) 1))
(.. "Left locals on stack?? Expected " (tostring (+ (length args) 1)) " got " (tostring (length self.locals)))) (.. "Left locals on stack?? Expected " (tostring (+ (length args) 1)) " got " (tostring (length self.locals))))
(set 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] (fn Ssc.asm-localify [self block]
(icollect [_ inst (ipairs block)] (icollect [_ inst (ipairs block)]
@ -244,6 +246,9 @@
(self:drop (. bindings (- (length bindings) (* i-half 2) -1))))] (self:drop (. bindings (- (length bindings) (* i-half 2) -1))))]
(values (lume.concat [:block] compiled-bindings [compiled-body] compiled-cleanup) etype))) (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 ...))) :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 ...] :if (lambda [self test iftrue ?else ...]
(let [(c-true truetype) (self:expr-poly iftrue) (let [(c-true truetype) (self:expr-poly iftrue)
iffalse (if (> (select :# ...) 0) [:if ?else ...] ?else) iffalse (if (> (select :# ...) 0) [:if ?else ...] ?else)
@ -456,7 +461,7 @@
(fn Ssc.compile-function-call [self f args] (fn Ssc.compile-function-call [self f args]
(let [pre (self:push-arguments f.args args) (let [pre (self:push-arguments f.args args)
post (icollect [_ (countiter (length args))] (self:drop))] 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] (fn Ssc.enter-expr [self expr]
(let [m (getmetatable expr)] (let [m (getmetatable expr)]