Fix toolbox, start to handle pointers
This commit is contained in:
parent
b63573cc89
commit
29de142c4a
|
|
@ -1,4 +1,4 @@
|
|||
(local {: int8-to-bytes : int16-to-bytes} (require "lib.util"))
|
||||
(local {: int8-to-bytes : int16-to-bytes : int24-to-bytes} (require "lib.util"))
|
||||
|
||||
(local opcodes {})
|
||||
|
||||
|
|
@ -105,7 +105,6 @@
|
|||
(where (or :abl :alx :ial)) 4
|
||||
nil 1
|
||||
_ (error (.. "unknown mode " op.mode))))
|
||||
(fn int24-to-bytes [i] (.. (int16-to-bytes (bit.band i 0xffff)) (int8-to-bytes (addr-page i))))
|
||||
|
||||
(fn op-pdat.bytes [op env]
|
||||
(local bytegen (. opcodes op.opcode))
|
||||
|
|
|
|||
|
|
@ -9,6 +9,9 @@
|
|||
|
||||
(fn lo [v] (bit.band v 0xff))
|
||||
(fn hi [v] (bit.band (bit.rshift v 8) 0xff))
|
||||
(fn loword [v] (bit.band v 0xffff))
|
||||
(fn hiword [v] (bit.band (bit.rshift v 16) 0xffff))
|
||||
|
||||
(fn int8-to-bytes [i]
|
||||
(string.char (lo i)))
|
||||
(fn int16-to-bytes [i]
|
||||
|
|
@ -112,7 +115,7 @@
|
|||
(not= f nil)))
|
||||
|
||||
{: int8-to-bytes : int16-to-bytes : int24-to-bytes : bytes-to-uint8 : bytes-to-uint16 : bytes-to-uint24
|
||||
: splice : lo : hi
|
||||
: splice : lo : hi : loword : hiword
|
||||
: reload : hotswap : swappable :require swappable-require : hot-table : nested-tset
|
||||
: readjson : writejson : file-exists : waitfor : in-coro : multival}
|
||||
|
||||
|
|
|
|||
|
|
@ -7,8 +7,8 @@
|
|||
|
||||
(asm pascalhex (db 5) hexbuf (bytes " "))
|
||||
(fn printnum (num)
|
||||
(HexIt num (& hexbuf))
|
||||
(WriteString 0 (& pascalhex)))
|
||||
(long! (ref hexbuf) (HexIt num))
|
||||
(WriteString (far-ref pascalhex)))
|
||||
|
||||
(fn add (lhs rhs) (+ lhs rhs))
|
||||
(fn main ()
|
||||
|
|
@ -23,7 +23,6 @@
|
|||
(IMShutDown)
|
||||
(MMShutDown userid)
|
||||
(TLShutDown)))
|
||||
|
||||
)
|
||||
|
||||
(ssc:assemble)
|
||||
|
|
|
|||
|
|
@ -3,128 +3,162 @@
|
|||
|
||||
#(compile $1
|
||||
(form def-toolbox [
|
||||
(fn [ssc name cmd param-words return-words]
|
||||
(fn [ssc cmd name args return-type]
|
||||
(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)
|
||||
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]]
|
||||
(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)))
|
||||
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 param-words)
|
||||
(ssc:was-dropped (length args))
|
||||
(when error-handler
|
||||
(lume.push block [:bcc :-no-error-]
|
||||
(ssc:push :error) (ssc:expr-word error-handler) (ssc:drop)
|
||||
(ssc:push :error) (ssc:expr-poly error-handler) (ssc:drop :error)
|
||||
:-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]))))
|
||||
(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))))
|
||||
block))]
|
||||
(values block (if (= (type return-type) :string) return-type :void))))]
|
||||
(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)
|
||||
(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 (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)
|
||||
; 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 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
|
||||
(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 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
|
||||
(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)
|
||||
)
|
||||
|
||||
|
|
|
|||
54
ssc/init.fnl
54
ssc/init.fnl
|
|
@ -43,6 +43,7 @@
|
|||
(local Ssc (Object:extend))
|
||||
(local Prg (require :asm.asm))
|
||||
(local util (require :lib.util))
|
||||
(local {: loword : hiword} util)
|
||||
|
||||
(set Ssc.LONG_LO :d0x00)
|
||||
(set Ssc.LONG_HI :d0x02)
|
||||
|
|
@ -65,11 +66,13 @@
|
|||
(sec) (xce) ;re-enter emulation mode
|
||||
(rts))))))
|
||||
|
||||
(fn Ssc.push [self name expr etype]
|
||||
(fn Ssc.push [self name expr ?etype]
|
||||
(local etype (or ?etype :word))
|
||||
(table.insert self.locals {: name :type etype})
|
||||
(match etype
|
||||
:word [:block expr [:pha]]
|
||||
:long [:block expr [:lda self.LONG_HI] [:pha] [:lda self.LONG_LO] [:pha]]))
|
||||
:word [:block (or expr [:flatten]) [:pha]]
|
||||
:long [:block (or expr [:flatten]) [:lda self.LONG_HI] [:pha] [:lda self.LONG_LO] [:pha]]
|
||||
_ (error (.. "Unknown stack type " (tostring etype)))))
|
||||
|
||||
(fn Ssc.remove-local [self ?name]
|
||||
(let [loc (. self.locals (length self.locals))]
|
||||
|
|
@ -178,9 +181,7 @@
|
|||
(values (lume.concat [:block] compiled-bindings [compiled-body] compiled-cleanup) etype)))
|
||||
:fn (lambda [self name args ...]
|
||||
(assert (not (self:defining?)) "Can't nest function definitions")
|
||||
(local arglocals (icollect [_ arg (ipairs args)] (match arg
|
||||
[:long aname] {:name aname :type :long}
|
||||
aname {:name aname :type :word})))
|
||||
(local arglocals (self:parse-parameters args))
|
||||
(set self.locals (lume.concat arglocals [{:type :word :comment :returnaddr}]))
|
||||
; todo: maybe handle mutually recursive functions? (compile-expr only has access to currently-defined functions)
|
||||
(local (c-function etype) (self:expr-poly [:do ...]))
|
||||
|
|
@ -231,15 +232,30 @@
|
|||
:not (lambda [self bool] (self:expr-poly [:if bool 0 0xffff]))
|
||||
:or (lambda [self lhs rhs] (self:expr-poly [:if lhs 0xffff [:if rhs 0xffff 0]]))
|
||||
:and (lambda [self lhs rhs] (self:expr-poly [:if lhs [:if rhs 0xffff 0] 0]))
|
||||
:& (lambda [self label] [:lda #($1:lookup-addr label)])
|
||||
:loword (lambda [self long] [:block (self:expr-long long) [:lda self.LONG_LO]])
|
||||
:hiword (lambda [self long] [:block (self:expr-long long) [:lda self.LONG_HI]])
|
||||
:ref (lambda [self label] [:lda #(loword ($1:lookup-addr label))])
|
||||
:far-ref (lambda [self label] (values [:block [:lda #(loword ($1:lookup-addr label))] [:sta self.LONG_LO]
|
||||
[:lda #(hiword ($1:lookup-addr label))] [:sta self.LONG_HI]] :long))
|
||||
; TODO: maybe handle a few different addressing modes here? re-use if the value is already on the stack?
|
||||
; TODO: automatically handle far-ref
|
||||
:word! (lambda [self ref value] [:block (self:push nil (self:expr-word ref) :word) (self:expr-word value) [:ldy 0] [:sta [1 :s] :y] (self:drop)])
|
||||
:long! (lambda [self ref value] [:block (self:push nil (self:expr-word ref) :word)
|
||||
(self:expr-long value) [:ldy 0] [:lda self.LONG_LO] [:sta [1 :s] :y] [:iny] [:iny] [:lda self.LONG_HI] [:sta [1 :s] :y]
|
||||
(self:drop)])
|
||||
:deref (lambda [self ref] [:block (self:push nil (self:expr-word ref) :word) [:lda [1 :s] :y] (self:drop)])
|
||||
})
|
||||
|
||||
(fn Ssc.local-offset [self name-or-index]
|
||||
(var offset nil)
|
||||
(var stacklen 0)
|
||||
(for [i 1 (length self.locals)]
|
||||
(when (or (= i name-or-index) (= (. self.locals i :name) name-or-index))
|
||||
(set offset (+ 1 (* 2 (- (length self.locals) i))))))
|
||||
offset)
|
||||
(let [loc (. self.locals i)
|
||||
size (match loc.type :word 2 :long 4 _ (error (.. "how big is this local??" (fv loc))))]
|
||||
(set stacklen (+ stacklen size))
|
||||
(when (or (= i name-or-index) (= loc.name name-or-index))
|
||||
(set offset stacklen))))
|
||||
(when offset (+ (- stacklen offset) 1)))
|
||||
|
||||
(fn Ssc.local-type [self name-or-index]
|
||||
(var etype nil)
|
||||
|
|
@ -271,6 +287,18 @@
|
|||
iloc (length (self.locals))]
|
||||
(lume.merge (self:addressible-loc iloc) {:setup #c :cleanup #(self:drop)}))))
|
||||
|
||||
(fn Ssc.parse-parameters [self params]
|
||||
(icollect [_ param (ipairs params)] (match param
|
||||
[:long pname] {:name pname :type :long}
|
||||
pname {:name pname :type :word})))
|
||||
|
||||
(fn Ssc.push-arguments [self paramdefs args]
|
||||
(icollect [iarg arg (ipairs args)]
|
||||
(let [atype (. paramdefs iarg :type)
|
||||
c-arg (: self (.. :expr- atype) arg)
|
||||
c-push (self:push nil c-arg atype)]
|
||||
c-push)))
|
||||
|
||||
(fn Ssc.expr-poly [self expr]
|
||||
(match expr
|
||||
(where lit (?. (self:addressible lit) :hi)) (let [{: lo : hi} (self:addressible lit)]
|
||||
|
|
@ -279,11 +307,7 @@
|
|||
; TODO: Global scope
|
||||
(where [func & args] (= (?. self.functions func :arity) (length args)))
|
||||
(let [f (. self.functions func)
|
||||
pre (icollect [iarg arg (ipairs args)]
|
||||
(let [atype (. f.args iarg :type)
|
||||
c-arg (: self (.. :expr- atype) arg)
|
||||
c-push (self:push nil c-arg atype)]
|
||||
c-push))
|
||||
pre (self:push-arguments f.args args)
|
||||
post (icollect [_ (countiter (length args))] (self:drop))]
|
||||
(print (fv pre) (fv post) (fv args))
|
||||
(values (lume.concat [:block] pre [[:jsr func]] post) f.type))
|
||||
|
|
|
|||
Loading…
Reference in a new issue