iigs: tested, unworking uthernet-ii debug stub
This commit is contained in:
parent
ccfb52aeaa
commit
683296b4e8
BIN
UdpDebug.dsk
Normal file
BIN
UdpDebug.dsk
Normal file
Binary file not shown.
|
@ -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]
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
19
ssc/init.fnl
19
ssc/init.fnl
|
@ -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)]
|
||||||
|
|
Loading…
Reference in a new issue