mirror/jak-project
1
0
Fork 0
mirror of https://github.com/open-goal/jak-project synced 2026-09-02 18:12:50 -04:00
Code Issues Packages Projects Releases Wiki Activity

[Decomp] Decompile gstring (#267)

Browse Source 
* decompile gstring

* update

* Update code_status.md

* Update code_status.md

* decompile gstate

* add test for states, hope it passes

* also test throw and catch xmms

* update doc
This commit is contained in:
water111
2021-02-16 20:37:48 -05:00
committed by GitHub
parent aa9bcd07f4
commit f1a93886e7
29 changed files with 2505 additions and 396 deletions
Download Patch File Download Diff File Expand all files Collapse all files
goal_src/kernel/gcommon.gc
+37 -20
View File
@@ -20,6 +20,23 @@
(defconstant RELOC_METHOD_ID 7) ;; or login?
(defconstant MEM_USAGE_METHOD_ID 8)
;; distance from a symbol pointer to a (pointer string)
;; this relies on the memory layout of the symbol table
;; this must match SYM_INFO_OFFSET in goal_constants.h + offset of the str field in struct SymUpper.
(defconstant SYM_TO_STRING_OFFSET 65336)
;; pointers larger than this are invalid by valid?
(defconstant END_OF_MEMORY #x8000000)
;; boxed object offset (16-byte alignement offsets)
(defconstant BINTEGER_OFFSET 0)
(defconstant PAIR_OFFSET 2)
(defconstant BASIC_OFFSET 4)
(defmacro symbol-to-string (sym)
;; "Convert a symbol to a goal string."
`(-> (the-as (pointer string) (+ SYM_TO_STRING_OFFSET (the-as int ,sym))))
)
;; forward declarations.
(define-extern name= (function basic basic symbol))
@@ -1114,15 +1131,15 @@
(local-vars (current-qword int))
(set! current-qword 0)
(while (< current-qword (sar word-count 2))
(format 0 "~X: ~X ~X ~X ~X~%"
(+ (+ (shl (shl current-qword 2) 2) 0) (the-as int data))
(-> data (shl current-qword 2))
(-> data (+ (shl current-qword 2) 1))
(-> data (+ (shl current-qword 2) 2))
(-> data (+ (shl current-qword 2) 3))
(format 0 "~X: ~X ~X ~X ~X~%"
(+ (+ (shl (shl current-qword 2) 2) 0) (the-as int data))
(-> data (shl current-qword 2))
(-> data (+ (shl current-qword 2) 1))
(-> data (+ (shl current-qword 2) 2))
(-> data (+ (shl current-qword 2) 3))
)
(set! current-qword (+ current-qword 1))
)
(set! current-qword (+ current-qword 1))
)
'#f
)
@@ -1138,9 +1155,9 @@
(format '#t " ")
(format '#t "| ")
)
(set! bits (shr bits 1))
(set! i (+ i 1))
)
(set! bits (shr bits 1))
(set! i (+ i 1))
)
'#f
)
@@ -1150,6 +1167,8 @@
0
)
;; these are not quite right, but it's close enough.
(defmacro start-of-symbol-table ()
`(rlet ((st :reg r15 :reset-here #t :type uint))
(the uint (- st 32768))
@@ -1189,7 +1208,7 @@
;; first, check if we are even in valid memory. This is the start of the symbol table to the end of RAM.
(set! in-goal-mem (and (>= (the-as uint obj) (start-of-symbol-table))
(< (the-as uint obj) #x8000000)
(< (the-as uint obj) END_OF_MEMORY)
)
)
(cond
@@ -1242,7 +1261,7 @@
((= expected-type pair)
;; pair alignment is 8 bytes + 2.
(cond
((!= (logand (the-as int obj) 7) 2)
((!= (logand (the-as int obj) 7) PAIR_OFFSET)
(if name
(format print-dest "ERROR: object #x~X ~S is not a valid object of type '~A' (misaligned)~%" obj name expected-type)
)
@@ -1273,7 +1292,7 @@
)
)
;; now we assume desired type is a basic.
((!= (logand (the-as int obj) 7) 4)
((!= (logand (the-as int obj) 7) BASIC_OFFSET)
(if name
(format print-dest "ERROR: object #x~X ~S is not a valid object of type '~A' (misaligned)~%" obj name expected-type)
)
@@ -1299,13 +1318,11 @@
;; otherwise... we want to check and see if the type is actually a type.
;; we use valid? to do this check.
;; avoid infinite recursion by skipping this check if the expected-type is type.
(set! v1-33 (and (!= expected-type type)
(not (valid? (rtype-of obj) type '#f '#t 0)
)
)
)
(cond
(v1-33
((and (!= expected-type type)
(not (valid? (rtype-of obj) type '#f '#t 0))
)
(if name
;; note: print the invalid type as an address in case it's unprintable.
(format print-dest "ERROR: object #x~X ~S is not a valid object of type '~A' (invalid type #x~X)~%"
goal_src/kernel/gkernel-h.gc
+20 -8
View File
@@ -141,6 +141,7 @@
(declare-type state basic)
(declare-type cpu-thread basic)
(declare-type dead-pool basic)
(declare-type event-message-block structure)
; DANGER - this type is created in kscheme.cpp. It has room for 12 methods and size 0x28 bytes.
(deftype thread (basic)
@@ -233,9 +234,9 @@
(state state :offset-assert #x38)
(trans-hook function :offset-assert #x3c)
(post-hook function :offset-assert #x40)
(event-hook (function stack-frame (function object) function state object) :offset-assert #x44)
(event-hook (function basic int basic event-message-block object) :offset-assert #x44)
(allocated-length int32 :offset-assert #x48)
(next-state basic :offset-assert #x4c)
(next-state state :offset-assert #x4c)
(heap-base pointer :offset-assert #x50)
(heap-top pointer :offset-assert #x54)
(heap-cur pointer :offset-assert #x58)
@@ -432,12 +433,13 @@
(trans (function object) :offset-assert 20)
(post function :offset-assert 24)
(enter (function object object object object object object object) :offset-assert 28)
(event basic :offset-assert 32)
(event (function basic int basic event-message-block object) :offset-assert 32)
)
(:methods
(new ((allocation symbol) (type-to-make type) (name basic) (code function)
(trans function) (enter function) (exit (function object)) (event function)) _type_ 0)
)
(new ((allocation symbol) (type-to-make type) (name basic) (code function)
(trans (function object)) (enter (function object object object object object object object)) (exit (function object))
(event (function basic int basic event-message-block object))) _type_ 0)
)
:method-count-assert 9
:size-assert #x24
:flag-assert #x900000024
@@ -505,9 +507,14 @@
`(!= 0 (logand ,mask (process-mask ,enum-value)))
)
(defmacro process-mask-set! (mask enum-value)
(defmacro process-mask-set! (mask &rest enum-value)
;; sets the given bits in the process mask (with or)
`(set! ,mask (logior ,mask (process-mask ,enum-value)))
`(set! ,mask (logior ,mask (process-mask ,@enum-value)))
)
(defmacro process-mask-clear! (mask &rest enum-value)
;; sets the given bits in the process mask (with or)
`(set! ,mask (logand ,mask (lognot (process-mask ,@enum-value))))
)
(defmacro suspend ()
@@ -531,3 +538,8 @@
(deactivate pp)
)
)
(defmacro with-pp (&rest body)
`(rlet ((pp :reg r13 :reset-here #t :type process))
,@body)
)
goal_src/kernel/gkernel.gc
+324 -219
View File
@@ -641,9 +641,7 @@
(defmethod thread-suspend cpu-thread ((unused cpu-thread))
"Suspend the thread and return to the kernel."
(declare (asm-func none)
;(print-asm)
)
(declare (asm-func none))
;; we begin this function with the thread object in pp.
;; not sure why we do this, maybe at one point suspending didn't clobber
@@ -656,71 +654,99 @@
(s1 :reg rbp :type uint)
(s2 :reg r10 :type uint)
(s3 :reg r11 :type uint)
(s4 :reg r12 :type uint))
(s4 :reg r12 :type uint)
(xmm8 :reg xmm8 :class fpr)
(xmm9 :reg xmm9 :class fpr)
(xmm10 :reg xmm10 :class fpr)
(xmm11 :reg xmm11 :class fpr)
(xmm12 :reg xmm12 :class fpr)
(xmm13 :reg xmm13 :class fpr)
(xmm14 :reg xmm14 :class fpr)
(xmm15 :reg xmm15 :class fpr)
)
;; get the return address pushed by "call" in the suspend.
(.pop temp)
;; convert to a GOAL address
(.sub temp off)
;; store return address in thread
(set! (-> obj pc) (the pointer temp))
;; get the return address pushed by "call" in the suspend.
(.pop temp)
;; convert to a GOAL address
(.sub temp off)
;; store return address in thread
(set! (-> obj pc) (the pointer temp))
;; convert our stack pointer to a GOAL address
(.sub sp off)
;; store in thread.
(set! (-> obj sp) (the pointer sp))
;; convert our stack pointer to a GOAL address
(.sub sp off)
;; store in thread.
(set! (-> obj sp) (the pointer sp))
;; back up registers
(.mov :color #f temp s0)
(set! (-> obj rreg 0) temp)
(.mov :color #f temp s1)
(set! (-> obj rreg 1) temp)
(.mov :color #f temp s2)
(set! (-> obj rreg 2) temp)
(.mov :color #f temp s3)
(set! (-> obj rreg 3) temp)
(.mov :color #f temp s4)
(set! (-> obj rreg 4) temp)
;; back up registers
(.mov :color #f temp s0)
(set! (-> obj rreg 0) temp)
(.mov :color #f temp s1)
(set! (-> obj rreg 1) temp)
(.mov :color #f temp s2)
(set! (-> obj rreg 2) temp)
(.mov :color #f temp s3)
(set! (-> obj rreg 3) temp)
(.mov :color #f temp s4)
(set! (-> obj rreg 4) temp)
;; todo, back up fprs
;; back up fprs
(.mov :color #f temp xmm8)
(set! (-> obj freg 0) (the-as float temp))
(.mov :color #f temp xmm9)
(set! (-> obj freg 1) (the-as float temp))
(.mov :color #f temp xmm10)
(set! (-> obj freg 2) (the-as float temp))
(.mov :color #f temp xmm11)
(set! (-> obj freg 3) (the-as float temp))
(.mov :color #f temp xmm12)
(set! (-> obj freg 4) (the-as float temp))
(.mov :color #f temp xmm13)
(set! (-> obj freg 5) (the-as float temp))
(.mov :color #f temp xmm14)
(set! (-> obj freg 6) (the-as float temp))
(.mov :color #f temp xmm15)
(set! (-> obj freg 7) (the-as float temp))
;; get our process
(let ((proc (-> obj process)))
(when (> (process-stack-used proc) (-> obj stack-size))
(break) ;; too much stack has been used and we can't suspend!
)
;; mark the process as suspended and copy the stack
(set! (-> proc status) 'suspended)
(let ((cur (the (pointer uint64) (-> obj stack-top)))
(save (&+ (the (pointer uint64) (-> obj stack)) (-> obj stack-size)))
)
(while (> (the int cur) (the int sp))
(set! cur (the (pointer uint64) (&- cur 8)))
(set! save (the (pointer uint64) (&- save 8)))
(set! (-> save) (-> cur))
)
)
)
;; actually setting pp to 0
(set! obj (the cpu-thread 0))
;; get the kernel stack pointer as a GOAL pointer
(.load-sym :sext #f sp *kernel-sp*)
;; convert it back to a real pointer
(.add sp off)
;; restore saved registers...
;; without coloring system because this is "cheating".
(.pop :color #f s4)
(.pop :color #f s3)
(.pop :color #f s2)
(.pop :color #f s1)
(.pop :color #f s0)
;; return to the kernel function that called the user code
(.ret)
;; get our process
(let ((proc (-> obj process)))
(when (> (process-stack-used proc) (-> obj stack-size))
(break) ;; too much stack has been used and we can't suspend!
)
;; mark the process as suspended and copy the stack
(set! (-> proc status) 'suspended)
(let ((cur (the (pointer uint64) (-> obj stack-top)))
(save (&+ (the (pointer uint64) (-> obj stack)) (-> obj stack-size)))
)
(while (> (the int cur) (the int sp))
(set! cur (the (pointer uint64) (&- cur 8)))
(set! save (the (pointer uint64) (&- save 8)))
(set! (-> save) (-> cur))
)
)
)
;; actually setting pp to 0
(set! obj (the cpu-thread 0))
;; get the kernel stack pointer as a GOAL pointer
(.load-sym :sext #f sp *kernel-sp*)
;; convert it back to a real pointer
(.add sp off)
;; restore saved registers...
;; without coloring system because this is "cheating".
(.pop :color #f s4)
(.pop :color #f s3)
(.pop :color #f s2)
(.pop :color #f s1)
(.pop :color #f s0)
;; return to the kernel function that called the user code
(.ret)
)
(none)
)
@@ -730,7 +756,7 @@
This is also used to start a thread initialized with set-to-run.
As a result of MIPS/x86 differences, there is a hack for this."
(declare (asm-func none)
;(print-asm)
;;(print-asm)
)
(rlet ((obj :reg r13 :type cpu-thread)
@@ -744,81 +770,106 @@
(s4 :reg r12 :type uint)
(a4 :reg r8 :type uint)
(a5 :reg r9 :type uint)
(temp-float :reg xmm0 :class fpr)
(xmm8 :reg xmm8 :class fpr)
(xmm9 :reg xmm9 :class fpr)
(xmm10 :reg xmm10 :class fpr)
(xmm11 :reg xmm11 :class fpr)
(xmm12 :reg xmm12 :class fpr)
(xmm13 :reg xmm13 :class fpr)
(xmm14 :reg xmm14 :class fpr)
(xmm15 :reg xmm15 :class fpr)
)
;; save the current kernel regs
(.push :color #f s0)
(.push :color #f s1)
(.push :color #f s2)
(.push :color #f s3)
(.push :color #f s4)
;; save the current kernel regs
(.push :color #f s0)
(.push :color #f s1)
(.push :color #f s2)
(.push :color #f s3)
(.push :color #f s4)
;; make rsp a GOAL pointer
(.sub sp off)
;; and store it
(set! *kernel-sp* (the pointer sp)) ;; todo, asm form here?
;; make rsp a GOAL pointer
(.sub sp off)
;; and store it
(set! *kernel-sp* (the pointer sp)) ;; todo, asm form here?
;; temp, stash thread in process-pointer
(set! obj thread-to-resume)
;; temp, stash thread in process-pointer
(set! obj thread-to-resume)
;; set stack pointer for the thread. leave it as a GOAL pointer for now..
(set! sp (the uint (-> obj sp)))
;; set stack pointer for the thread. leave it as a GOAL pointer for now..
(set! sp (the uint (-> obj sp)))
;; restore the stack (sp is a GOAL pointer)
(let ((cur (the (pointer uint64) (-> obj stack-top)))
(restore (&+ (the (pointer uint64) (-> obj stack)) (-> obj stack-size)))
)
(while (> (the int cur) (the int sp))
(set! cur (the (pointer uint64) (&- cur 8)))
(set! restore (the (pointer uint64) (&- restore 8)))
(set! (-> cur) (-> restore))
)
;; restore the stack (sp is a GOAL pointer)
(let ((cur (the (pointer uint64) (-> obj stack-top)))
(restore (&+ (the (pointer uint64) (-> obj stack)) (-> obj stack-size)))
)
;; offset sp after we're done using it as a GOAL pointer.
(.add sp off)
;; setup process
(set! (-> (-> obj process) top-thread) obj)
(set! (-> (-> obj process) status) 'running)
;; restore reg
(set! temp (-> obj rreg 0))
(.mov :color #f s0 temp)
(set! temp (-> obj rreg 1))
(.mov :color #f s1 temp)
(set! temp (-> obj rreg 2))
(.mov :color #f s2 temp)
(set! temp (-> obj rreg 3))
(.mov :color #f s3 temp)
(set! temp (-> obj rreg 4))
(.mov :color #f s4 temp)
;; todo restore fpr.
;; hack for set-to-run-bootstrap. The set-to-run-bootstrap in MIPS
;; expects to receive 7 values from the cpu thread's rregs.
;; usually rreg holds saved registers, but on the first resume after
;; a set-to-run, they hold arguments, and set-to-run-bootstrap copies them.
;; We only have 5 saved regs, so we need to cheat and directly pass
;; two values in other registers
;; so we load the a4/a5 argument registers with rreg 5 and rreg 6
;; In the case where we are doing a normal resume, the
;; compiler should assume that these registers are overwritten anyway.
(set! temp (-> obj rreg 5))
(.mov a4 temp)
(set! temp (-> obj rreg 6))
(.mov a5 temp)
;; get the resume address
(set! temp (the uint (-> obj pc)))
(.add temp off)
;; setup the process
(set! obj (the cpu-thread (-> obj process)))
;; resume!
(.jr temp)
(while (> (the int cur) (the int sp))
(set! cur (the (pointer uint64) (&- cur 8)))
(set! restore (the (pointer uint64) (&- restore 8)))
(set! (-> cur) (-> restore))
)
)
;; offset sp after we're done using it as a GOAL pointer.
(.add sp off)
;; setup process
(set! (-> (-> obj process) top-thread) obj)
(set! (-> (-> obj process) status) 'running)
;; restore reg
(set! temp (-> obj rreg 0))
(.mov :color #f s0 temp)
(set! temp (-> obj rreg 1))
(.mov :color #f s1 temp)
(set! temp (-> obj rreg 2))
(.mov :color #f s2 temp)
(set! temp (-> obj rreg 3))
(.mov :color #f s3 temp)
(set! temp (-> obj rreg 4))
(.mov :color #f s4 temp)
(set! temp-float (-> obj freg 0))
(.mov :color #f xmm8 temp-float)
(set! temp-float (-> obj freg 1))
(.mov :color #f xmm9 temp-float)
(set! temp-float (-> obj freg 2))
(.mov :color #f xmm10 temp-float)
(set! temp-float (-> obj freg 3))
(.mov :color #f xmm11 temp-float)
(set! temp-float (-> obj freg 4))
(.mov :color #f xmm12 temp-float)
(set! temp-float (-> obj freg 5))
(.mov :color #f xmm13 temp-float)
(set! temp-float (-> obj freg 6))
(.mov :color #f xmm14 temp-float)
(set! temp-float (-> obj freg 7))
(.mov :color #f xmm15 temp-float)
;; hack for set-to-run-bootstrap. The set-to-run-bootstrap in MIPS
;; expects to receive 7 values from the cpu thread's rregs.
;; usually rreg holds saved registers, but on the first resume after
;; a set-to-run, they hold arguments, and set-to-run-bootstrap copies them.
;; We only have 5 saved regs, so we need to cheat and directly pass
;; two values in other registers
;; so we load the a4/a5 argument registers with rreg 5 and rreg 6
;; In the case where we are doing a normal resume, the
;; compiler should assume that these registers are overwritten anyway.
(set! temp (-> obj rreg 5))
(.mov a4 temp)
(set! temp (-> obj rreg 6))
(.mov a5 temp)
;; get the resume address
(set! temp (the uint (-> obj pc)))
(.add temp off)
;; setup the process
(set! obj (the cpu-thread (-> obj process)))
;; resume!
(.jr temp)
)
(none)
)
@@ -903,10 +954,14 @@
;; Process Dead Pool Heap
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; a dead-pool-heap is a chunk of memory where you can allocate variable sized processes.
; these processes start out with a lot of memory, then shrink their heap (compact) to the size
; they actually need. To avoid heap fragmentation, the dead-pool-heap system will relocate
; processes. This requires that you implement the relocate method on your process.
;; a dead-pool-heap is a chunk of memory where you can allocate variable sized processes.
;; these processes start out with a lot of memory, then shrink their heap (compact) to the size
;; they actually need. To avoid heap fragmentation, the dead-pool-heap system will relocate
;; processes. This requires that you implement the relocate method on your process.
;; DANGER: the dead pool heap is _not_ a proper process tree. Do not attempt to treat it like on.
;; If you get-process, you should immediately activate it. The activate method will (change-parent)
;; and this will get stuck in an endless loop if you do it on a process that wasn't the most recent one.
(define-extern *null-process* process)
@@ -1612,7 +1667,6 @@
(lambda ((obj process))
;(format 0 "Call to dispatcher lambda!~%")
(let ((context *kernel-context*))
(cond
((or (eq? (-> obj status) 'waiting-to-run)
(eq? (-> obj status) 'suspended))
@@ -1658,8 +1712,10 @@
(if (process-mask? (-> obj mask) sleep-code)
;; we're sleeping. Move us to suspended, in case we were in waiting to run.
(set! (-> obj status) 'suspended)
;; not sleeping. call resume hook
((-> obj main-thread resume-hook) (-> obj main-thread))
)
;; check for deadness
(cond
@@ -1763,7 +1819,6 @@
The allocation must be an address.
Unlike the original, this only works on the first six parameters, but I think this doesn't matter."
(declare (asm-func object)
;(print-asm)
(allow-saved-regs) ;; very dangerous!
)
@@ -1776,79 +1831,102 @@
(s2 :reg r10 :type (pointer uint64))
(s3 :reg r11 :type uint)
(s4 :reg r12 :type uint)
(xmm8 :reg xmm8 :class fpr)
(xmm9 :reg xmm9 :class fpr)
(xmm10 :reg xmm10 :class fpr)
(xmm11 :reg xmm11 :class fpr)
(xmm12 :reg xmm12 :class fpr)
(xmm13 :reg xmm13 :class fpr)
(xmm14 :reg xmm14 :class fpr)
(xmm15 :reg xmm15 :class fpr)
)
;; we treat the allocation as an address.
(let ((obj (the catch-frame (&+ allocation *gtype-basic-offset*))))
;; setup catch frame
(set! (-> obj type) type-to-make)
(set! (-> obj name) name)
;; get the return address (the compiler won't touch the stack because we're an asm-func)
(.pop temp)
(.push temp)
;; make it a GOAL address so it fits in 32 bitys
(.sub temp off)
;; store it
(set! (-> obj ra) (the int temp))
;; we treat the allocation as an address.
(let ((obj (the catch-frame (&+ allocation *gtype-basic-offset*))))
;; setup catch frame
(set! (-> obj type) type-to-make)
(set! (-> obj name) name)
;; get the return address (the compiler won't touch the stack because we're an asm-func)
(.pop temp)
(.push temp)
;; make it a GOAL address so it fits in 32 bitys
(.sub temp off)
;; store it
(set! (-> obj ra) (the int temp))
;; todo, do we need a stack offset here?
;; remember the stack pointer
(set! temp sp)
(.sub temp off)
(set! (-> obj sp) (the int temp))
;; todo, do we need a stack offset here?
;; remember the stack pointer
(set! temp sp)
(.sub temp off)
(set! (-> obj sp) (the int temp))
;; back up registers we care about
(.mov :color #f temp s0)
(set-u128-as-u64! (-> obj rreg 0) temp)
(.mov :color #f temp s1)
(set-u128-as-u64! (-> obj rreg 1) temp)
(.mov :color #f temp s2)
(set-u128-as-u64! (-> obj rreg 2) temp)
(.mov :color #f temp s3)
(set-u128-as-u64! (-> obj rreg 3) temp)
(.mov :color #f temp s4)
(set-u128-as-u64! (-> obj rreg 4) temp)
;; todo save fprs
;; back up registers we care about
(.mov :color #f temp s0)
(set-u128-as-u64! (-> obj rreg 0) temp)
(.mov :color #f temp s1)
(set-u128-as-u64! (-> obj rreg 1) temp)
(.mov :color #f temp s2)
(set-u128-as-u64! (-> obj rreg 2) temp)
(.mov :color #f temp s3)
(set-u128-as-u64! (-> obj rreg 3) temp)
(.mov :color #f temp s4)
(set-u128-as-u64! (-> obj rreg 4) temp)
(.mov :color #f temp xmm8)
(set! (-> obj freg 0) (the-as float temp))
(.mov :color #f temp xmm9)
(set! (-> obj freg 1) (the-as float temp))
(.mov :color #f temp xmm10)
(set! (-> obj freg 2) (the-as float temp))
(.mov :color #f temp xmm11)
(set! (-> obj freg 3) (the-as float temp))
(.mov :color #f temp xmm12)
(set! (-> obj freg 4) (the-as float temp))
(.mov :color #f temp xmm13)
(set! (-> obj freg 5) (the-as float temp))
(.mov :color #f temp xmm14)
(set! (-> obj freg 6) (the-as float temp))
(.mov :color #f temp xmm15)
(set! (-> obj freg 7) (the-as float temp))
;; push this stack frame
(set! (-> obj next) (-> pp stack-frame-top))
(set! (-> pp stack-frame-top) obj)
;; push this stack frame
(set! (-> obj next) (-> pp stack-frame-top))
(set! (-> pp stack-frame-top) obj)
;; help coloring, it isn't smart enough to realize it's "safe" to use these registers.
(.push :color #f s3)
(.push :color #f s2)
(.push :color #f s2)
(set! s3 (the uint func))
(set! s2 param-block)
;; help coloring, it isn't smart enough to realize it's "safe" to use these registers.
(.push :color #f s3)
(.push :color #f s2)
(.push :color #f s2)
(set! s3 (the uint func))
(set! s2 param-block)
;; todo - are we aligned correctly here?
(let ((ret ((the-super-u64-fucntion s3)
(-> s2 0)
(-> s2 1)
(-> s2 2)
(-> s2 3)
(-> s2 4)
(-> s2 5)
))
)
(.pop :color #f s2)
(.pop :color #f s2)
(.pop :color #f s3)
(set! (-> pp stack-frame-top) (-> pp stack-frame-top next))
(.ret)
(the object ret)
;; todo - are we aligned correctly here?
(let ((ret ((the-super-u64-fucntion s3)
(-> s2 0)
(-> s2 1)
(-> s2 2)
(-> s2 3)
(-> s2 4)
(-> s2 5)
))
)
)
(.pop :color #f s2)
(.pop :color #f s2)
(.pop :color #f s3)
(set! (-> pp stack-frame-top) (-> pp stack-frame-top next))
(.ret)
(the object ret)
)
)
)
)
(defun throw-dispatch ((obj catch-frame) value)
"Throw the given value to the catch frame.
Only can throw a 64-bit value. The original could throw 128 bits."
(declare (asm-func none)
;(print-asm)
)
(declare (asm-func none))
(rlet ((pp :reg r13 :type process)
(temp :reg rax :type uint)
@@ -1859,38 +1937,64 @@
(s2 :reg r10 :type (pointer uint64))
(s3 :reg r11 :type uint)
(s4 :reg r12 :type uint)
(temp-float :reg xmm0 :class fpr)
(xmm8 :reg xmm8 :class fpr)
(xmm9 :reg xmm9 :class fpr)
(xmm10 :reg xmm10 :class fpr)
(xmm11 :reg xmm11 :class fpr)
(xmm12 :reg xmm12 :class fpr)
(xmm13 :reg xmm13 :class fpr)
(xmm14 :reg xmm14 :class fpr)
(xmm15 :reg xmm15 :class fpr)
)
;; pop everything we threw past
(set! (-> pp stack-frame-top) (-> obj next))
;; pop everything we threw past
(set! (-> pp stack-frame-top) (-> obj next))
;; restore regs we care about.
(set-u64-from-u128! temp (-> obj rreg 0))
(.mov :color #f s0 temp)
(set-u64-from-u128! temp (-> obj rreg 1))
(.mov :color #f s1 temp)
(set-u64-from-u128! temp (-> obj rreg 2))
(.mov :color #f s2 temp)
(set-u64-from-u128! temp (-> obj rreg 3))
(.mov :color #f s3 temp)
(set-u64-from-u128! temp (-> obj rreg 4))
(.mov :color #f s4 temp)
;; todo fpr
;; restore regs we care about.
(set-u64-from-u128! temp (-> obj rreg 0))
(.mov :color #f s0 temp)
(set-u64-from-u128! temp (-> obj rreg 1))
(.mov :color #f s1 temp)
(set-u64-from-u128! temp (-> obj rreg 2))
(.mov :color #f s2 temp)
(set-u64-from-u128! temp (-> obj rreg 3))
(.mov :color #f s3 temp)
(set-u64-from-u128! temp (-> obj rreg 4))
(.mov :color #f s4 temp)
(set! temp-float (-> obj freg 0))
(.mov :color #f xmm8 temp-float)
(set! temp-float (-> obj freg 1))
(.mov :color #f xmm9 temp-float)
(set! temp-float (-> obj freg 2))
(.mov :color #f xmm10 temp-float)
(set! temp-float (-> obj freg 3))
(.mov :color #f xmm11 temp-float)
(set! temp-float (-> obj freg 4))
(.mov :color #f xmm12 temp-float)
(set! temp-float (-> obj freg 5))
(.mov :color #f xmm13 temp-float)
(set! temp-float (-> obj freg 6))
(.mov :color #f xmm14 temp-float)
(set! temp-float (-> obj freg 7))
(.mov :color #f xmm15 temp-float)
;; set stack pointer
(set! sp (the uint (-> obj sp)))
(.add sp off)
;; set stack pointer
(set! sp (the uint (-> obj sp)))
(.add sp off)
;; overwrite our return address
(.pop temp)
(set! temp (the uint (-> obj ra)))
(.add temp off)
(.push temp)
;; overwrite our return address
(.pop temp)
(set! temp (the uint (-> obj ra)))
(.add temp off)
(.push temp)
;; load the return register
(.mov temp value)
(.ret)
)
;; load the return register
(.mov temp value)
(.ret)
)
)
(defun throw ((name symbol) value)
@@ -2006,6 +2110,7 @@
(let ((thread (new 'global 'cpu-thread obj 'code PROCESS_STACK_SAVE_SIZE stack-top)))
(set! (-> obj main-thread) thread)
)
(change-parent obj dest)
)
goal_src/kernel/gstate.gc
+346
View File
@@ -4,3 +4,349 @@
;; name: gstate.gc
;; name in dgo: gstate
;; dgos: KERNEL
#|
Summary of state system:
A process can be put into a state, using enter-state, or the go macro.
This will set up the process to run the appropriate handler functions defined by the state.
The state handlers are:
- enter : gets run before trans on the first time the state is used. Can be #f. Must return.
- trans : gets run before code each time the code is run. Can be #f. Must return.
- code : main thread. Can suspend. If it returns, the process dies
- exit : gets run when leaving a state. must return.
- event : not sure of the details here yet.
You can "go" to another state. This causes the current main thread execution to be abandoned.
If the main thread has exits/protects on the stack frame, they will be run first to clean up.
There are several ways to "go"
- go during init: when a process is being initialized with run-function-in-process, you can "go".
this causes the run-function-in-process to return, and the next time the process is dispatched
it will go into the other state. This will automatically set the process to waiting-to-run,
and shrink the process heap, if appropriate
- go from outside the process. You can temporarily set pp to another process, and have that
process go to another state. The actually go will occur the next time the process is scheduled.
- go from a non-main thread in the right process. You can do a go from a temporary thread, like trans or post.
If you do it from post, the go returns. If you do it from any other thread, the temporary thread
is immediately abandonded. Like the previous two, it will defer the actual go until the next time the
process runs.
- go from the main thread of the main process. This causes the (-> pp state) to change, the stack frames
to be cleaned up, and the old state's exit to be called. It will reset the stack, then run the code.
|#
;; fancy macro to accept variable arguments for go.
;; (defmacro go (next-state &rest args)
;; (if (< 6 (length args))
;; (error "too many arguments to go")
;; (let ((zero-args (repeated-list 0 (- 6 (length args)))))
;; `(with-pp
;; (set! (-> pp next-state) ,next-state)
;; (enter-state ,@args ,@zero-args)
;; )
;; )
;; )
;; )
;; cause the current process to change state
(defmacro go (next-state &rest args)
`(with-pp
(set! (-> pp next-state) ,next-state)
((the (function _varargs_ object) enter-state) ,@args)
)
)
;; cause the given process to change state.
(defmacro go-process (proc state &rest args)
`(with-pp
(protect (pp)
(set! pp ,proc)
(set! (-> pp next-state) ,state)
((the (function _varargs_ object) enter-state) ,@args)
)
)
)
;; run the given function in a process right now.
;; will return to here when:
;; - you return
;; - you deactivate
;; - you go
;; - you throw to 'initialize
(defmacro run-now-in-process (proc func &rest args)
`((the (function _varargs_ object) run-function-in-process)
,proc ,func ,@args
)
)
;; sets the main thread of the given process to run the given thing.
;; this resets the main thread stack back to the top
(defmacro run-next-time-in-process (proc func &rest args)
`((the (function _varargs_ object) set-to-run)
(-> ,proc main-thread) ,func ,@args
)
)
;; display a listing of active processes.
(defmacro ps (&key (detail #f))
`(inspect-process-tree *active-pool* 0 0 ,detail)
)
;; define a state state
(defmacro defstate (state-name
&key (event #f)
&key (enter #f)
&key (trans #f)
&key (exit #f)
&key (code #f)
&key (post #f)
)
`(begin
(define ,state-name (new 'static 'state
:name (quote ,state-name)
:next #f
:exit #f
:code #f
:trans #f
:post #f
:enter #f
:event #f
)
)
,(if event
`(set! (-> ,state-name event) ,event)
`(none)
)
,(if enter
`(set! (-> ,state-name enter) (the (function object object object object object object object) ,enter))
`(none)
)
,(if trans
`(set! (-> ,state-name trans) ,trans)
`(none)
)
,(if exit
`(set! (-> ,state-name exit) ,exit)
`(none)
)
,(if code
`(set! (-> ,state-name code) ,code)
`(none)
)
,(if post
`(set! (-> ,state-name post) ,post)
`(none)
)
)
)
(defmethod new state
((allocation symbol)
(type-to-make type)
(name basic)
(code function)
(trans (function object))
(enter (function object object object object object object object))
(exit (function object))
(event (function basic int basic event-message-block object)))
"Allocate a new state. It seems like this isn't really used much and most states are
statically allocated and as a result don't have the constructor called."
(let ((obj (object-new allocation type-to-make (the-as int (-> type-to-make size)))))
(set! (-> obj name) name)
(set! (-> obj next) '#f)
(set! (-> obj exit) exit)
(set! (-> obj code) code)
(set! (-> obj trans) trans)
(set! (-> obj post) '#f)
(set! (-> obj enter) enter)
(set! (-> obj event) event)
obj
)
)
(defun inherit-state ((child state) (parent state))
"Copy handler functions from parent to child"
(set! (-> child exit) (-> parent exit))
(set! (-> child code) (-> parent code))
(set! (-> child trans) (-> parent trans))
(set! (-> child post) (-> parent post))
(set! (-> child enter) (-> parent enter))
(set! (-> child event) (-> parent event))
child
)
(defmethod print state ((obj state))
"Print a state."
(format '#t "#<~A ~A @ #x~X>" (-> obj type) (-> obj name) obj)
obj
)
(define-extern enter-state (function object object object object object object object))
(defun enter-state (arg0 arg1 arg2 arg3 arg4 arg5)
"Make the process stored in pp enter the state in pp next-state"
;;(declare (print-asm))
(with-pp
;; unsleep us
(process-mask-clear! (-> pp mask) sleep sleep-code)
;; mark as going
(process-mask-set! (-> pp mask) going)
(cond
((= (-> pp status) 'initialize)
;; did a go during initialize.
;; remove the old trans hook, if there was one
(set! (-> pp trans-hook) #f)
(set-to-run (-> pp main-thread) enter-state arg0 arg1 arg2 arg3 arg4 arg5)
;; tell the kernel that we did a go during init
(set! (-> pp status) 'initialize-go)
;; abandon this thread, go back to what initialized us!
(throw 'initialize #t)
#t
)
((!= (-> *kernel-context* current-process) pp)
;; we aren't actually in process pp right now.
;; so set us up to go in the next run
(let ((status-backup (-> pp status)))
(set! (-> pp trans-hook) #f)
;; will set waiting-to-run
(set-to-run (-> pp main-thread) enter-state arg0 arg1 arg2 arg3 arg4 arg5)
;; restore the old status.
(set! (-> pp status) status-backup)
#t
)
)
((= (-> pp main-thread) (-> pp top-thread))
;; we are in the right process, and in the main thread!
;; actually do a go!
(set! (-> pp state) (-> pp next-state))
;; loop through current stack frames
(let ((frame (-> pp stack-frame-top)))
(while frame
(let ((typ (-> frame type)))
(if (or (= typ protect-frame) (= typ state))
;; if we got a protect-frame or a state, call exit handler
((-> (the protect-frame frame) exit))
)
)
(set! frame (-> frame next))
)
)
;; done with going!
(process-mask-clear! (-> pp mask) going)
;; now, update the process:
(let ((new-state (-> pp state)))
;; event hook from the current state
(set! (-> pp event-hook) (-> new-state event))
;; if we have an exit, push it onto the stack frame
;; and also blow away the old stack frame
(if (-> new-state exit)
(set! (-> pp stack-frame-top) new-state)
(set! (-> pp stack-frame-top) #f)
)
(set! (-> pp post-hook) (-> new-state post))
(set! (-> pp trans-hook) (-> new-state trans))
;; now do the enter
(let ((enter-func (-> new-state enter)))
(if enter-func
(enter-func arg0 arg1 arg2 arg3 arg4 arg5)
)
)
;; now do the trans
(let ((trans-func (-> new-state trans)))
(if trans-func
(trans-func)
)
)
;; now we run the code, but in a tricky way.
(rlet ((temp)
(func)
(sp :reg rsp :type uint)
(off :reg r15 :type uint)
(carg0 :reg rdi)
(carg1 :reg rsi)
(carg2 :reg rdx)
(carg3 :reg rcx))
;; prepare args
;; compiler will likely have these on the stack, we need to get them in regs
;; before messing with the stack.
(.mov carg0 arg0)
(.mov carg1 arg1)
(.mov carg2 arg2)
(.mov carg3 arg3)
;; get the main code as an x86-64 pointer
(.mov func (-> new-state code))
(.add func off)
;; reset the stack (scary)
(.mov sp (-> pp main-thread stack-top))
(.add sp off)
;; push the return trampoline for when code returns.
(.mov temp return-from-thread-dead)
(.add temp off)
(.push temp)
;; and call!
(.jr func)
;; stupid hack so the compiler doesn't throw away these registers.
(.add carg0 carg1)
(.add carg2 carg3)
#f ;; can't get here
)
)
)
(else
;; not in the main-thread.
;; so we set up the main thread to try again.
(set! (-> pp trans-hook) #f)
(set-to-run (-> pp main-thread)
enter-state arg0 arg1 arg2 arg3 arg4 arg5)
(when (!= (-> pp top-thread name) 'post)
;; abandon this one too.
;; NOTE - this is different from GOAL.
;; GOAL installs this as the return address for this function and returns normally.
;; but we don't because I don't have an easy way to find where to stick this.
;; I can't see how this makes a difference, as all non-main threads seem
;; temporary, but if this turns out to be false, we will need to change this.
(rlet ((temp)
(off :reg r15 :type uint :reset-here #t))
(.mov temp return-from-thread)
(.add temp off)
(.push temp)
(.ret)
#f ;; can't get here
)
)
)
)
)
)
(defun send-event-function ((proc process) (msg event-message-block))
(with-pp
(when (and proc (!= (-> proc type) process-tree) (-> proc event-hook))
(let ((pp-backup pp))
(set! pp proc)
(let ((result ((-> proc event-hook) (-> msg from) (-> msg num-params) (-> msg message) msg)))
(set! pp pp-backup)
result
)
)
)
)
)
(defun looping-code ()
"Loop."
(while #t
(suspend)
)
#f
)
goal_src/kernel/gstring-h.gc
+2
View File
@@ -5,6 +5,8 @@
;; name in dgo: gstring-h
;; dgos: KERNEL
;; generates no code.
(define-extern *string-tmp-str* string)
(define-extern *temp-string* string)
(define-extern *stdcon0* string)
goal_src/kernel/gstring.gc
+630 -29
View File
@@ -60,11 +60,88 @@
)
)
;; string=
;; string-charp=
;; name=
;; copyn-string<-charp
;; string<-charp
(defun string= ((str-a string) (str-b string))
"Does str-a hold the same data as str-b?.
If either string is null, returns #f."
(local-vars (b-ptr (pointer uint8)) (a-ptr (pointer uint8)))
(set! a-ptr (-> str-a data))
(set! b-ptr (-> str-b data))
(if (or (zero? str-a) (zero? str-b))
(return '#f)
)
;; loop until we reach the end of one string
(while (and (nonzero? (-> a-ptr 0)) (nonzero? (-> b-ptr 0)))
(if (!= (-> a-ptr 0) (-> b-ptr 0))
(return '#f)
)
(set! a-ptr (&-> a-ptr 1))
(set! b-ptr (&-> b-ptr 1))
)
;; only equal if both at the end.
(and (zero? (-> a-ptr 0)) (zero? (-> b-ptr 0)))
)
(defun string-charp= ((str string) (charp (pointer uint8)))
"Is the data in str equal to the C string charp?"
(local-vars (str-ptr (pointer uint8)))
(set! str-ptr (-> str data))
(while (and (nonzero? (-> str-ptr 0)) (nonzero? (-> charp 0)))
(if (!= (-> str-ptr 0) (-> charp 0))
(return '#f)
)
(set! str-ptr (&-> str-ptr 1))
(set! charp (&-> charp 1))
)
(and (zero? (-> str-ptr 0)) (zero? (-> charp 0)))
)
(defun name= ((arg0 basic) (arg1 basic))
"Do arg0 and arg1 have the same name?
This can use either strings or symbols"
(cond
((= arg0 arg1)
"Either same symbols, or same string objects, fast check pass!"
'#t)
((and (= (-> arg0 type) string) (= (-> arg1 type) string))
(string= (the-as string arg0) (the-as string arg1))
)
((and (= (-> arg0 type) string) (= (-> arg1 type) symbol))
(string= (the-as string arg0) (symbol-to-string arg1))
)
((and (= (-> arg1 type) string) (= (-> arg0 type) symbol))
(string= (the-as string arg1) (symbol-to-string arg0))
)
)
)
(defun copyn-string<-charp ((str string) (charp (pointer uint8)) (len int))
"Copy data from a charp to a GOAL string. Copies len chars, plus a null."
(local-vars (str-ptr (pointer uint8)) (i int))
(set! str-ptr (-> str data))
(set! i 0)
(while (< i len)
(set! (-> str-ptr 0) (-> charp 0))
(set! str-ptr (&-> str-ptr 1))
(set! charp (&-> charp 1))
(set! i (+ i 1))
)
(set! (-> str-ptr 0) 0)
str
)
(defun string<-charp ((str string) (charp (pointer uint8)))
"Copy all chars from a char* to a GOAL string.
Does NO length checking."
(local-vars (str-ptr (pointer uint8)))
(set! str-ptr (-> str data))
(while (nonzero? (-> charp 0))
(set! (-> str-ptr 0) (-> charp 0))
(set! str-ptr (&-> str-ptr 1))
(set! charp (&-> charp 1))
)
(set! (-> str-ptr 0) 0)
str
)
(defun charp<-string ((dst (pointer uint8)) (src-string string))
"Copy a GOAL string into a character array."
@@ -79,40 +156,564 @@
)
)
;; copy-charp<-charp
;; cat-string<-string
;; catn-string<-charp
;; cat-string<-string_to_charp
;; append-character-to-string
;; charp-basename
(defun copy-charp<-charp ((dst (pointer uint8)) (src (pointer uint8)))
"C string copy."
(while (nonzero? (-> src 0))
(set! (-> dst 0) (-> src 0))
(set! dst (&-> dst 1))
(set! src (&-> src 1))
)
(set! (-> dst 0) 0)
dst
)
(defun cat-string<-string ((a string) (b string))
"Append b to a. No length checks"
(local-vars (a-ptr (pointer uint8)) (b-ptr (pointer uint8)))
(set! a-ptr (-> a data))
(set! b-ptr (-> b data))
;; seek to the end of a
(while (nonzero? (-> a-ptr 0))
(nop!)
(nop!)
(nop!)
(set! a-ptr (&-> a-ptr 1))
)
;; append b
(while (nonzero? (-> b-ptr 0))
(set! (-> a-ptr 0) (-> b-ptr 0))
(set! a-ptr (&-> a-ptr 1))
(set! b-ptr (&-> b-ptr 1))
)
;; null terminate
(set! (-> a-ptr 0) 0)
a
)
(defun catn-string<-charp ((a string) (b (pointer uint8)) (len int))
"Append b to a, exactly len chars"
(local-vars (a-ptr (pointer uint8)) (i int) )
(set! a-ptr (-> a data))
;; seek to end of a
(while (nonzero? (-> a-ptr 0))
(nop!)
(nop!)
(nop!)
(set! a-ptr (&-> a-ptr 1))
)
;; append
(set! i 0)
(while (< i len)
(set! (-> a-ptr 0) (-> b 0))
(set! a-ptr (&-> a-ptr 1))
(set! b (&-> b 1))
(set! i (+ i 1))
)
(set! (-> a-ptr 0) 0)
a
)
(defun cat-string<-string_to_charp ((a string) (b string) (end-ptr (pointer uint8)))
"Append b to a, using chars of b up to (and including) the one pointed to by end-ptr,
or, until the end of b, whichever comes first."
(let ((b-ptr (-> b data))
(a-ptr (-> a data))
)
;; seek to end of a
(while (nonzero? (-> a-ptr 0))
(nop!)
(nop!)
(nop!)
(set! a-ptr (&-> a-ptr 1))
)
(while (and (>= (the-as int end-ptr) (the-as int b-ptr))
(nonzero? (-> b-ptr 0)))
(set! (-> a-ptr 0) (-> b-ptr 0))
(set! a-ptr (&-> a-ptr 1))
(set! b-ptr (&-> b-ptr 1))
)
(set! (-> a-ptr 0) 0)
a-ptr
)
)
(defun append-character-to-string ((str string) (char uint8))
"Append char to the end of the given string."
(let ((str-ptr (-> str data)))
(while (nonzero? (-> str-ptr 0))
(nop!)
(nop!)
(nop!)
(set! str-ptr (&-> str-ptr 1))
)
(set! (-> str-ptr 0) char)
(set! (-> str-ptr 1) 0)
0
)
)
(defun charp-basename ((charp (pointer uint8)))
"Like basename in C"
(let ((ptr charp))
;; seek to end
(while (nonzero? (-> ptr 0))
(set! ptr (&-> ptr 1))
)
;; and back up...
(while (< (the-as int charp) (the-as int ptr))
(set! ptr (&-> ptr -1))
;; (if (or (zero? (+ (-> ptr 0) -47)) (zero? (+ (-> ptr 0) -92)))
;; check for equal to / or \
(if (or (= (-> ptr 0) #\/) (= (-> ptr 0) #\\))
;; return the next char after that
(return (&-> ptr 1))
)
)
;; didn't find any slashes, return the whole thing.
charp
)
)
(defun clear ((a0-0 string))
"Make string empty"
(set! (-> a0-0 data 0) 0) a0-0
)
;; string<?
;; string>?
;; string<=?
;; string>=?
;; NOTE: these string comparisons are a little broken.
;; ex: (string<? "asd" "asdf") = #f
;; (string<? "asdf" "asd") = #f
;; these comparisons do not properly order strings.
(defun string<? ((a string) (b string))
"In dictionary order, is a < b?"
(local-vars (i int) (len int))
;; get the minimum length.
;; note - we don't do virtual calls here for some reason.
(set! len (min ((method-of-type string length) a)
((method-of-type string length) b)
)
)
;; loop through chars, up until the minimum length.
(set! i 0)
(while (< i len)
(cond
((< (-> a data i) (-> b data i)) (return '#t))
((< (-> b data i) (-> a data i)) (return '#f))
)
(set! i (+ i 1))
)
'#f
)
(defun string>? ((a string) (b string))
"In dictionary order, is a > b?"
(local-vars (i int) (len int))
(set! len (min ((method-of-type string length) a)
((method-of-type string length) b))
)
(set! i 0)
(while (< i len)
(cond
((< (-> a data i) (-> b data i)) (return '#f))
((< (-> b data i) (-> a data i)) (return '#t))
)
(set! i (+ i 1))
)
'#f
)
(defun string<=? ((a string) (b string))
(local-vars (i int) (len int))
(set! len (min ((method-of-type string length) a)
((method-of-type string length) b))
)
(set! i 0)
(while
(< i len)
(cond
((< (-> a data i) (-> b data i)) (return '#t))
((< (-> b data i) (-> a data i)) (return '#f))
)
(set! i (+ i 1))
)
'#t
)
(defun string>=? ((a string) (b string))
(local-vars (i int) (len int))
(set! len (min ((method-of-type string length) a)
((method-of-type string length) b))
)
(set! i 0)
(while (< i len)
(cond
((< (-> a data i) (-> b data i)) (return '#f))
((< (-> b data i) (-> a data i)) (return '#t))
)
(set! i (+ i 1))
)
'#t
)
;; temporary string for argument functions
(define *string-tmp-str* (new 'global 'string 128 (the string #f)))
;; string-skip-to-char
;; string-cat-to-last-char
;; string-skip-whitespace
;; string-suck-up!
;; string-strip-leading-whitespace
;; string-strip-trailing-whitespace
;; string-strip-whitespace
;; string-get-arg!!
;; string->int
;; string->float
;; string-get-int32!!
;; string-get-float!!
;; string-get-flag!!
(defun string-skip-to-char ((str (pointer uint8)) (char uint))
"Return pointer to first instance of char in C string, or to the null terminator if none"
(while (and (nonzero? (-> str 0)) (!= (-> str 0) char))
(set! str (&-> str 1))
)
str
)
(defun string-cat-to-last-char ((base-str string) (append-str string) (char uint))
"Append append-str to the end of of base-str, up to the last occurance of char in append-str"
(local-vars
(location-of-char (pointer uint8))
(end-of-append (pointer uint8))
)
;; point to one before the beginning of the append string (kind of a hack)
(set! end-of-append (&-> (the-as (pointer uint8) append-str) 3))
;; try to find char in append-str
(set! location-of-char (string-skip-to-char (-> append-str data) char))
(when (= (-> location-of-char 0) char)
;; found it!
(until
(begin
;; update the location of the last find
(set! end-of-append location-of-char)
;; try to find another
(set! location-of-char (string-skip-to-char (&-> location-of-char 1) char))
;; did we succeed?
(!= (-> location-of-char 0) char)
)
(none)
)
)
;; now location-of-char points to the last occurance.
;; or to 1 before the start of append-str if we never found it.
(cat-string<-string_to_charp base-str append-str end-of-append)
)
(defmacro is-whitespace-char? (c)
;; 32 = space
;; 9 = \t
;; 13 = \r
;; 10 = \n
`(or (= ,c 32)
(= ,c 9)
(= ,c 13)
(= ,c 10)
)
)
(defun string-skip-whitespace ((arg0 (pointer uint8)))
"Skip over spaces, tabs, r's and n's"
(while
(and (nonzero? (-> arg0 0))
(is-whitespace-char? (-> arg0 0))
)
(set! arg0 (&-> arg0 1))
)
arg0
)
(defun string-suck-up! ((str string) (location (pointer uint8)))
"Remove character between the start of string and location.
The char pointed to by location is now the first."
;; fast check to do nothing if location points to start already.
(when (!= location (-> str data))
(let ((str-ptr (-> str data)))
;; copy back
(while (nonzero? (-> location 0))
(set! (-> str-ptr 0) (-> location 0))
(set! str-ptr (&-> str-ptr 1))
(set! location (&-> location 1))
)
;; null terminate
(set! (-> str-ptr 0) 0)
)
'#f
)
)
(defun string-strip-leading-whitespace! ((str string))
"Remove whitespace at the front of a string"
(let ((start-loc (string-skip-whitespace (-> str data))))
(string-suck-up! str start-loc)
)
#f
)
(defun string-strip-trailing-whitespace! ((str string))
"Remove whitespace at the end of a string"
(local-vars (ptr (pointer uint8)))
(when (nonzero? ((method-of-type string length) str))
(set! ptr (&+ (-> str data)
(the-as uint (+ ((method-of-type string length) str) -1)))
)
(while (and (>= (the-as int ptr) (the-as int (-> str data)))
(is-whitespace-char? (-> ptr 0))
)
(set! ptr (&-> ptr -1))
)
(set! (-> ptr 1) 0)
)
'#f
)
(defun string-strip-whitespace! ((arg0 string))
"Remove whitespace at the beginning and end of a string"
(string-strip-trailing-whitespace! arg0)
(string-strip-leading-whitespace! arg0)
'#f
)
(defun string-get-arg!! ((a-str string) (arg string))
"Get the first argument from a whitespace separated list of arguments.
The arguments can be in quotes or not.
Removes argument from arg string, sucks up white space before the next one
Outputs argument to a-str."
(local-vars
(arg-start (pointer uint8))
(v1-11 (pointer uint8))
(a0-6 symbol)
(a0-20 symbol)
(a1-3 (pointer uint8))
(a1-9 (pointer uint8))
(arg-word-start (pointer uint8))
(arg-end (pointer uint8))
)
;; seek up the beginning of a word.
(set! arg-word-start (string-skip-whitespace (-> arg data)))
(cond
((= (-> arg-word-start 0) 34) ;; starts with quote
;; seek past quote to first char of name
(set! arg-end (&-> arg-word-start 1))
;; now, find the end
(set! arg-start arg-end)
(while (and (nonzero? (-> arg-end 0))
;; (nonzero? (+ (-> arg-end 0) -34))
(!= (-> arg-end 0) 34) ;; quote
)
(set! arg-end (&-> arg-end 1))
)
;; copy to output.
(copyn-string<-charp a-str arg-start (- (the-as int arg-end) (the-as uint arg-start)))
;; if we got a close quote
(when (= (-> arg-end 0) 34)
;; seek past it
(set! arg-end (&-> arg-end 1))
)
(set! a1-3 (string-skip-whitespace arg-end))
(string-suck-up! arg a1-3)
(return '#t)
)
((nonzero? (-> arg-word-start 0))
(set! v1-11 arg-word-start)
(while
(and
(nonzero? (-> arg-word-start 0))
(nonzero? (+ (-> arg-word-start 0) -32))
(nonzero? (+ (-> arg-word-start 0) -9))
(nonzero? (+ (-> arg-word-start 0) -13))
(nonzero? (+ (-> arg-word-start 0) -10))
)
(set! arg-word-start (&-> arg-word-start 1))
)
(copyn-string<-charp a-str v1-11 (- (the-as int arg-word-start) (the-as uint v1-11)))
(set! a1-9 (string-skip-whitespace arg-word-start))
(string-suck-up! arg a1-9)
(return '#t)
)
)
'#f
)
(defun string->int ((str string))
"String to int. Supports binary, hex, and decimal. Negative is implemented for decimal and hex
But I think it's broken?"
(local-vars
(result int)
(negative symbol)
(str-ptr (pointer uint8))
(next-char-1 (pointer uint8))
(next-char-2 (pointer uint8))
(a0-4 (pointer uint8))
(a0-5 symbol)
(a1-14 uint)
(a1-16 symbol)
(a1-20 uint)
(a1-23 uint)
(a1-33 symbol)
(a1-44 symbol)
(a1-47 (pointer uint8))
)
(set! str-ptr (-> str data))
(set! result 0)
(set! negative '#f)
(cond
((= (-> str-ptr 0) 35) ;; #
;; starts with #.
(set! next-char-1 (&-> str-ptr 1))
(cond
((or (= (-> next-char-1 0) #\x) (= (-> next-char-1 0) #\X))
;; starts with #x or #X
(set! next-char-2 (&-> next-char-1 1))
(when (= (-> next-char-2 1) #\-)
;; negate!
(set! negative '#t)
(set! next-char-2 (&-> next-char-2 1))
)
(while
(or
;; is in [0-9]
(and
(>= (-> next-char-2 0) #\0)
(>= (the-as uint #\9) (-> next-char-2 0))
)
;; is in [A-F]
(and
(>= (-> next-char-2 0) (the-as uint 65))
(>= (the-as uint 70) (-> next-char-2 0))
)
;; is in [a-f]
(and
(>= (-> next-char-2 0) (the-as uint 97))
(>= (the-as uint 102) (-> next-char-2 0))
)
)
(cond
;; is in [A-F]
((and
(>= (-> next-char-2 0) (the-as uint 65))
(>= (the-as uint 70) (-> next-char-2 0))
)
(set!
result
(the int (+ (+ (-> next-char-2 0) -55) (the-as uint (shl result 4))))
)
)
(else
(set!
a1-16
(and
(>= (-> next-char-2 0) (the-as uint 97))
(>= (the-as uint 102) (-> next-char-2 0))
)
)
(cond
(a1-16
;; in [a-f]
(set! result
(the int (+ (+ (-> next-char-2 0) -87) (the-as uint (shl result 4))))
)
)
(else
;; numeric
(set! result
(the int (+ (+ (-> next-char-2 0) -48) (the-as uint (shl result 4))))
)
) ;; end numeric
) ;; end numeric or [a-f]
) ;; end not [A-F]
) ;; end cond
(set! next-char-2 (&-> next-char-2 1))
) ;; end while
)
((or (zero? (+ (-> next-char-1 0) -98)) (zero? (+ (-> next-char-1 0) -66)))
;; is #b (I guess we can't do negative binary?)
(set! a0-4 (&-> next-char-1 1))
(while (and (>= (-> a0-4 0) (the-as uint 48)) (>= (the-as uint 49) (-> a0-4 0)))
(set! result (the int (+ (+ (-> a0-4 0) -48) (the-as uint (shl result 1)))))
(set! a0-4 (&-> a0-4 1))
)
)
)
)
(else
;; decimal
;; check for negative
(when (= (-> str-ptr 1) 45)
(set! negative '#t)
(set! str-ptr (&-> str-ptr 1))
(set! a1-47 str-ptr)
)
(while (and
(>= (-> str-ptr 0) (the-as uint 48))
(>= (the-as uint 57) (-> str-ptr 0))
)
(set! result (the int (+ (+ (-> str-ptr 0) -48) (the-as uint (* 10 result)))))
(set! str-ptr (&-> str-ptr 1))
)
)
)
(cond (negative (- result)) (else result))
)
(defun string->float ((arg0 string))
"Convert a string to a float, but it is not implemented."
(format 0 "string->float left as an excersize for the reader~%")
0.0
)
(defun string-get-int32!! ((arg0 (pointer int32)) (arg1 string))
"Get an int32 from a list of arguments"
(cond
((string-get-arg!! *string-tmp-str* arg1)
(set! (-> arg0 0) (string->int *string-tmp-str*))
'#t
)
(else '#f)
)
)
(defun string-get-float!! ((arg0 (pointer float)) (arg1 string))
(cond
((string-get-arg!! *string-tmp-str* arg1)
(set! (-> arg0 0) (string->float *string-tmp-str*))
'#t
)
(else '#f)
)
)
(defun string-get-flag!! ((result (pointer symbol)) (in string) (first-flag string) (second-flag string))
(local-vars (v1-0 symbol))
(cond
((string-get-arg!! *string-tmp-str* in)
(cond
((or (string= *string-tmp-str* first-flag)
(string= *string-tmp-str* second-flag)
)
(set! (-> result 0) (string= *string-tmp-str* first-flag))
'#t
)
(else '#f)
)
)
(else '#f)
)
)
;; what is this?
(define *debug-draw-pauseable* #f)
;; console buffers. not sure what the two are for.
(define *stdcon0* (new 'global 'string 16384 (the string #f)))
(define *stdcon1* (new 'global 'string 16384 (the string #f)))
(define *stdcon* *stdcon0*)
(define *temp-string* (new 'global 'string 256 (the string #f)))
;; shared temporary string.
(define *temp-string* (new 'global 'string 256 (the string #f)))