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)))
(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]

View file

@ -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)

View file

@ -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

View file

@ -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

View file

@ -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)]