SpindleyQ/honeylisp
1
1
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

Working boot stub to initialize the Memory Manager toolset without an OS

Browse source 
Listen to keyboard events
This commit is contained in:
Jeremy Penner 2021-08-15 22:40:47 -04:00
parent e84fbd2c95
commit 315fd794de
5 changed files with 145 additions and 36 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
lib/util.fnl
View file

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

52
neutgs/init.fnl
View file

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

66
ssc/iigs/toolbox.fnl
View file

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

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