From 315fd794de046b9987cc2811f1e47c4f3d37796e Mon Sep 17 00:00:00 2001 From: Jeremy Penner Date: Sun, 15 Aug 2021 22:40:47 -0400 Subject: [PATCH] Working boot stub to initialize the Memory Manager toolset without an OS Listen to keyboard events --- lib/util.fnl | 6 +++- neutgs/init.fnl | 52 ++++++++++++++++++++++++---------- ssc/iigs/bootstub.fnl | 39 +++++++++++++++++++++++++ ssc/iigs/toolbox.fnl | 66 +++++++++++++++++++++++++++++++++++++------ ssc/init.fnl | 18 +++++------- 5 files changed, 145 insertions(+), 36 deletions(-) create mode 100644 ssc/iigs/bootstub.fnl diff --git a/lib/util.fnl b/lib/util.fnl index 0b22341..0942f80 100644 --- a/lib/util.fnl +++ b/lib/util.fnl @@ -116,8 +116,12 @@ (when (not= f nil) (io.close f)) (not= f nil))) +(fn pairoff [l] + (fn [_ iprev] (let [i (if iprev (+ iprev 2) 1)] + (when (< i (length l)) (values i (. l i) (. l (+ i 1))))))) + {: int8-to-bytes : int16-to-bytes : int24-to-bytes : int32-to-bytes : bytes-to-uint8 : bytes-to-uint16 : bytes-to-uint24 : splice : lo : hi : loword : hiword - : reload : hotswap : swappable :require swappable-require : hot-table : nested-tset + : reload : hotswap : swappable :require swappable-require : hot-table : nested-tset : pairoff : readjson : writejson : file-exists : waitfor : in-coro : multival} diff --git a/neutgs/init.fnl b/neutgs/init.fnl index b1a505f..b2dd331 100644 --- a/neutgs/init.fnl +++ b/neutgs/init.fnl @@ -1,10 +1,18 @@ (local Ssc (require :ssc)) (import-macros {:sss ! : compile} :ssc.macros) -(local ssc (Ssc {:boot-org 0xc00})) +(local ssc (Ssc {:boot [(! (require ssc.iigs.bootstub))]})) (compile ssc (require :ssc.iigs.toolbox) + (tooltable toolsets + ToolsetIntegerMath 0x0100 + ToolsetText 0x0100 + ToolsetQuickDraw 0x0100 + ToolsetEventManager 0x0100 + 5 0x0100 ; desk manager + 9 0x0100) ; ADB + (asm pascalhex (db 5) hexbuf (bytes " ")) (fn printnum (num) @@ -13,35 +21,49 @@ (fn add (lhs rhs) (+ lhs rhs)) - (const screen 0xe12000) + (asm event-buffer) + (global word event-what) + (global long event-msg) + (global long event-when) + (global word event-y) + (global word event-x) + (global word event-mod) + + (fn wait-for-key () + (FlushEvents keyDownMask 0) + (while (not (GetOSEvent keyDownMask (far-ref event-buffer))))) + + (const screen-addr 0xe12000) (const screen-size 0x9d00) (global word screen-offset 0) - (getter screen-cursor (+ screen screen-offset)) + (getter screen-cursor (+ screen-addr screen-offset)) (setter screen-cursor (pixels) (word! screen-cursor pixels) (set! screen-offset (+ screen-offset 2))) - (global word UserID) + (global word userID) (fn main () - (TLStartUp) - (set! UserID (MMStartUp)) + (LoadTools (far-ref toolsets)) + (set! userID (MMStartUp)) (IMStartUp) (TextStartUp) - (MTStartUp) - + (QDStartUp 0x2100 0 0 userID) + (EMStartUp 0x2000 0 0 320 0 200 userID) (GrafOn) - (set! screen-offset 0) - (while (< screen-offset screen-size) - (set! screen-cursor (+ 0x2345 screen-offset))) + (set! screen-offset 0) + (let (i 0) + (while (< screen-offset screen-size) + (set! screen-cursor (+ screen-offset i)) + (set! i (+ i 1)))) + (wait-for-key) (GrafOff) - (MTShutDown) + (EMShutDown) + (QDShutDown) (TextShutDown) (IMShutDown) - (MMShutDown UserID) - (TLShutDown))) - + (MMShutDown userID))) (ssc:assemble) diff --git a/ssc/iigs/bootstub.fnl b/ssc/iigs/bootstub.fnl new file mode 100644 index 0000000..b4c3fdb --- /dev/null +++ b/ssc/iigs/bootstub.fnl @@ -0,0 +1,39 @@ +(import-macros {:sss ! : compile} :ssc.macros) + +#(compile $1 + (start-symbol boot) + (org 0x0800) + (require ssc.iigs.toolbox) + + (global word BootUserID) + (global long BootHandle-00) + (global long BootHandle-01) + (global long BootHandle-e0) + (global long BootHandle-e1) + (fn boot () + (asm (clc) (xce) (rep 0x30)) ; disable emulation mode, 16-bit index registers + ; http://www.1000bit.it/support/manuali/apple/technotes/pdos/tn.pdos.27.html + ; When bootstrapping with no OS, we must reserve + (TLStartUp) + (LoadOneTool ToolsetMisc 0x0100) + (MTStartUp) + (set! BootUserID (GetNewID 0x1f00)) + + (LoadOneTool ToolsetMemoryManager 0x0100) + (set! BootHandle-00 (NewHandle 0xb800 BootUserID 0xb017 0x000800)) + (set! BootHandle-01 (NewHandle 0xb800 BootUserID 0xb017 0x010800)) + (set! BootHandle-e0 (NewHandle 0x4000 BootUserID 0xb017 0xe02000)) + (set! BootHandle-e1 (NewHandle 0x8000 BootUserID 0xb017 0xe12000)) + + (asm (jsr [(or $2 :main)])) + + (DisposeHandle BootHandle-e1) + (DisposeHandle BootHandle-e0) + (DisposeHandle BootHandle-01) + (DisposeHandle BootHandle-00) + (DeleteID BootUserID) + + (MTShutDown) + (asm (sec) (xce)) ; re-enter emulation mode + )) + diff --git a/ssc/iigs/toolbox.fnl b/ssc/iigs/toolbox.fnl index b01d662..386fd92 100644 --- a/ssc/iigs/toolbox.fnl +++ b/ssc/iigs/toolbox.fnl @@ -1,5 +1,7 @@ (import-macros {:sss ! : compile} :ssc.macros) (local lume (require :lib.lume)) +(local util (require :lib.util)) +(local {: pairoff} util) #(compile $1 (do (form def-toolbox [ @@ -13,11 +15,10 @@ error-handler (when (= arg-count (+ expected-arg-count 1)) (select (+ expected-arg-count 1) ...)) expected-arg-count (if error-handler (+ expected-arg-count 1) expected-arg-count) block [:block] - iloc-resultptr (do (assert (= arg-count expected-arg-count)) + iloc-resultptr (do (assert (= arg-count expected-arg-count) (.. name " expected " expected-arg-count " args, got " (fv [...]))) (when resultptr (lume.push block (ssc:push nil (ssc:expr-word resultptr))) (length ssc.locals)))] - (for [_ 1 (match return-type :void 0 :word 1 :long 2 _ return-type)] (lume.push block (ssc:push))) (each [_ push (ipairs (ssc:push-arguments (ssc:parse-parameters args) (lume.slice [...] 1 (length args))))] @@ -30,7 +31,7 @@ :-no-error-)) (match return-type :void nil - :word (lume.push block (ssc:pop)) + :word (lume.push block (ssc:pop) nil) :long (lume.push block (ssc:pop) [:sta ssc.LONG_LO] (ssc:pop) [:sta ssc.LONG_HI]) _ (do (lume.push block [:ldy 0]) (for [i 1 return-type] @@ -40,7 +41,13 @@ (values block (if (= (type return-type) :string) return-type :void))))] (ssc:expr-poly [:form name call])))]) - ; toolbox locator + (form tooltable [(fn [ssc name ...] + (ssc.org:append name [:dw (/ (select :# ...) 2)]) + (each [_ toolset-id version (pairoff [...])] + (ssc.org:append [:dw (match (type toolset-id) :number toolset-id :string (. ssc.constants toolset-id))] + [:dw version])))]) + + (const ToolsetToolLocator 0x01) (def-toolbox 0x0201 TLStartUp () void) (def-toolbox 0x0301 TLShutDown () void) (def-toolbox 0x0401 TLVersion () word) @@ -54,7 +61,7 @@ (def-toolbox 0x1201 TLTextMountVolume ((long line1Ptr) (long line2Ptr) (long button1Ptr) (long button2Ptr)) word) (def-toolbox 0x1001 UnloadOneTool (toolNumber) void) - ; integer math + (const ToolsetIntegerMath 0x0b) (def-toolbox 0x020b IMStartUp () void) (def-toolbox 0x030b IMShutDown () void) (def-toolbox 0x040b IMVersion () word) @@ -94,7 +101,7 @@ (def-toolbox 0x200b X2Fix ((long extendPtr)) long) (def-toolbox 0x210b X2Frac ((long extendPtr)) long) - ; memory manager + (const ToolsetMemoryManager 0x02) (def-toolbox 0x0202 MMStartUp () word) (def-toolbox 0x0302 MMShutDown (userID) void) (def-toolbox 0x0402 MMVersion () word) @@ -125,7 +132,7 @@ (def-toolbox 0x2502 SetPurgeAll (userID newPurgeLevel) void) (def-toolbox 0x1d02 TotalMem () long) - ; text + (const ToolsetText 0x0c) (def-toolbox 0x020c TextStartUp () void) (def-toolbox 0x030c TextShutDown () void) (def-toolbox 0x040c TextVersion () word) @@ -159,7 +166,7 @@ (def-toolbox 0x1a0c WriteLine ((long strPtr)) void) (def-toolbox 0x1c0c WriteString ((long strPtr)) void) - ; Misc toolset + (const ToolsetMisc 0x03) (def-toolbox 0x0203 MTStartUp () void) (def-toolbox 0x0303 MTShutDown () void) (def-toolbox 0x0403 MTVersion () word) @@ -201,7 +208,48 @@ (def-toolbox 0x1003 SetVector (vectorRefNum (long vectorPtr)) void) (def-toolbox 0x1103 GetVector (vectorRefNum) long) - ; QuickDraw + (const ToolsetEventManager 0x06) + (const nullEvt 0) + (const mouseDownEvt 1) + (const mouseUpEvt 2) + (const keyDownEvt 3) + (const autoKeyEvt 5) + (const updateEvt 6) + (const activeFlag 0x0001) + (const changeFlag 0x0002) + (const btn1State 0x0040) + (const btn0State 0x0080) + (const appleKey 0x0100) + (const shiftKey 0x0200) + (const capsLock 0x0400) + (const optionKey 0x0800) + (const controlKey 0x1000) + (const keyPad 0x2000) + (const mDownMask 0x0002) + (const mUpMask 0x0004) + (const keyDownMask 0x0008) + (const autoKeyMask 0x0020) + (const updateMask 0x0040) + (def-toolbox 0x0206 EMStartUp (dPageAddr queueSize xMinClamp xMaxClamp yMinClamp yMaxClamp userID) void) + (def-toolbox 0x0306 EMShutDown () void) + (def-toolbox 0x0406 EMVersion () word) + (def-toolbox 0x0606 EMStatus () word) + (def-toolbox 0x0d06 Button (buttonNum) word) + (def-toolbox 0x0b06 EventAvail (eventMask (long eventPtr)) word) + (def-toolbox 0x1506 FlushEvents (eventMask stopMask) word) + (def-toolbox 0x1206 GetCaretTime () long) + (def-toolbox 0x1106 GetDblTime () long) + (def-toolbox 0x0c06 GetMouse ((long mouseLocPtr)) void) + (def-toolbox 0x0a06 GetNextEvent (eventMask (long eventPtr)) word) + (def-toolbox 0x1606 GetOSEvent (eventMask (long eventPtr)) word) + (def-toolbox 0x1706 OSEventAvail (eventMask (long eventPtr)) word) + (def-toolbox 0x1406 PostEvent (eventCode (long eventMsg)) word) + (def-toolbox 0x1806 SetEventMask (sysEventMask) void) + (def-toolbox 0x0e06 StillDown (buttonNum) word) + (def-toolbox 0x1006 TickCount () long) + (def-toolbox 0x0f06 WaitMouseUp (buttonNum) word) + + (const ToolsetQuickDraw 0x04) (def-toolbox 0x0204 QDStartUp (dPageAddr masterSCB maxWidth userID) void) (def-toolbox 0x0304 QDShutDown () void) (def-toolbox 0x0404 QDVersion () word) diff --git a/ssc/init.fnl b/ssc/init.fnl index 277eded..36a87a6 100644 --- a/ssc/init.fnl +++ b/ssc/init.fnl @@ -37,7 +37,7 @@ (local Ssc (Object:extend)) (local Prg (require :asm.asm)) (local util (require :lib.util)) -(local {: loword : hiword} util) +(local {: loword : hiword : pairoff} util) (set Ssc.LONG_LO :d0x00) (set Ssc.LONG_HI :d0x02) @@ -64,7 +64,7 @@ (asm boot (clc) (xce) (rep 0x30) ; disable emulation mode, 16-bit index registers - (jsr main) + (jsr [(or opts.main :main)]) (sec) (xce) ;re-enter emulation mode (rts)))))) @@ -106,10 +106,6 @@ (let [i (if iprev (+ iprev 1) min)] (when (<= i max) i))))) -(fn pairoff [l] - (fn [_ iprev] (let [i (if iprev (+ iprev 2) 1)] - (when (< i (length l)) (values i (. l i) (. l (+ i 1))))))) - ; operations that work on the accumulator, like adc or sbc ; optimization strategy: keep the current result in the accumulator, work from the stack or immediate values ; 1. take "right" arguments and push them (unless already on stack, immediate, or absolute) @@ -167,7 +163,6 @@ cond (self:rewrite-condition cond) [op & args] cond cmp (. self.comparisons op)] - (pp cond) (if cmp (let [[lhs rhs] args ropgen (self:push-opgen rhs) @@ -218,12 +213,12 @@ :setter (lambda [self name arg ...] (assert (= (length arg) 1)) (tset self.setters name (self:compile-function (.. :-set- name) arg ...))) - :require (lambda [self name] + :require (lambda [self name ...] (when (= (. self.modules name) nil) (let [mod (util.reload name) func (if (= (type mod) :function) mod mod.module)] (tset self.modules name mod) - (func self)))) + (func self ...)))) :global (lambda [self etype name ?const] (tset self.globals name {:type etype : name}) (self.org:append name @@ -250,7 +245,7 @@ (c-false falsetype) (when ?iffalse (self:expr-poly ?iffalse)) etype (if (not= truetype falsetype) :void truetype) block [:block (self:gen-condition test :-if-true- :-if-false-) :-if-true- c-true] - _ (pp block) +; _ (pp block) cl-false (if ?iffalse [[:bra :-if-done-] :-if-false- c-false :-if-done-] [:-if-false-])] (values (lume.concat block cl-false) etype))) @@ -328,7 +323,7 @@ (if (and (= (type lhs) :string) (. self.setters lhs)) (self:compile-function-call (. self.setters lhs) [value]) (let [(c-value etype) (self:expr-poly value) - {: lo : hi} (self:opgen-lhs lhs) + {: lo : hi} (assert (self:opgen-lhs lhs) (.. (fv lhs) " not valid as a target of set!")) c-lo (match etype :word (lo :sta) :long [:block [:lda self.LONG_LO] (lo :sta)]) @@ -429,6 +424,7 @@ (values (lume.concat [:block] pre [[:jsr f.name]] post) f.type))) (fn Ssc.expr-poly [self expr] +; (pp expr) (match expr (where lit (?. (self:opgen lit) :hi)) (let [{: lo : hi} (self:opgen lit)] (values [:block (lo :lda) [:sta self.LONG_LO] (hi :lda) [:sta self.LONG_HI]] :long))