GameLib is a collection of libraries for creating applications in Cakelisp.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

1803 lines
82 KiB

(import "FileUtilities.cake"
"CHelpers.cake" "ComptimeHelpers.cake")
(c-import "<stdlib.h>" ;; atoi, atof
"<string.h>" ;; strcmp
"<ctype.h>" ;; For isspace
&with-decls "<stdio.h>" ;; FILE ;; TODO: How can I remove this from header?
"<stddef.h>") ;; For size_t, offsetof
;;
;; Comptime
;;
;; Allows modules to conditionally define introspection overrides in GameLib without requiring
;; everything use Introspection
(comptime-define-symbol 'Introspection)
(defun-comptime is-type-string (tokens (& (const (<> (in std vector) Token)))
start-type-token-index int
;; Will distinguish which sub-type of string it is
possible-string-introspect-type (* (* (const char)))
&return bool)
(var start-type-token (* (const Token)) (addr (at start-type-token-index tokens)))
;; No string types can be expressed with a single keyword
(unless (= TokenType_OpenParen (path start-type-token > type))
(set (deref possible-string-introspect-type) null)
(return false))
(var start-possible-char-type int -1)
(cond
((std-str-equals (path (+ 1 start-type-token) > contents) "*")
(set start-possible-char-type (+ 2 start-type-token-index))
(set (deref possible-string-introspect-type) "introspect-type-string"))
((std-str-equals (path (+ 1 start-type-token) > contents) "[]")
(set start-possible-char-type (+ 3 start-type-token-index)) ;; Skip the size ;; TODO Bug if size is expression
(set (deref possible-string-introspect-type) "introspect-type-fixed-size-string"))
(true
(set (deref possible-string-introspect-type) null)
(return false)))
(var start-possible-char-type-token (* (const Token))
(addr (at start-possible-char-type tokens)))
(cond
((and (= TokenType_OpenParen (path start-possible-char-type-token > type))
(= TokenType_Symbol (path (+ 1 start-possible-char-type-token) > type))
(std-str-equals (path (+ 1 start-possible-char-type-token) > contents) "const")
(std-str-equals (path (+ 2 start-possible-char-type-token) > contents) "char"))
(return true))
((and (= TokenType_Symbol (path start-possible-char-type-token > type))
(std-str-equals (path start-possible-char-type-token > contents) "char"))
(return true))
(true
(set (deref possible-string-introspect-type) null)
(return false)))
(set (deref possible-string-introspect-type) null)
(return false))
(defun-comptime introspect-metadata-name-from-struct-name (buffer-out (* char) buffer-size size_t
struct-name (* (const char)))
(SafeSnprintf buffer-out buffer-size "%s--metadata-def"
struct-name))
(defun-comptime introspect-metadata-pointer-name-from-struct-name (buffer-out (* char)
buffer-size size_t
struct-name (* (const char)))
(SafeSnprintf buffer-out buffer-size "%s--metadata"
struct-name))
;; Use macro so it can be used in comptime and at runtime
(defmacro introspect-get-num-tags ()
;; Tags are arbitrarily limited to 2. They are strings to facilitate cross-executable
;; communication as well as not require any enum updating
;; TODO: Don't change this without also updating the metadata-field! The macro doesn't work yet there
(tokenize-push output 2)
(return true))
;; The main interface to create introspect-structs. Define them just like regular structs, only you
;; can add a () list after the type to specify tags and other things.
;; Note that you will need to define override handlers for types the system can't figure out how to
;; read/write/compare etc.
(defmacro def-introspect-struct (struct-name symbol &rest arguments any)
(var processed-arguments (* (<> std::vector Token)) (new (<> std::vector Token)))
(call-on push_back (field environment comptimeTokens) processed-arguments)
(var fields-metadata (* (<> std::vector Token)) (new (<> std::vector Token)))
(call-on push_back (field environment comptimeTokens) fields-metadata)
(var end-token-index int (FindCloseParenTokenIndex tokens startTokenIndex))
(var num-parens int 1) ;; Count the opening of the struct definition
(defenum read-state
state-variable-name
state-variable-type
state-variable-annotations)
(var state read-state state-variable-name)
;; TODO: Need better helper functions for getting tokens vs. elements (where element can be array or symbol)
(var start-members int (getExpectedArgument "first member" tokens startTokenIndex 2 end-token-index))
(when (= -1 start-members)
(return false))
(each-token-argument-in tokens start-members end-token-index i
(var name-token (* (const Token))
(addr (at i tokens)))
(set i (getNextArgument tokens i end-token-index))
(var type-token-index int i)
(var type-token (* (const Token))
(addr (at i tokens)))
;; Read annotations
(var ignore-field bool false)
(var override-field bool false)
(var possible-annotation-index int (getNextArgument tokens i end-token-index))
(var annotations-token (* (const Token))
(addr (at possible-annotation-index tokens)))
(var tags-tokens (<> (in std vector) Token))
(call-on resize tags-tokens (introspect-get-num-tags))
(each-in-range (call-on size tags-tokens) i
(set (at i tags-tokens) (deref type-token))
(set (field (at i tags-tokens) type) TokenType_Symbol)
(set (field (at i tags-tokens) contents) "null"))
(var next-free-tag-token int 0)
(when (= TokenType_OpenParen (path annotations-token > type))
;; Process annotation
(var end-annotation-index int (FindCloseParenTokenIndex tokens possible-annotation-index))
(each-token-argument-in tokens (+ 1 possible-annotation-index) end-annotation-index annotation-arg
(var annotation-token (* (const Token)) (addr (at annotation-arg tokens)))
(cond
((and (= TokenType_Symbol (path annotation-token > type))
(std-str-equals (path annotation-token > contents) "ignore"))
(set ignore-field true))
((and (= TokenType_Symbol (path annotation-token > type))
(std-str-equals (path annotation-token > contents) "override"))
(set override-field true))
((or
(= (path annotation-token > type) TokenType_String)
(= (at 0 (path annotation-token > contents)) '\''))
(when (>= next-free-tag-token (call-on size tags-tokens))
(ErrorAtTokenf (deref annotation-token)
"the max number of tags is %d. Consider consolidating your tags or " \
"raise the max in Introspection.cake"
(type-cast (call-on size tags-tokens) int))
(return false))
(set (at next-free-tag-token tags-tokens) (deref annotation-token))
(set (field (at next-free-tag-token tags-tokens) type) TokenType_String)
(incr next-free-tag-token))))
;; Absorb the argument as part of this field
(set i possible-annotation-index))
(unless ignore-field ;; Build field metadata
(var name-to-string-token Token (deref name-token))
(set (field name-to-string-token type) TokenType_String)
(var possible-string-introspect-type (* (const char)) null)
(var core-type-token (* (const Token)) type-token)
(var core-type-token-index int type-token-index)
(var is-override-pointer bool false)
(var array-count-token (* (const Token)) null)
(when (= (path core-type-token > type) TokenType_OpenParen)
;; Strip off pointer to store core type
(when (and (std-str-equals (path (+ 1 core-type-token) > contents) "*")
;; Strings get their own special handling
(not (is-type-string tokens core-type-token-index
(addr possible-string-introspect-type))))
;; Require the user to provide an override to handle any pointers
(set override-field true)
;; Ensure that if this is an array of pointers, we're using the size of the pointer, not
;; the size of the element. If the size is needed, use the metadata-struct to get it
(set is-override-pointer true)
(set core-type-token-index (+ 2 core-type-token-index)) ;; skip (*. TODO Handle (* (const X))
(set core-type-token (addr (at core-type-token-index tokens))))
(when (and (std-str-equals (path (+ 1 core-type-token) > contents) "[]")
;; Exclude arrays of chars because they are handled like strings
(not (is-type-string tokens core-type-token-index
(addr possible-string-introspect-type))))
;; Count must be provided in struct definitions
(set array-count-token (+ 2 core-type-token))
;; Skip over array stuff so the basic type can be found
(var end-type-index int (FindCloseParenTokenIndex tokens core-type-token-index))
(var start-core-type-index int (getNextArgument tokens (+ 2 core-type-token-index) end-type-index))
(set core-type-token-index start-core-type-index)
(set core-type-token (addr (at core-type-token-index tokens)))))
(set possible-string-introspect-type null)
(var field-introspect-type Token (deref core-type-token))
(set (field field-introspect-type type) TokenType_Symbol)
(var determined-type-string (* (const char)) null)
(var type-is-string bool false)
(var field-type-metadata-from-core-type bool is-override-pointer)
(cond
(override-field
(set determined-type-string "introspect-type-override"))
((std-str-equals (path core-type-token > contents) "int")
(set determined-type-string "introspect-type-int"))
((std-str-equals (path core-type-token > contents) "float")
(set determined-type-string "introspect-type-float"))
((std-str-equals (path core-type-token > contents) "bool")
(set determined-type-string "introspect-type-bool"))
((std-str-equals (path core-type-token > contents) "char")
(set determined-type-string "introspect-type-char"))
((is-type-string tokens core-type-token-index (addr possible-string-introspect-type))
(set type-is-string true)
(set determined-type-string possible-string-introspect-type))
;; (true
;; (ErrorAtToken (deref core-type-token) "cannot generate metadata for unknown type")
;; (return false))
(true
;; TODO: Have cakelisp verify structures are introspectable at comptime rather than C++ at link time?
(set determined-type-string "introspect-type-introspect-struct")
(set field-type-metadata-from-core-type true)))
(set (field field-introspect-type contents) determined-type-string)
;; In the case of substructures or pointers to structures, they must be introspect structs in
;; order to be able to be handled correctly. Determine the metadata name here
;; TODO: Allow completely overridden pointers to structs which aren't introspect structs
(var field-type-metadata-token Token (deref core-type-token))
(set (field field-type-metadata-token type) TokenType_Symbol)
(call-on clear (field field-type-metadata-token contents))
(when field-type-metadata-from-core-type
(var type-metadata-pointer-name ([] 128 char) (array 0))
(introspect-metadata-pointer-name-from-struct-name
type-metadata-pointer-name (sizeof type-metadata-pointer-name)
(call-on c_str (path core-type-token > contents)))
(set (field field-type-metadata-token contents) type-metadata-pointer-name))
(var field-count Token (deref core-type-token))
(unless array-count-token
(set (field field-count type) TokenType_Symbol)
(set (field field-count contents) "0")
(set array-count-token (addr field-count)))
(var field-type-metadata-reference (<> (in std vector) Token))
(if (call-on empty (field field-type-metadata-token contents))
(tokenize-push field-type-metadata-reference null)
(tokenize-push field-type-metadata-reference
(token-splice-addr field-type-metadata-token)))
(var field-type-element-size (<> (in std vector) Token))
(cond
;; A somewhat special case: repurpose element-size where a fixed char array is one element
((= 0 (strcmp determined-type-string "introspect-type-fixed-size-string"))
(tokenize-push field-type-element-size (token-splice (+ 2 core-type-token))))
(type-is-string
(tokenize-push field-type-element-size (sizeof char)))
(is-override-pointer ;; Assume pointers are the same size
(tokenize-push field-type-element-size (sizeof (type (* void)))))
(true
(tokenize-push field-type-element-size (sizeof (type (token-splice core-type-token))))))
(tokenize-push (deref fields-metadata)
(array (token-splice-addr name-to-string-token)
(token-splice-addr field-introspect-type)
(token-splice-array field-type-metadata-reference)
(offsetof (type (token-splice struct-name)) (token-splice name-token))
(token-splice-array field-type-element-size)
(token-splice array-count-token)
(array (token-splice-array tags-tokens)))))
;; Output regular struct fields
(PushBackTokenExpression (deref processed-arguments) name-token)
(PushBackTokenExpression (deref processed-arguments) type-token))
;; Output metadata
(var metadata-name Token (deref struct-name))
(scope
(var metadata-name-buffer ([] 128 char) (array 0))
(introspect-metadata-name-from-struct-name
metadata-name-buffer (sizeof metadata-name-buffer)
(call-on c_str (path struct-name > contents)))
(set (field metadata-name contents) metadata-name-buffer))
(var metadata-pointer-name Token (deref struct-name))
(scope
(var metadata-pointer-name-buffer ([] 128 char) (array 0))
(introspect-metadata-pointer-name-from-struct-name
metadata-pointer-name-buffer (sizeof metadata-pointer-name-buffer)
(call-on c_str (path struct-name > contents)))
(set (field metadata-pointer-name contents) metadata-pointer-name-buffer))
(var metadata-fields-name Token (deref struct-name))
(scope
(var metadata-fields-name-buffer ([] 128 char) (array 0))
(PrintfBuffer metadata-fields-name-buffer "%s--metadata-fields"
(call-on c_str (path struct-name > contents)))
(set (field metadata-fields-name contents) metadata-fields-name-buffer))
(var struct-name-to-str Token (deref struct-name))
(set (field struct-name-to-str type) TokenType_String)
;; TODO: global vs. local
(tokenize-push output
(defstruct (token-splice struct-name)
(token-splice-array (deref processed-arguments)))
(var (token-splice-addr metadata-fields-name) ([] metadata-field)
(array (token-splice-array (deref fields-metadata))))
(var (token-splice-addr metadata-name) metadata-struct
(array (token-splice-addr struct-name-to-str)
(token-splice-addr metadata-fields-name)
(array-size (token-splice-addr metadata-fields-name))
(sizeof (type (token-splice struct-name)))))
;; Allow access to the metadata without having to declare all the types in the header
(forward-declare (struct metadata-struct)) ;; TODO Would be nice to not do this for every struct
(var-global (token-splice-addr metadata-pointer-name) (* (const metadata-struct))
(addr (token-splice-addr metadata-name))))
(return true))
;; TODO: This is a limitation of not being able to declare and reference new types in comptime
(defmacro introspect-override-define-types ()
(tokenize-push output
(defstruct introspect-override-handler
handler-type (* (const char))
override-function-name Token
function-signature (<> (in std vector) Token)
function-invocation (<> (in std vector) Token)
on-override-missing (<> (in std vector) Token)
registered-handlers (<> (in std unordered_map)
(* (const Token)) ;; Handler name
(* (const Token))) ;; Condition to invoke this handler
num-installed int)
(defstruct introspect-override-state
handlers-by-type (<> (in std vector) introspect-override-handler)))
(return true))
(defun-comptime destroy-introspect-override-state (data (* void))
(introspect-override-define-types)
(delete (type-cast data (* introspect-override-state))))
;; Must return void because types cannot be defined in comptime
(defun-comptime create-introspect-override-state (environment (& EvaluatorEnvironment)
state-out (* (* void))
;; Needs to return bool only because tokenize-push
&return bool)
(set (deref state-out) null)
(introspect-override-define-types)
(var overrides-state (* introspect-override-state) (new introspect-override-state))
(unless (CreateCompileTimeVariable environment
"introspect-override-handlers" "(* introspect-override-state)"
(type-cast overrides-state (* void))
"destroy-introspect-override-state")
(delete overrides-state)
(return false))
;; By setting -1, we ensure the override handler functions are generated even if none are
;; registered, to make sure everything still compiles
(var start-num-installed-sentinel int -1)
(scope
(var handler introspect-override-handler)
(set (field handler handler-type) "'write-s-expr")
(set (field handler override-function-name type) TokenType_Symbol)
(set (field handler override-function-name source) "Introspection.cake")
(set (field handler override-function-name contents)
"write-s-expr-handle-override")
(tokenize-push (field handler function-signature)
(struct-metadata (* (const metadata-struct))
field (* (const metadata-field))
struct-to-write (* (const void))
value-offset size_t
out-file (* FILE)
write-options write-introspect-struct-options
&return bool))
(tokenize-push (field handler function-invocation)
struct-metadata
field
struct-to-write
value-offset
out-file
write-options)
(tokenize-push (field handler on-override-missing) (return false))
(set (field handler num-installed) start-num-installed-sentinel)
(call-on push_back (path overrides-state > handlers-by-type)
(call (in std move) handler)))
(scope
(var handler introspect-override-handler)
(set (field handler handler-type) "'read-s-expr")
(set (field handler override-function-name type) TokenType_Symbol)
(set (field handler override-function-name source) "Introspection.cake")
(set (field handler override-function-name contents)
"read-s-expr-handle-override")
(tokenize-push (field handler function-signature)
(struct-metadata (* (const metadata-struct))
field (* (const metadata-field))
struct-out (* void)
value-offset size_t
value-argument-start (* (const char))
string-allocate allocate-string-function
&return bool))
(tokenize-push (field handler function-invocation)
struct-metadata
field
struct-out
value-offset
value-argument-start
string-allocate)
(tokenize-push (field handler on-override-missing) (return false))
(set (field handler num-installed) start-num-installed-sentinel)
(call-on push_back (path overrides-state > handlers-by-type)
(call (in std move) handler)))
(scope
(var handler introspect-override-handler)
(set (field handler handler-type) "'compare")
(set (field handler override-function-name type) TokenType_Symbol)
(set (field handler override-function-name source) "Introspection.cake")
(set (field handler override-function-name contents)
"compare-introspect-field-handle-override")
(tokenize-push (field handler function-signature)
(struct-metadata (* (const metadata-struct))
field (* (const metadata-field))
struct-a (* void)
struct-b (* void)
value-offset size_t
dispatch-value-index size_t
print-difference bool
&return int))
(tokenize-push (field handler function-invocation)
struct-metadata
field
struct-a
struct-b
value-offset
dispatch-value-index
print-difference)
(tokenize-push (field handler on-override-missing) (return -1))
(set (field handler num-installed) start-num-installed-sentinel)
(call-on push_back (path overrides-state > handlers-by-type)
(call (in std move) handler)))
(scope
(var handler introspect-override-handler)
(set (field handler handler-type) "'copy")
(set (field handler override-function-name type) TokenType_Symbol)
(set (field handler override-function-name source) "Introspection.cake")
(set (field handler override-function-name contents)
"copy-introspect-field-handle-override")
(tokenize-push (field handler function-signature)
(struct-metadata (* (const metadata-struct))
field (* (const metadata-field))
struct-dest (* void)
struct-src (* void)
value-offset size_t
dispatch-value-index size_t
string-allocate allocate-string-function
&return bool))
(tokenize-push (field handler function-invocation)
struct-metadata
field
struct-dest
struct-src
value-offset
dispatch-value-index
string-allocate)
(tokenize-push (field handler on-override-missing) (return false))
(set (field handler num-installed) start-num-installed-sentinel)
(call-on push_back (path overrides-state > handlers-by-type)
(call (in std move) handler)))
(scope
(var handler introspect-override-handler)
(set (field handler handler-type) "'free")
(set (field handler override-function-name type) TokenType_Symbol)
(set (field handler override-function-name source) "Introspection.cake")
(set (field handler override-function-name contents)
"free-introspect-field-handle-override")
(tokenize-push (field handler function-signature)
(struct-metadata (* (const metadata-struct))
field (* (const metadata-field))
struct-to-destroy (* void)
value-offset size_t
dispatch-value-index size_t
string-free free-string-function))
(tokenize-push (field handler function-invocation)
struct-metadata
field
struct-to-destroy
value-offset
dispatch-value-index
string-free)
(tokenize-push (field handler on-override-missing) (ignore))
(set (field handler num-installed) start-num-installed-sentinel)
(call-on push_back (path overrides-state > handlers-by-type)
(call (in std move) handler)))
(set (deref state-out) (type-cast overrides-state (* void)))
(return true))
;; Replaced by introspect-overrides-install
(defun-local read-s-expr-handle-override ())
(defun-local write-s-expr-handle-override ())
(defun-local compare-introspect-field-handle-override ())
(defun-local copy-introspect-field-handle-override ())
(defun-local free-introspect-field-handle-override ())
(defun-comptime introspect-override-get-handler-by-type (environment (& EvaluatorEnvironment)
handler-type (* (const char))
handler-out (* (* void))
&return bool)
(introspect-override-get-shared-variables)
(for-in handler-by-type (& introspect-override-handler) (path overrides-state > handlers-by-type)
(when (= 0 (strcmp (field handler-by-type handler-type) handler-type))
(set (deref handler-out) (type-cast (addr handler-by-type) (* void)))
(return true)))
(return false))
;; I'm not super pleased with this, but it's important these don't get out of sync
(defmacro introspect-override-get-shared-variables ()
(tokenize-push output
(introspect-override-define-types)
(var overrides-state (* introspect-override-state) null)
;; Don't use get-or-create-comptime-var because it'll have a hard time with our custom type
(unless (GetCompileTimeVariable environment "introspect-override-handlers"
"(* introspect-override-state)"
(type-cast (addr overrides-state) (* (* void))))
(unless (create-introspect-override-state environment
(type-cast (addr overrides-state) (* (* void))))
(return false))))
(return true))
(defmacro introspect-override-invocation-args (handler-type symbol)
(introspect-override-get-shared-variables)
(var handler (* introspect-override-handler) null)
(introspect-override-get-handler-by-type environment
(call-on c_str (path handler-type > contents))
(type-cast (addr handler) (* (* void))))
(unless handler
(return false))
(tokenize-push output
(token-splice-array (path handler > function-invocation)))
(return true))
;; Any field overrides are handled via defining a custom function which will be called handler-name
;; with body handler-body. This handler will be called if condition is true for a field already
;; marked as introspect-type-override.
;; operation is one of the symbols defined in the topmost cond block of this macro
(defmacro introspect-override-register-handler (operation symbol
condition any
handler-name symbol ;; Will be created
&rest handler-body any)
(introspect-override-get-shared-variables)
(var handler (* introspect-override-handler) null)
(introspect-override-get-handler-by-type environment
(call-on c_str (path operation > contents))
(type-cast (addr handler) (* (* void))))
(unless handler
(ErrorAtToken (deref operation)
"expected operation to be one of the following symbols:")
(for-in handler-by-type (& introspect-override-handler) (path overrides-state > handlers-by-type)
(Logf "\t%s\n" (field handler-by-type handler-type)))
(return false))
(set (at handler-name (path handler > registered-handlers)) condition)
(tokenize-push output
(defun-nodecl (token-splice handler-name)
(token-splice-array (path handler > function-signature))
(token-splice-rest handler-body tokens)))
(return true))
(defun-comptime sorted-handler-comparison (a (& (const (* (<> (in std pair)
(const (* (const Token)))
(* (const Token))))))
b (& (const (* (<> (in std pair)
(const (* (const Token)))
(* (const Token))))))
&return bool)
(return (> 0 (call-on compare (path a > first > contents)
(path b > first > contents)))))
;; The linker will handle finding the actual functions. This is nice because we don't need to worry
;; about including anything the implementations need
(defun-comptime introspect-overrides-install (environment (& EvaluatorEnvironment)
was-code-modified (& bool)
&return bool)
(introspect-override-get-shared-variables)
(for-in handler-by-type (& introspect-override-handler) (path overrides-state > handlers-by-type)
;; (Logf "Handler %s installed %d registered: %d\n" (field handler-by-type handler-type)
;; (type-cast (field handler-by-type num-installed) int)
;; (type-cast (call-on size (field handler-by-type registered-handlers)) int))
;; Already handled in a previous pass
;; We need to do it at least once to write the proper signature; by setting num-installed to -1
;; as the starting value, we ensure even with no registered handlers, they will get signatures
;; generated, which is important to compilation
(when (= (call-on size (field handler-by-type registered-handlers))
(field handler-by-type num-installed))
(continue))
;; We used unordered_map, which due to not being ordered, causes unnecessary recompilation due
;; to not being deterministic between runs (which I assume is for security in case an attacker
;; wants to manipulate the data order). I'd rather do this than introduce std::map for now
(var sorted-handlers (<> (in std vector) (* (<> (in std pair)
(const (* (const Token)))
(* (const Token))))))
(for-in handler-cond-pair (& (<> (in std pair) (const (* (const Token)))
(* (const Token))))
(field handler-by-type registered-handlers)
(call-on push_back sorted-handlers (addr handler-cond-pair)))
;; TODO: This is a HACK: Invoke the sort function once so it's registered as a reference on
;; this definition, which will pull it into the comptime compilation
(unless (call-on empty (field handler-by-type registered-handlers))
(sorted-handler-comparison (deref (call-on begin sorted-handlers))
(deref (call-on begin sorted-handlers)))
(call (in std sort) (call-on begin sorted-handlers)
(call-on end sorted-handlers) sorted-handler-comparison))
(var handler-forward-declare-tokens (<> (in std vector) Token))
(var handler-cond-tokens (<> (in std vector) Token))
(for-in handler-cond-pair (* (<> (in std pair) (const (* (const Token)))
(* (const Token))))
sorted-handlers
;; Let the compiler know we expect to get the handler during linking
(tokenize-push handler-forward-declare-tokens
(declare-extern-function (token-splice (path handler-cond-pair > first))
(token-splice-array (field handler-by-type function-signature))))
(tokenize-push handler-cond-tokens
;; Condition
((token-splice (path handler-cond-pair > second))
;; Invocation
(return ((token-splice (path handler-cond-pair > first))
(token-splice-array (field handler-by-type function-invocation)))))))
(var handler-amalgamation (* (<> std::vector Token)) (new (<> std::vector Token)))
;; Environment will handle freeing tokens for us
(call-on push_back (field environment comptimeTokens) handler-amalgamation)
;; Give the cond something to chew on in the empty state
(when (call-on empty handler-cond-tokens)
(tokenize-push handler-cond-tokens
(true (fprintf stderr "warning: no overrides registered\n"))))
(var handler-type-string-token Token)
(set (field handler-type-string-token type) TokenType_String)
(set (field handler-type-string-token source) "Introspection.cake")
(set (field handler-type-string-token contents)
(field handler-by-type handler-type))
(tokenize-push (deref handler-amalgamation)
(token-splice-array handler-forward-declare-tokens)
(defun-local (token-splice-addr (field handler-by-type override-function-name))
(token-splice-array (field handler-by-type function-signature))
(cond
(token-splice-array handler-cond-tokens))
(fprintf stderr "error: override for struct \"%s\" field \"%s\" not handled. You need to
define a %s handler for this field via introspect-override-register-handler\n"
(path struct-metadata > name) (path field > name)
(token-splice-addr handler-type-string-token))
(token-splice-array (field handler-by-type on-override-missing))))
;; (prettyPrintTokens (deref handler-amalgamation))
(unless (ReplaceAndEvaluateDefinition
environment
(call-on c_str (field handler-by-type override-function-name contents))
(deref handler-amalgamation))
(return false))
(set was-code-modified true)
;; Track that we have installed these, preventing post-references-resolved loops
(set (field handler-by-type num-installed)
(call-on size (field handler-by-type registered-handlers))))
(return true))
(add-compile-time-hook post-references-resolved introspect-overrides-install)
;;
;; Types
;;
(defenum introspect-type
introspect-type-override ;; Use custom callbacks when operating on this type
introspect-type-int
introspect-type-float
introspect-type-bool
introspect-type-char
introspect-type-string
introspect-type-fixed-size-string
;; Recurse into the substruct
introspect-type-introspect-struct)
;; Gross, but necessary so the structs can refer to each other
(forward-declare (struct MetadataField)
(struct MetadataStruct))
(defstruct metadata-field
name (* (const char))
type introspect-type
field-type-metadata (* (const metadata-struct))
offset size_t
element-size size_t
count size_t ;; For arrays
tags ([] 2 (* (const char))))
(defstruct metadata-struct
name (* (const char))
;; type introspect-struct-type ;; Almost always field-by-field, but TODO let them override the whole process
members (* (const metadata-field))
num-members size_t
struct-size size_t)
;;
;; Runtime
;;
(defmacro offset-pointer-to-type (start-address any offset-bytes any desired-type any)
(tokenize-push output
(type-cast (+ (type-cast (token-splice start-address) (* char))
(token-splice offset-bytes))
(token-splice desired-type)))
(return true))
;; This isn't ideal, but I did want to eliminate the need to branch repeatedly on the same field's
;; type. So, we'll create a separate for loop for each type
(defmacro introspect-field-dispatch (field-pointer any
offset-out symbol &rest per-value-body any)
(tokenize-push output
(each-in-range (? (path (token-splice field-pointer) > count)
(path (token-splice field-pointer) > count)
1)
dispatch-value-index
(var (token-splice offset-out) size_t
(+ (* dispatch-value-index
(path (token-splice field-pointer) > element-size))
(path (token-splice field-pointer) > offset)))
(token-splice-rest per-value-body tokens)))
(return true))
;; Helper function for overrides
(defun metadata-field-has-tag (field (* (const metadata-field))
tag (* (const char))
&return bool)
(each-in-array (path field > tags) i
(when (and (at i (path field > tags))
(= 0 (strcmp (at i (path field > tags)) tag)))
(return true)))
(return false))
(defun-local bool-to-string (value bool &return (* (const char)))
(return (? value "true" "false")))
;; TODO: Change this to be flags enum
(defenum write-introspect-struct-options
write-introspect-struct-default
write-introspect-struct-add-newline)
;; TODO Escape quotes, newlines, etc.
(defun write-introspect-struct-s-expr (struct-metadata (* (const metadata-struct))
struct-to-write (* (const void))
out-file (* FILE)
write-options write-introspect-struct-options
&return bool)
(fprintf out-file "(%s" (path struct-metadata > name))
(each-in-range (path struct-metadata > num-members) i
(var field (* (const metadata-field)) (addr (at i (path struct-metadata > members))))
(fprintf out-file " :%s" (path field > name))
(when (path field > count)
(fprintf out-file " (array"))
(cond
;; Numeric and boolean types
((= (path field > type) introspect-type-int)
(introspect-field-dispatch field value-offset
(var int-write (* int)
(offset-pointer-to-type struct-to-write value-offset (* int)))
(fprintf out-file " %d" (deref int-write))))
((= (path field > type) introspect-type-float)
(introspect-field-dispatch field value-offset
(var float-write (* float)
(offset-pointer-to-type struct-to-write value-offset (* float)))
(fprintf out-file " %f" (deref float-write))))
((= (path field > type) introspect-type-bool)
(introspect-field-dispatch field value-offset
(var bool-write (* bool)
(offset-pointer-to-type struct-to-write value-offset (* bool)))
(fprintf out-file " %s" (bool-to-string (deref bool-write)))))
((= (path field > type) introspect-type-char)
(var char-write (* char)
(offset-pointer-to-type struct-to-write (path field > offset) (* char)))
;; Write chars as integers to avoid writing e.g. '\0' in text
(fprintf out-file " %d" (deref char-write)))
;; Strings
((= (path field > type) introspect-type-fixed-size-string)
(introspect-field-dispatch field value-offset
(var str-write (* (const char))
(offset-pointer-to-type struct-to-write value-offset (* (const char))))
;; TODO: This will require quoting any '"' in the string (etc.)
(fprintf out-file " \"%s\"" (? str-write str-write ""))))
((= (path field > type) introspect-type-string)
(introspect-field-dispatch field value-offset
(var str-write (* (* (const char)))
(offset-pointer-to-type struct-to-write value-offset (* (* (const char)))))
;; TODO: This will require quoting any '"' in the string (etc.)
(fprintf out-file " \"%s\"" (? (deref str-write) (deref str-write) ""))))
;; TODO: Add indentation for substructs to improve readability
((= (path field > type) introspect-type-introspect-struct)
(introspect-field-dispatch field value-offset
(var substruct-write (* void)
(offset-pointer-to-type struct-to-write value-offset (* void)))
(fprintf out-file " ")
(write-introspect-struct-s-expr (path field > field-type-metadata)
substruct-write out-file
write-introspect-struct-default)))
((= (path field > type) introspect-type-override)
(introspect-field-dispatch field value-offset
(unless (write-s-expr-handle-override (introspect-override-invocation-args 'write-s-expr))
(return false))))
(true
;; (fprintf out-file " <unknown>")
(fprintf stderr "error: attempted to write field of unknown type %d\n" (path field > type))
(return false)))
(when (path field > count)
(fprintf out-file ")"))
(when (< i (- (path struct-metadata > num-members) 1))
(fprintf out-file "\n")))
(fprintf out-file ")")
(when (= write-options write-introspect-struct-add-newline)
(fprintf out-file "\n"))
(return true))
(def-function-signature-global allocate-string-function (num-bytes size_t &return (* void)))
(def-function-signature-global free-string-function (string-to-free (* void)))
(defun print-string-range (start (* (const char))
end (* (const char))
add-newline bool)
(each-in-range (- end start) char-index
(fprintf stderr "%c" (at char-index start)))
(when add-newline
(fprintf stderr "\n")))
(defun-local set-metadata-field-from-string (struct-metadata (* (const metadata-struct))
field (* (const metadata-field))
struct-out (* void)
value-offset size_t
in-string (* (const char)) value-length size_t
string-allocate allocate-string-function
&return bool)
(cond
;; Numeric and boolean types
((= (path field > type) introspect-type-int)
(var int-write (* int)
(offset-pointer-to-type struct-out value-offset (* int)))
(set (deref int-write) (atoi in-string)))
((= (path field > type) introspect-type-float)
(var float-write (* float)
(offset-pointer-to-type struct-out value-offset (* float)))
(set (deref float-write) (atof in-string)))
((= (path field > type) introspect-type-bool)
(var bool-write (* bool)
(offset-pointer-to-type struct-out value-offset (* bool)))
(cond ((= 0 (strcmp "true" in-string))
(set (deref bool-write) true))
((= 0 (strcmp "false" in-string))
(set (deref bool-write) false))
(true
(fprintf stderr "error: failed to parse true or false for boolean. Got ")
(print-string-range in-string (+ in-string value-length) true)
(return false))))
((= (path field > type) introspect-type-char)
(var char-write (* char)
(offset-pointer-to-type struct-out value-offset (* char)))
;; Write chars as integers to avoid writing e.g. '\0' in text
(set (deref char-write) (type-cast (atoi in-string) char)))
;; Strings
((= (path field > type) introspect-type-fixed-size-string)
(var str-write (* char)
(offset-pointer-to-type struct-out value-offset (* char)))
(when (>= value-length (path field > element-size))
(fprintf stderr "error: struct %s field %s has length %d, which cannot fit value of length %d" \
" and a null terminator. Value: "
(path struct-metadata > name)
(path field > name)
(type-cast (path field > element-size) int)
(type-cast value-length int))
(print-string-range in-string (+ in-string value-length) true)
(return false))
(strncpy str-write in-string value-length)
;; Ensure null terminator gets written
(set (at value-length str-write) 0))
((= (path field > type) introspect-type-string)
;; Don't allocate for empty strings
(unless value-length
(return true))
(var str-write (* (* (const char)))
(offset-pointer-to-type struct-out value-offset (* (* (const char)))))
(var-cast-to copied-string (* char) (string-allocate (+ 1 value-length)))
(strncpy copied-string in-string value-length)
(set (at value-length copied-string) 0)
(set (deref str-write) copied-string))
;; Nested introspectable structs
((= (path field > type) introspect-type-introspect-struct)
(var substruct-out (* void)
(offset-pointer-to-type struct-out value-offset (* void)))
(return (read-introspect-struct-s-expr (path field > field-type-metadata)
substruct-out
in-string
string-allocate
;; Why can this be null? Because in a valid S-expression
;; file, our parent should be able to find the number of
;; characters read via scanning and counting parentheses
null)))
(true
(fprintf stderr "error: do not know how to parse field '%s' with type %d from string \"%s\"\n"
(path field > name) (path field > type) in-string)
(return false)))
(return true))
;; Does the extra checks needed to handle escaped double quotes
(defun-local is-end-of-string (char-in-string (* (const char)) &return bool)
(return (and (= '\"' (deref char-in-string))
(!= '\\' (deref (- char-in-string 1)))
;; Handle strings which end in backslash: "\\"
(!= '\\' (deref (- char-in-string 2))))))
;; Hack to avoid Emacs getting confused by ')'
(var close-paren (const char) (at 0 ")"))
(defun s-expr-get-next-argument-start-end (in-string (* (const char))
start-out (* (* (const char)))
end-out (* (* (const char))))
(set (deref start-out) null)
(set (deref end-out) null)
(defenum read-state
find-start
find-end
find-end-string
find-end-paren
find-end-paren-ignoring-string)
(var state read-state find-start)
(var num-parens int 0)
(each-char-in-string-const in-string current-char
(cond
((= state find-start)
(cond
((isspace (deref current-char))
(continue))
;; Escape character added for emacs paren detection; otherwise unnecessary
((= '\(' (deref current-char))
;; We encountered the first paren, so count it here
(set num-parens 1)
(set state find-end-paren)
(set (deref start-out) current-char))
((= '\"' (deref current-char))
(set state find-end-string)
(set (deref start-out) current-char))
((= close-paren (deref current-char))
;; End of arguments
(break))
(true
(set state find-end)
(set (deref start-out) current-char))))
((= state find-end)
(when (or (= (deref current-char) close-paren)
(isspace (deref current-char)))
(set (deref end-out) current-char)
(break)))
((= state find-end-string)
(when (is-end-of-string current-char)
(set (deref end-out) (+ 1 current-char))
(break)))
((= state find-end-paren-ignoring-string)
(when (is-end-of-string current-char)
(set state find-end-paren)))
((= state find-end-paren)
(cond
;; Escape character added for emacs paren detection; otherwise unnecessary
((= '\(' (deref current-char))
(incr num-parens))
;; Ensure strings don't confuse us in case they have parentheses within them
((= '\"' (deref current-char))
(set state find-end-paren-ignoring-string))
((= close-paren (deref current-char))
(decr num-parens)
(unless num-parens
(set (deref end-out) (+ 1 current-char))
(break))))))))
;; characters-read-out signals the end of this struct, which enables many potentially different
;; structs to be in the same file, one after another. null is okay if you don't care
(defun read-introspect-struct-s-expr (struct-metadata (* (const metadata-struct))
struct-out (* void)
in-string (* (const char))
string-allocate allocate-string-function
characters-read-out (* (unsigned int))
&return bool)
(when characters-read-out
(set (deref characters-read-out) 0))
;; Find the start of the struct; validates we are parsing the struct we expect via checking the
;; type name after the first opening paren
(var struct-member-start (* (const char)) null)
(var struct-name-length size_t (strlen (path struct-metadata > name)))
(each-char-in-string-const in-string current-char
(when (isspace (deref current-char))
(continue))
;; Escape character added for emacs paren detection; otherwise unnecessary
(when (= '\(' (deref current-char))
(unless (and (= 0 (strncmp (+ 1 current-char) (path struct-metadata > name)
struct-name-length))
(or (= ' ' (at (+ 1 struct-name-length) current-char))
(= '\n' (at (+ 1 struct-name-length) current-char))))
(fprintf stderr "error: failed to read struct %s from string" \
" (struct type name does not match): \"%s\"\n"
(path struct-metadata > name) (+ 1 current-char))
(return false))
(set struct-member-start (+ current-char struct-name-length 1))
(break)))
(unless struct-member-start
(fprintf stderr "error: failed to read struct %s from string (start not found): {%s}\n"
(path struct-metadata > name) in-string)
(return false))
;; TODO: Validate the entire struct is read in via checking the parens match
(defenum read-state
state-search-for-member-name
state-read-member-name
state-search-for-member-value
state-reading-member-value
state-reading-member-value-string
state-reading-member-value-paren)
(var state read-state state-search-for-member-name)
(var current-symbol-buffer ([] 1024 char) (array 0))
(var current-symbol-write (* char) current-symbol-buffer)
(var current-field (* (const metadata-field)) null)
(set state state-read-member-name)
(var argument-start (* (const char)) null)
(var argument-end (* (const char)) null)
(var last-valid-argument-end (* (const char)) null)
(var current-char (* (const char)) struct-member-start)
(s-expr-get-next-argument-start-end current-char (addr argument-start) (addr argument-end))
(while (and argument-start argument-end)
;; (fprintf stderr "argument: '")
;; (print-string-range argument-start argument-end false)
;; (fprintf stderr "'\n")
(set last-valid-argument-end argument-end)
(cond
((= state state-read-member-name)
(unless (= (deref argument-start) ':')
(fprintf stderr "error: expected field name to start with ':', got ")
(print-string-range argument-start argument-end true)
(return false))
(incr argument-start) ;; Absorb the : prefix
(var found-field bool false)
(each-in-range (path struct-metadata > num-members) i
(var field (* (const metadata-field)) (addr (at i (path struct-metadata > members))))
(var field-name-length size_t (strlen (path field > name)))
(when (and (= 0 (strncmp (path field > name) argument-start field-name-length))
(= argument-end (+ argument-start field-name-length)))
(set current-field field)
(set found-field true)
(break)))
(unless found-field
(fprintf stderr "error: encountered unknown field named ")
(print-string-range argument-start argument-end true)
(return false))
(set state state-reading-member-value))
;; TODO: This needs more validation
((= state state-reading-member-value)
(var value-argument-start (* (const char)) argument-start)
(var value-argument-end (* (const char)) argument-end)
(when (path current-field > count) ;; Handle (array)
(var array-keyword-length int 6) ;; Length of "array "
(when (!= 0 (strncmp (+ 1 argument-start) "array " array-keyword-length))
(fprintf stderr "error: expected (array) for field %s, got "
(path current-field > name))
(print-string-range argument-start argument-end true)
(return false))
;; Skip into (array)
(s-expr-get-next-argument-start-end (+ 1 array-keyword-length value-argument-start)
(addr value-argument-start)
(addr value-argument-end)))
(introspect-field-dispatch current-field value-offset
(var value-length size_t (- value-argument-end value-argument-start))
(var field (* (const metadata-field)) current-field)
(cond
((= (path field > type) introspect-type-override)
(read-s-expr-handle-override (introspect-override-invocation-args 'read-s-expr)))
((= (deref value-argument-start) '\"') ;; Strings
(unless (set-metadata-field-from-string struct-metadata
current-field struct-out
value-offset
;; Trim the open and close quotes
(+ 1 value-argument-start)
(- value-argument-end 1 (+ 1 value-argument-start))
string-allocate)
(return false)))
((= (deref value-argument-start) '\(') ;; Nested structures
(unless (set-metadata-field-from-string struct-metadata
current-field struct-out
value-offset
value-argument-start value-length
string-allocate)
(return false)))
(true ;; Basic types
(var basic-type-buffer ([] 64 char) (array 0))
(when (> value-length (array-size basic-type-buffer))
(fprintf stderr "error: failed to copy basic type of size %d into buffer of size %d from value "
(type-cast value-length int) (type-cast (array-size basic-type-buffer) int))
(print-string-range value-argument-start value-argument-end true)
(return false))
(memcpy basic-type-buffer value-argument-start value-length)
(unless (set-metadata-field-from-string struct-metadata
current-field struct-out
value-offset
basic-type-buffer value-length
string-allocate)
(return false))))
(when (and (path current-field > count)
(< dispatch-value-index (- (path current-field > count) 1)))
(s-expr-get-next-argument-start-end value-argument-end (addr value-argument-start)
(addr value-argument-end))
;; (print-string-range value-argument-start value-argument-end true)
(unless (and value-argument-start value-argument-end)
(fprintf stderr "error: field %s expected %d elements but found only %d\n"
(path current-field > name) (type-cast (path current-field > count) int)
dispatch-value-index)
(return false))))
(set state state-read-member-name)))
(s-expr-get-next-argument-start-end argument-end (addr argument-start) (addr argument-end)))
(when characters-read-out
(set (deref characters-read-out)
;; Add one to eat the final closing paren
(+ 1 (type-cast (- last-valid-argument-end in-string)
(unsigned int)))))
(return true))
(defun free-introspect-struct-fields (struct-metadata (* (const metadata-struct))
struct-to-destroy (* void)
string-free free-string-function)
(each-in-range (path struct-metadata > num-members) i
(var field (* (const metadata-field)) (addr (at i (path struct-metadata > members))))
(cond
((= (path field > type) introspect-type-string)
(introspect-field-dispatch field value-offset
(var str-write (* (* char))
(offset-pointer-to-type struct-to-destroy value-offset (* (* char))))
(when (deref str-write)
(string-free (deref str-write))
(set (deref str-write) null))))
((= (path field > type) introspect-type-introspect-struct)
(introspect-field-dispatch field value-offset
(var substruct (* void)
(offset-pointer-to-type struct-to-destroy value-offset (* void)))
(free-introspect-struct-fields (path field > field-type-metadata)
substruct
string-free)))
((= (path field > type) introspect-type-override)
(introspect-field-dispatch field value-offset
(free-introspect-field-handle-override
(introspect-override-invocation-args 'free)))))))
(var introspect-floating-point-compare-tolerance (const float) 0.00001f)
;; TODO: Make const correct
(defun compare-introspect-struct-internal (struct-metadata (* (const metadata-struct))
struct-a (* void)
struct-b (* void)
print-difference bool
&return int)
(each-in-range (path struct-metadata > num-members) i
(var field (* (const metadata-field)) (addr (at i (path struct-metadata > members))))
(cond
;; Numeric and boolean types
((= (path field > type) introspect-type-int)
(introspect-field-dispatch field value-offset
(var int-a (* int)
(offset-pointer-to-type struct-a value-offset (* int)))
(var int-b (* int)
(offset-pointer-to-type struct-b value-offset (* int)))
(when (!= (deref int-a) (deref int-b))
(when print-difference
(fprintf stderr "structs differ by field '%s' [%d] (%d vs %d)\n"
(path field > name)
dispatch-value-index
(deref int-a) (deref int-b)))
(return (- int-a int-b)))))
((= (path field > type) introspect-type-float)
(introspect-field-dispatch field value-offset
(var float-a (* float)
(offset-pointer-to-type struct-a value-offset (* float)))
(var float-b (* float)
(offset-pointer-to-type struct-b value-offset (* float)))
(when (> (- (deref float-a) (deref float-b))
introspect-floating-point-compare-tolerance)
(when print-difference
(fprintf stderr "structs differ by field '%s' [%d] (%f vs %f)\n"
(path field > name)
dispatch-value-index
(deref float-a) (deref float-b)))
(return (- float-a float-b)))))
((= (path field > type) introspect-type-bool)
(introspect-field-dispatch field value-offset
(var bool-a (* bool)
(offset-pointer-to-type struct-a value-offset (* bool)))
(var bool-b (* bool)
(offset-pointer-to-type struct-b value-offset (* bool)))
(when (!= (deref bool-a) (deref bool-b))
(when print-difference
(fprintf stderr "structs differ by field '%s' [%d] (%s vs %s)\n"
(path field > name)
dispatch-value-index
(bool-to-string (deref bool-a)) (bool-to-string (deref bool-b))))
(return (? bool-a 1 -1)))))
((= (path field > type) introspect-type-char)
(var char-a (* char)
(offset-pointer-to-type struct-a (path field > offset) (* char)))
(var char-b (* char)
(offset-pointer-to-type struct-b (path field > offset) (* char)))
;; Write chars as integers to avoid writing e.g. '\0' in text
(when (!= (deref char-a) (deref char-b))
(when print-difference
(fprintf stderr "structs differ by field '%s' (%c vs %c)\n"
(path field > name)
(deref char-a) (deref char-b)))
(return (- char-a char-b))))
;; Strings
((= (path field > type) introspect-type-fixed-size-string)
(introspect-field-dispatch field value-offset
(var str-a (* (const char))
(offset-pointer-to-type struct-a value-offset (* (const char))))
(var str-b (* (const char))
(offset-pointer-to-type struct-b value-offset (* (const char))))
(var result int (strcmp str-a str-b))
(when (!= 0 result)
(when print-difference
(fprintf stderr "structs differ by field '%s' [%d] (%s vs %s)\n"
(path field > name)
dispatch-value-index
str-a str-b))
(return result))))
((= (path field > type) introspect-type-string)
(introspect-field-dispatch field value-offset
(var str-a (* (* (const char)))
(offset-pointer-to-type struct-a value-offset (* (* (const char)))))
(var str-b (* (* (const char)))
(offset-pointer-to-type struct-b value-offset (* (* (const char)))))
(var-cast-to result int 0)
(if (and (deref str-a)
(deref str-b))
(set result (strcmp (deref str-a) (deref str-b)))
;; One or both of the strings is null, so we can't strcmp
(cond
((deref str-a)
(set result -1))
((deref str-b)
(set result 1))
(true
(set result 0))))
(when (!= 0 result)
(when print-difference
(fprintf stderr "structs differ by field '%s' [%d] ('%s' vs '%s')\n"
(path field > name)
dispatch-value-index
(deref str-a) (deref str-b)))
(return result))))
;; Nested introspectable structs
((= (path field > type) introspect-type-introspect-struct)
(introspect-field-dispatch field value-offset
(var substruct-a (* void)
(offset-pointer-to-type struct-a value-offset (* void)))
(var substruct-b (* void)
(offset-pointer-to-type struct-b value-offset (* void)))
(var return-value int
(compare-introspect-struct-internal (path field > field-type-metadata)
substruct-a
substruct-b
print-difference))
(when (!= 0 return-value)
(when print-difference (fprintf stderr "structs differ by substruct in field %s\n" (path field > name)))
(return return-value))))
((= (path field > type) introspect-type-override)
(introspect-field-dispatch field value-offset
(var result int
(compare-introspect-field-handle-override (introspect-override-invocation-args 'compare)))
(when (!= 0 result)
(return result))))
(true
(fprintf stderr "error: do not know how to parse field '%s' with type %d\n"
(path field > name) (path field > type))
(return -1))))
(return 0))
(defun compare-introspect-struct (struct-metadata (* (const metadata-struct))
struct-a (* void)
struct-b (* void)
&return int)
(return (compare-introspect-struct-internal
struct-metadata
struct-a
struct-b
false)))
(defun introspect-struct-= (struct-metadata (* (const metadata-struct))
struct-a (* void)
struct-b (* void)
&return bool)
(return (= 0 (compare-introspect-struct-internal
struct-metadata
struct-a
struct-b
false))))
(defun compare-introspect-struct-print-result (struct-metadata (* (const metadata-struct))
struct-a (* void)
struct-b (* void)
&return int)
(return (compare-introspect-struct-internal
struct-metadata
struct-a
struct-b
true)))
(defun copy-introspect-struct (struct-metadata (* (const metadata-struct))
struct-dest (* void)
struct-src (* void)
string-allocate allocate-string-function
&return bool)
(each-in-range (path struct-metadata > num-members) i
(var field (* (const metadata-field)) (addr (at i (path struct-metadata > members))))
(cond
;; Numeric and boolean types
((= (path field > type) introspect-type-int)
(introspect-field-dispatch field value-offset
(var int-dest (* int)
(offset-pointer-to-type struct-dest value-offset (* int)))
(var int-src (* int)
(offset-pointer-to-type struct-src value-offset (* int)))
(set (deref int-dest) (deref int-src))))
((= (path field > type) introspect-type-float)
(introspect-field-dispatch field value-offset
(var float-dest (* float)
(offset-pointer-to-type struct-dest value-offset (* float)))
(var float-src (* float)
(offset-pointer-to-type struct-src value-offset (* float)))
(set (deref float-dest) (deref float-src))))
((= (path field > type) introspect-type-bool)
(introspect-field-dispatch field value-offset
(var bool-dest (* bool)
(offset-pointer-to-type struct-dest value-offset (* bool)))
(var bool-src (* bool)
(offset-pointer-to-type struct-src value-offset (* bool)))
(set (deref bool-dest) (deref bool-src))))
((= (path field > type) introspect-type-char)
(var char-dest (* char)
(offset-pointer-to-type struct-dest (path field > offset) (* char)))
(var char-src (* char)
(offset-pointer-to-type struct-src (path field > offset) (* char)))
(set (deref char-dest) (deref char-src)))
;; Strings
((= (path field > type) introspect-type-fixed-size-string)
(introspect-field-dispatch field value-offset
(var str-dest (* char)
(offset-pointer-to-type struct-dest value-offset (* char)))
(var str-src (* (const char))
(offset-pointer-to-type struct-src value-offset (* (const char))))
(strcpy str-dest str-src)))
((= (path field > type) introspect-type-string)
(introspect-field-dispatch field value-offset
(var str-dest (* (* char))
(offset-pointer-to-type struct-dest value-offset (* (* char))))
(var str-src (* (* (const char)))
(offset-pointer-to-type struct-src value-offset (* (* (const char)))))
(when (deref str-dest)
(fprintf stderr "error: cannot copy field '%s' because string seems to be present. Free " \
"the destination first\n"
(path field > name))
(return false))
(when (deref str-src) ;; Guard against null strings
(var src-length size_t (strlen (deref str-src)))
(set (deref str-dest) (type-cast (string-allocate (+ 1 src-length))
(* char)))
(strncpy (deref str-dest) (deref str-src) src-length)
(set (at src-length (deref str-dest)) 0))))
;; Nested introspectable structs
((= (path field > type) introspect-type-introspect-struct)
(introspect-field-dispatch field value-offset
(var substruct-dest (* void)
(offset-pointer-to-type struct-dest value-offset (* void)))
(var substruct-src (* void)
(offset-pointer-to-type struct-src value-offset (* void)))
(var return-value bool
(copy-introspect-struct (path field > field-type-metadata)
substruct-dest
substruct-src
string-allocate))
(unless return-value
(fprintf stderr "error: failed to copy field '%s' with nested struct type\n"
(path field > name))
(return false))))
((= (path field > type) introspect-type-override)
(introspect-field-dispatch field value-offset
(var is-success bool
(copy-introspect-field-handle-override (introspect-override-invocation-args 'copy)))
(unless is-success
(return false))))
(true
(fprintf stderr "error: do not know how to copy field '%s' with type %d\n"
(path field > name) (path field > type))
(return false))))
(return true))
;;
;; Test
;;
;; This runs read-s-expr, write-s-expr, compare, and free on your struct, which is a good way to
;; test that everything is working properly
(defun introspect-test-struct-internal (struct-metadata (* (const metadata-struct))
baseline (* void)
serialization-filename (* (const char))
is-quiet bool
&return bool)
(unless is-quiet
(fprintf stderr "Baseline:\n")
(unless (write-introspect-struct-s-expr struct-metadata baseline stderr
write-introspect-struct-add-newline)
(return false)))
(scope ;; Write to a file
(var out-file (* FILE) (fopen serialization-filename "w"))
(unless out-file (return false))
(unless (write-introspect-struct-s-expr struct-metadata baseline out-file
write-introspect-struct-add-newline)
(fclose out-file)
(return false))
(fclose out-file))
(scope ;; Now read it back
(var read-struct (* void) (malloc (path struct-metadata > struct-size)))
(memset read-struct 0 (path struct-metadata > struct-size))
(scope
(var in-file (* FILE) (fopen serialization-filename "r"))
(unless in-file (return false))
(var file-contents (* (const char)) (read-file-into-memory in-file))
(fclose in-file)
(var num-characters-read (unsigned int) 0)
(unless (read-introspect-struct-s-expr struct-metadata read-struct
file-contents malloc (addr num-characters-read))
(free (type-cast file-contents (* void)))
(free read-struct)
(return false))
;; (fprintf stderr "Read %d characters. Last char: %c Rest: \"%s\"\n"
;; num-characters-read (deref (+ file-contents num-characters-read))
;; (+ file-contents num-characters-read))
(free (type-cast file-contents (* void))))
(unless is-quiet
(fprintf stderr "Read-in struct:\n")
(unless (write-introspect-struct-s-expr struct-metadata read-struct stderr
write-introspect-struct-add-newline)
(free-introspect-struct-fields
struct-metadata read-struct free)
(free read-struct)
(return false)))
;; Print error even if quiet
(unless (= 0 (compare-introspect-struct-print-result struct-metadata
read-struct baseline))
(fprintf stderr "error: struct read in does not equal original struct\n")
(free-introspect-struct-fields
struct-metadata read-struct free)
(free read-struct)
(return false))
(free-introspect-struct-fields
struct-metadata read-struct free)
(free read-struct))
(scope ;; Test copy
(var dest-struct (* void) (malloc (path struct-metadata > struct-size)))
(memset dest-struct 0 (path struct-metadata > struct-size))
(unless (copy-introspect-struct struct-metadata dest-struct baseline malloc)
(return false))
(unless (= 0 (compare-introspect-struct-print-result struct-metadata
dest-struct
baseline))
(fprintf stderr "error: copied struct does not equal baseline\n")
(return false))
(free-introspect-struct-fields
struct-metadata dest-struct free)
(free dest-struct))
(return true))
(defun introspect-test-struct (struct-metadata (* (const metadata-struct))
baseline (* void)
serialization-filename (* (const char))
&return bool)
(return (introspect-test-struct-internal
struct-metadata
baseline
serialization-filename
false)))
(defun introspect-test-struct-quiet (struct-metadata (* (const metadata-struct))
baseline (* void)
serialization-filename (* (const char))
&return bool)
(return (introspect-test-struct-internal
struct-metadata
baseline
serialization-filename
true)))
(comptime-cond
('auto-test
(c-import "<string.h>" ;; strdup()
"<stdlib.h>") ;; free()
(def-type-alias-global my-type int) ;; TODO support type alias stripping
(def-introspect-struct my-nested-struct
message (* (const char))
is-awesome bool)
(def-introspect-struct my-struct
name (* (const char))
other-name ([] 32 char)
yet-another-name (* char)
optional-name (* char)
value int
decimal float
bad ([] 3 float) (ignore)
support-arrays ([] 3 float)
support-substruct-arrays ([] 2 my-nested-struct)
truthy bool
charry char
nested my-nested-struct
special-field my-type (override 'Type-Hint "Unowned NoEditor")
another-special ([] 2 my-type) (override 'Type-Hint)
my-thing (* my-nested-struct))
(introspect-override-register-handler 'write-s-expr
(metadata-field-has-tag field "'Type-Hint")
write-my-type
(var my-type-write (* my-type)
(offset-pointer-to-type struct-to-write value-offset (* my-type)))
(fprintf out-file " %d" (deref my-type-write))
(return true))
(introspect-override-register-handler 'read-s-expr
(metadata-field-has-tag field "'Type-Hint")
read-my-type
(var my-type-read (* my-type)
(offset-pointer-to-type struct-out value-offset (* my-type)))
(set (deref my-type-read) (atoi value-argument-start))
(return true))
(introspect-override-register-handler 'compare
(metadata-field-has-tag field "'Type-Hint")
compare-my-type
(var my-type-a (* my-type)
(offset-pointer-to-type struct-a value-offset (* my-type)))
(var my-type-b (* my-type)
(offset-pointer-to-type struct-b value-offset (* my-type)))
(when (!= (deref my-type-a) (deref my-type-b))
(when print-difference
(fprintf stderr "structs differ by field '%s' [%d] (%d vs %d)\n"
(path field > name)
(type-cast dispatch-value-index int)
(deref my-type-a) (deref my-type-b)))
(return (- my-type-a my-type-b)))
(return 0))
(introspect-override-register-handler 'copy
(metadata-field-has-tag field "'Type-Hint")
copy-my-type
(var my-type-dest (* my-type)
(offset-pointer-to-type struct-dest value-offset (* my-type)))
(var my-type-src (* my-type)
(offset-pointer-to-type struct-src value-offset (* my-type)))
(set (deref my-type-dest) (deref my-type-src))
(return true))
(introspect-override-register-handler 'free
(metadata-field-has-tag field "'Type-Hint")
free-my-type
(ignore))
;; Example of pointer to struct override
(introspect-override-register-handler 'write-s-expr
(= (path field > field-type-metadata) my-nested-struct--metadata)
write-my-nested-struct-ptr
(var my-nested-struct-ptr-write (* (* my-nested-struct))
(offset-pointer-to-type struct-to-write value-offset (* (* my-nested-struct))))
(if (deref my-nested-struct-ptr-write)
;; (fprintf out-file " %d" (deref (deref my-nested-struct-ptr-write)))
(fprintf out-file " TODO")
(fprintf out-file " null"))
(return true))
(introspect-override-register-handler 'read-s-expr
(= (path field > field-type-metadata) my-nested-struct--metadata)
read-my-nested-struct-ptr
(var my-nested-struct-ptr-read (* (* my-nested-struct))
(offset-pointer-to-type struct-out value-offset (* (* my-nested-struct))))
;; TODO
(set (deref my-nested-struct-ptr-read) null)
(return true))
(introspect-override-register-handler 'compare
(= (path field > field-type-metadata) my-nested-struct--metadata)
compare-my-nested-struct-ptr
(var my-nested-struct-ptr-a (* (* my-nested-struct))
(offset-pointer-to-type struct-a value-offset (* (* my-nested-struct))))
(var my-nested-struct-ptr-b (* (* my-nested-struct))
(offset-pointer-to-type struct-b value-offset (* (* my-nested-struct))))
;; Just do raw pointer comparison for now
(when (!= (deref my-nested-struct-ptr-a) (deref my-nested-struct-ptr-b))
(when print-difference
(fprintf stderr "structs differ by field '%s' [%d] (%p vs %p)\n"
(path field > name)
(type-cast dispatch-value-index int)
(deref my-nested-struct-ptr-a) (deref my-nested-struct-ptr-b)))
(return (- my-nested-struct-ptr-a my-nested-struct-ptr-b)))
(return 0))
(introspect-override-register-handler 'copy
(= (path field > field-type-metadata) my-nested-struct--metadata)
copy-my-nested-struct-ptr
(var my-nested-struct-ptr-dest (* (* my-nested-struct))
(offset-pointer-to-type struct-dest value-offset (* (* my-nested-struct))))
(var my-nested-struct-ptr-src (* (* my-nested-struct))
(offset-pointer-to-type struct-src value-offset (* (* my-nested-struct))))
;; Just do raw pointer set for now
(set (deref my-nested-struct-ptr-dest) (deref my-nested-struct-ptr-src))
(return true))
(introspect-override-register-handler 'free
(= (path field > field-type-metadata) my-nested-struct--metadata)
free-my-thing
(ignore))
(defun test--introspection (&return int)
(var a my-struct
(array "Test struct" "Other name" (strdup "Another name") null
42 -0.33f (array 0.f 1.f 2.f) (array 10.f 20.f 30.f)
(array (array "Hi" true) (array "Bye" false))
false 'a'
(array "Hello!" true)
888
(array 8 9)
;; This doesn't actually write the value yet, but still tests what I wanted to test
;; (pointer overrides)
null))
(unless (introspect-test-struct my-struct--metadata (addr a) "TestSerialize.cakedata")
(return 1))
(scope ;; Test multi-reads
(fprintf stderr "\nMulti-reads:\n")
(scope ;; Write to a file
(var out-file (* FILE) (fopen "MultiReads.cakedata" "w"))
(unless out-file (return false))
(unless (write-introspect-struct-s-expr my-struct--metadata (addr a) out-file
write-introspect-struct-add-newline)
(fclose out-file)
(return false))
(unless (write-introspect-struct-s-expr my-struct--metadata (addr a) out-file
write-introspect-struct-add-newline)
(fclose out-file)
(return false))
(fclose out-file))
(scope
(var read-struct-a my-struct (array 0))
(var read-struct-b my-struct (array 0))
(var in-file (* FILE) (fopen "MultiReads.cakedata" "r"))
(unless in-file (return 1))
(var file-contents (* (const char)) (read-file-into-memory in-file))
(fclose in-file)
(var num-chars-read (unsigned int) 0)
(unless (read-introspect-struct-s-expr my-struct--metadata (addr read-struct-a)
file-contents malloc (addr num-chars-read))
(free-introspect-struct-fields
my-struct--metadata (addr read-struct-a) free)
(free (type-cast file-contents (* void)))
(return 1))
(unless (read-introspect-struct-s-expr my-struct--metadata (addr read-struct-b)
(+ num-chars-read file-contents) malloc null)
(free-introspect-struct-fields
my-struct--metadata (addr read-struct-b) free)
(free (type-cast file-contents (* void)))
(return 1))
(var succeeded bool true)
(unless (= 0 (compare-introspect-struct-print-result my-struct--metadata
(addr read-struct-a)
(addr read-struct-b)))
(fprintf stderr "error: structs read in do not equal each other\n")
(set succeeded false))
(unless (= 0 (compare-introspect-struct-print-result my-struct--metadata
(addr a)
(addr read-struct-b)))
(fprintf stderr "error: structs read in do not equal baseline\n")
(set succeeded false))
(free (type-cast file-contents (* void)))
(free-introspect-struct-fields
my-struct--metadata (addr read-struct-a) free)
(free-introspect-struct-fields
my-struct--metadata (addr read-struct-b) free)
(unless succeeded (return 1))
(fprintf stderr "Succeeded\n")))
(scope ;; Copy structs
(var a my-struct
(array "Test struct" "Other name" (strdup "Another name") null
42 -0.33f (array 0.f 1.f 2.f) (array 10.f 20.f 30.f)
(array (array "Hi" true) (array "Bye" false))
false 'a'
(array "Hello!" true)
888
(array 8 9)
;; This doesn't actually write the value yet, but still tests what I wanted to test
;; (pointer overrides)
null))
(var b my-struct (array 0))
(unless (copy-introspect-struct my-struct--metadata (addr b) (addr a) malloc)
(return 1))
(unless (= 0 (compare-introspect-struct-print-result my-struct--metadata
(addr a)
(addr b)))
(fprintf stderr "error: copied struct does not equal baseline\n")
(return 1)))
(scope ;; Test errors
(var read-struct my-struct (array 0))
(scope
(var in-file (* FILE) (fopen "Errors.cakedata" "r"))
(unless in-file (return 1))
(var file-contents (* (const char)) (read-file-into-memory in-file))
(fclose in-file)
(fprintf stderr "note: I expect there to be an error to read struct from Errors.cakedata -- ")
(when (read-introspect-struct-s-expr my-struct--metadata (addr read-struct)
file-contents malloc null)
(fprintf stderr "error: expected to fail to read struct from Errors.cakedata\n")
(free-introspect-struct-fields
my-struct--metadata (addr read-struct) free)
(free (type-cast file-contents (* void)))
(return 1))
(free (type-cast file-contents (* void)))
(free-introspect-struct-fields
my-struct--metadata (addr read-struct) free)))
(free (field a yet-another-name))
(return 0))))