honeylisp/ssc/iigs/toolbox.fnl

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

#(compile $1
  (form def-toolbox [
    (fn [ssc cmd name args return-type]
      (let [call (fn [ssc ...]
                   (let [arg-count (select :# ...)
                         expected-arg-count (length args)
                         expected-resultptr (= (type return-type) :number)
                         expected-arg-count (if expected-resultptr (+ expected-arg-count 1) expected-arg-count)
                         resultptr (when expected-resultptr (select 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]
                         iloc-resultptr (do (assert (= arg-count expected-arg-count))
                                            (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))))]
                       (lume.push block push))
                     (lume.push block [:ldx cmd] [:jsr :0xe10000])
                     (ssc:was-dropped (length args))
                     (when error-handler
                       (lume.push block [:bcc :-no-error-]
                                        (ssc:push :error) (ssc:expr-poly error-handler) (ssc:drop :error)
                                        :-no-error-))
                     (match return-type
                       :void nil
                       :word (lume.push block (ssc:pop))
                       :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]
                                         (lume.push block (ssc:pop) [:sta [(ssc:local-offset iloc-resultptr) :s] :y])
                                         (when (< i return-type) (lume.push block [:iny] [:iny])))
                                       (lume.push block (ssc:drop))))
                     (values block (if (= (type return-type) :string) return-type :void))))]
      (ssc:expr-poly [:form name call])))])

  ; toolbox locator
  (def-toolbox 0x0201 TLStartUp () void)
  (def-toolbox 0x0301 TLShutDown () void)
  (def-toolbox 0x0401 TLVersion () word)
  (def-toolbox 0x0b01 GetFuncPtr (userOrSystem funcNumTsNum) long)
  (def-toolbox 0x0f01 LoadOneTool (toolNumber minVersion) void)
  (def-toolbox 0x0e01 LoadTools ((long toolTablePtr)) void)
  (def-toolbox 0x1501 MessageCenter (action type (long messageHandle)) void)
  (def-toolbox 0x1401 RestoreTextState ((long stateHandle)) void)
  (def-toolbox 0x1301 SaveTextState () long)
  (def-toolbox 0x1101 TLMountVolume (whereX whereY (long line1ptr) (long line2ptr) (long but1ptr) (long but2ptr)) word)
  (def-toolbox 0x1201 TLTextMountVolume ((long line1Ptr) (long line2Ptr) (long button1Ptr) (long button2Ptr)) word)
  (def-toolbox 0x1001 UnloadOneTool (toolNumber) void)

  ; integer math
  (def-toolbox 0x020b IMStartUp () void)
  (def-toolbox 0x030b IMShutDown () void)
  (def-toolbox 0x040b IMVersion () word)
  (def-toolbox 0x060b IMStatus () word)
  (def-toolbox 0x280b Dec2Int ((long strPtr) strLength signedFlag) word)
  (def-toolbox 0x290b Dec2Long ((long strPtr) strLength signedFlag) long)
  (def-toolbox 0x1c0b Fix2Frac ((long fixedValue)) long)
  (def-toolbox 0x1b0b Fix2Long ((long fixedValue)) long)
  (def-toolbox 0x1e0b Fix2X ((long fixedValue) (long extendPtr)) void)
  (def-toolbox 0x170b FixATan2 ((long input1) (long input2)) long)
  (def-toolbox 0x110b FixDiv ((long dividend) (long divisor)) long)
  (def-toolbox 0x0f0b FixMul ((long multiplicand) (long multiplier)) long)
  (def-toolbox 0x0e0b FixRatio (numerator denominator) long)
  (def-toolbox 0x130b FixRound ((long fixedValue)) word)
  (def-toolbox 0x1d0b Frac2Fix ((long fracValue)) long)
  (def-toolbox 0x1f0b Frac2X ((long fracValue) (long extendPtr)) void)
  (def-toolbox 0x150b FracCos ((long angle)) long)
  (def-toolbox 0x120b FracDiv ((long dividend) (long divisor)) long)
  (def-toolbox 0x100b FracMul ((long multiplicand) (long multiplier)) long)
  (def-toolbox 0x160b FracSin ((long angle)) long)
  (def-toolbox 0x140b FracSqrt ((long fracValue)) long)
  (def-toolbox 0x240b Hex2Int ((long strPtr) strLength) word)
  (def-toolbox 0x250b Hex2Long ((long strPtr) strLength) long)
  (def-toolbox 0x2a0b HexIt (intValue) long)
  (def-toolbox 0x180b HiWord ((long longValue)) word)
  (def-toolbox 0x260b Int2Dec (wordValue (long strPtr) strLength signedFlag) void)
  (def-toolbox 0x220b Int2Hex (intValue (long strPtr) strLength) void)
  (def-toolbox 0x270b Long2Dec ((long longValue) (long strPtr) strLength signedFlag) void)
  (def-toolbox 0x1a0b Long2Fix ((long longIntValue)) long)
  (def-toolbox 0x230b Long2Hex ((long longValue) (long strPtr) strLength) void)
  (def-toolbox 0x0d0b LongDivide ((long dividend) (long divisor)) 4) ; -> long remainder, long quotient
  (def-toolbox 0x0c0b LongMul ((long multiplicand) (long multiplier)) 4) ; -> long msResult, long lsResult
  (def-toolbox 0x190b LoWord ((long longValue)) word)
  (def-toolbox 0x090b Multiply (multiplicand multiplier) long)
  (def-toolbox 0x0a0b SDivide (dividend divisor) long) ; -> word remainder, word quotient
  (def-toolbox 0x0b0b UDivide (dividend divisor) long) ; -> word remainder, word quotient
  (def-toolbox 0x200b X2Fix ((long extendPtr)) long)
  (def-toolbox 0x210b X2Frac ((long extendPtr)) long)

  ; memory manager
  (def-toolbox 0x0202 MMStartUp () word)
  (def-toolbox 0x0302 MMShutDown (userID) void)
  (def-toolbox 0x0402 MMVersion () word)
  (def-toolbox 0x0602 MMStatus () word)
  (def-toolbox 0x2b02 BlockMove ((long sourcePtr) (long destPtr) (long count)) void)
  (def-toolbox 0x1e02 CheckHandle ((long theHandle)) void)
  (def-toolbox 0x1f02 CompactMem () void)
  (def-toolbox 0x1102 DisposeAll (userID) void)
  (def-toolbox 0x1002 DisposeHandle ((long theHandle)) void)
  (def-toolbox 0x1a02 FindHandle ((long locationPtr)) long)
  (def-toolbox 0x1b02 FreeMem () long)
  (def-toolbox 0x1802 GetHandleSize ((long theHandle)) long)
  (def-toolbox 0x2a02 HandToHand ((long sourceHandle) (long destHandle) (long count)) void)
  (def-toolbox 0x2902 HandToPtr ((long sourceHandle) (long destPtr) (long count)) void)
  (def-toolbox 0x2002 HLock ((long theHandle)) void)
  (def-toolbox 0x2102 HLockAll (userID) void)
  (def-toolbox 0x2202 HUnlock ((long theHandle)) void)
  (def-toolbox 0x2302 HUnlockAll (userID) void)
  (def-toolbox 0x1c02 MaxBlock () long)
  (def-toolbox 0x0902 NewHandle ((long blockSize) userID attributes (long locationPtr)) long)
  (def-toolbox 0x2802 PtrToHand ((long sourcePtr) (long destHandle) (long count)) void)
  (def-toolbox 0x1302 PurgeAll (userID) void)
  (def-toolbox 0x1202 PurgeHandle ((long theHandle)) void)
  (def-toolbox 0x0a02 ReAllocHandle ((long blockSize) userID attributes (long locationPtr) (long theHandle)) void)
  (def-toolbox 0x0b02 RestoreHandle ((long theHandle)) void)
  (def-toolbox 0x1902 SetHandleSize ((long newSize) (long theHandle)) void)
  (def-toolbox 0x2402 SetPurge ((long theHandle)) word)
  (def-toolbox 0x2502 SetPurgeAll (userID newPurgeLevel) void)
  (def-toolbox 0x1d02 TotalMem () long)

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