honeylisp/ssc/iigs/toolbox.fnl

(import-macros {:sss ! : compile} :ssc.macros)
(local lume (require :lib.lume))

#(compile $1
  (form def-toolbox [
    (fn [ssc name cmd param-words return-words]
      (let [call (fn [ssc ...]
                   (let [arg-count (select :# ...)
                         expected-arg-count param-words
                         resultptr (when (> return-words 1) (select (+ expected-arg-count 1) ...))
                         expected-arg-count (if resultptr (+ expected-arg-count 1) expected-arg-count)
                         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]]
                     (assert (= arg-count expected-arg-count))
                     (when resultptr (lume.push block (ssc:expr-word resultptr) (ssc:push)))
                     (for [_ 1 return-words] (lume.push block (ssc:push)))
                     (for [i 1 param-words]  (lume.push block (ssc:expr-word (select i ...)) (ssc:push)))
                     (lume.push block [:ldx cmd] [:jsr :0xe10000])
                     (ssc:was-dropped param-words)
                     (when error-handler
                       (lume.push block [:bcc :-no-error-]
                                        (ssc:push :error) (ssc:expr-word error-handler) (ssc:drop)
                                        :-no-error-))
                     (if (= return-words 1) (lume.push block (ssc:pop))

                         resultptr (do (lume.push block [:ldy 0])
                                       (for [i 1 return-words]
                                         (let [stack-offset (+ (* (- return-words i) 2) 1)]
                                           (lume.push block (ssc:pop) [:sta [stack-offset :s] :y])
                                           (when (< i return-words) (lume.push block [:iny] [:iny]))))
                                       (lume.push block (ssc:drop))))
                     block))]
      (ssc:expr-poly [:form name call])))])

  ; todo: some kind of type system, or wrappers for 32-bit pointers, god

  ; toolbox locator
  (def-toolbox TLStartUp 0x0201 0 0)
  (def-toolbox TLShutDown 0x0301 0 0)
  (def-toolbox TLVersion 0x0401 0 1)
  (def-toolbox GetFuncPtr 0x0b01 2 2)
  (def-toolbox LoadOneTool 0x0f01 2 0)
  (def-toolbox LoadTools 0x0e01 2 0)
  (def-toolbox MessageCenter 0x1501 4 0)
  (def-toolbox RestoreTextState 0x1401 2 0)
  (def-toolbox SaveTextState 0x1301 0 2)
  (def-toolbox TLMountVolume 0x1101 10 1)
  (def-toolbox TLTextMountVolume 0x1201 8 1)
  (def-toolbox UnloadOneTool 0x1001 1 0)

  ; integer math (skipping long, frac, and fixed because 32 is too many bits)
  (def-toolbox IMStartUp 0x020b 0 0)
  (def-toolbox IMShutDown 0x030b 0 0)
  (def-toolbox IMVersion 0x040b 0 1)
  (def-toolbox IMStatus 0x060b 0 1)
  (def-toolbox Dec2Int 0x280b 6 1)
  (def-toolbox HexIt 0x2a0b 1 2)
  (def-toolbox Int2Dec 0x260b 5 0)
  (def-toolbox Int2Hex 0x220b 4 0)
  (def-toolbox Multiply 0x090b 2 2)
  (def-toolbox SDivide 0x0a0b 2 2)
  (def-toolbox UDivide 0x0b0b 2 2)

  ; memory manager
  (def-toolbox MMStartUp 0x0202 0 1) ; -> word userID
  (def-toolbox MMShutDown 0x0302 1 0) ; word userID
  (def-toolbox MMVersion 0x0402 0 1) ; word version
  (def-toolbox MMStatus 0x0602 0 1) ; bool
  (def-toolbox BlockMove 0x2b02 6 0)
  (def-toolbox CheckHandle 0x1e02 2 0)
  (def-toolbox CompactMem 0x1f02 0 0)
  (def-toolbox DisposeAll 0x1102 1 0)
  (def-toolbox DisposeHandle 0x1002 2 0)
  (def-toolbox FindHandle 0x1a02 2 2)
  (def-toolbox FreeMem 0x1b02 0 2)
  (def-toolbox GetHandleSize 0x1802 2 2)
  (def-toolbox HandToHand 0x2a02 6 0)
  (def-toolbox HandToPtr 0x2902 6 0)
  (def-toolbox HLock 0x2002 2 0)
  (def-toolbox HLockAll 0x2102 1 0)
  (def-toolbox HUnlock 0x2202 2 0)
  (def-toolbox HUnlockAll 0x2302 1 0)
  (def-toolbox MaxBlock 0x1c02 0 2)
  (def-toolbox NewHandle 0x0902 6 2)
  (def-toolbox PtrToHand 0x2802 6 0)
  (def-toolbox PurgeAll 0x1302 1 0)
  (def-toolbox PurgeHandle 0x1202 2 0)
  (def-toolbox ReAllocHandle 0x0a02 8 0)
  (def-toolbox RestoreHandle 0x0b02 2 0) ; handle theHandle
  (def-toolbox SetHandleSize 0x1902 4 0) ; long newSize, handle theHandle
  (def-toolbox SetPurge 0x2402 2 1) ; handle theHandle -> word newPurgeLevel
  (def-toolbox SetPurgeAll 0x2502 2 0) ; word userID, word newPurgeLevel
  (def-toolbox TotalMem 0x1d02 0 2) ; -> long totalSize

  ; text
  (def-toolbox TextStartUp 0x020c 0 0)
  (def-toolbox TextShutDown 0x030c 0 0)
  (def-toolbox TextVersion 0x040c 0 1) ; -> versionInfo
  (def-toolbox TextStatus 0x060c 0 1) ; -> activeFlag
  (def-toolbox CtlTextDev 0x160c 2 0) ; word deviceNum, word controlCode
  (def-toolbox ErrWriteBlock 0x1f0c 4 0) ; ptr textPtr, word offset, word count
  (def-toolbox ErrWriteChar 0x190c 1 0) ; word theChar
  (def-toolbox ErrWriteCString 0x210c 2 0) ; ptr cStrPtr
  (def-toolbox ErrWriteLine 0x1b0c 2 0) ; ptr strPtr
  (def-toolbox ErrWriteString 0x1d0c 2 0) ; ptr strPtr
  (def-toolbox GetErrGlobals 0x0e0c 0 2) ; -> word andMask, word orMask
  (def-toolbox GetErrorDevice 0x140c 0 3) ; -> word deviceType, long ptrOrSlot
  (def-toolbox GetInGlobals 0x0c0c 0 2) ; -> word andMask, word orMask
  (def-toolbox GetInputDevice 0x120c 0 3) ; -> word deviceType, long ptrOrSlot
  (def-toolbox GetOutGlobals 0x0d0c 0 2) ; -> word andMask, word orMask
  (def-toolbox GetOutputDevice 0x130c 0 3) ; -> word deviceType, long ptrOrSlot
  (def-toolbox InitTextDev 0x150c 1 0) ; word deviceNum
  (def-toolbox ReadChar 0x220c 1 1) ; word echoFlag -> word char
  (def-toolbox ReadLine 0x240c 5 1) ; ptr bufferPtr, word maxCount, word eolChar, word echoFlag -> word charCount
  (def-toolbox SetErrGlobals 0x0b0c 2 0) ; word andMask, word orMask
  (def-toolbox SetErrorDevice 0x110c 3 0) ; word deviceType, long ptrOrSlot
  (def-toolbox SetInGlobals 0x090c 2 0) ; word andMask, word orMask
  (def-toolbox SetInputDevice 0x0f0c 3 0) ; word deviceType, long ptrOrSlot
  (def-toolbox SetOutGlobals 0x0a0c 2 0) ; word andMask, word orMask
  (def-toolbox SetOutputDevice 0x100c 3 0) ; word deviceType, long ptrOrSlot
  (def-toolbox StatusTextDev 0x170c 2 0) ; word deviceNum, word requestCode
  (def-toolbox TextReadBlock 0x230c 5 0) ; ptr bufferPtr, word offset, word blockSize, word echoFlag
  (def-toolbox TextWriteBlock 0x1e0c 4 0) ; ptr textPtr, word offset, word count
  (def-toolbox WriteChar 0x180c 1 0) ; word theChar
  (def-toolbox WriteCString 0x200c 2 0) ; ptr cStrPtr
  (def-toolbox WriteLine 0x1a0c 2 0) ; ptr strPtr
  (def-toolbox WriteString 0x1c0c 2 0) ; ptr strPtr
)