Working boot stub to initialize the Memory Manager toolset without an OS
Listen to keyboard events
This commit is contained in:
parent
e84fbd2c95
commit
315fd794de
|
@ -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}
|
||||
|
||||
|
|
|
@ -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)
|
||||
|
|
39
ssc/iigs/bootstub.fnl
Normal file
39
ssc/iigs/bootstub.fnl
Normal file
|
@ -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
|
||||
))
|
||||
|
|
@ -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)
|
||||
|
|
18
ssc/init.fnl
18
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))
|
||||
|
|
Loading…
Reference in a new issue