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

Listen to keyboard events

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}
 

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)
+    (LoadTools (far-ref toolsets))
-    (set! UserID (MMStartUp))
+    (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)
+    (MMShutDown userID)))
-    (TLShutDown)))
-
 
 (ssc:assemble)

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

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)

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