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.
2059 lines
97 KiB
2059 lines
97 KiB
(import "FileUtilities.cake"
|
|
"CHelpers.cake" "ComptimeHelpers.cake")
|
|
(comptime-cond
|
|
('Unix
|
|
(c-preprocessor-define __USE_XOPEN_EXTENDED))) ;; for strdup
|
|
(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
|
|
"<stdbool.h>")
|
|
;;
|
|
;; Comptime
|
|
;;
|
|
|
|
;; Allows modules to conditionally define introspection overrides in GameLib without requiring
|
|
;; everything use Introspection
|
|
(comptime-define-symbol 'Introspection)
|
|
|
|
;; When optional-length is zero, write the string until a null terminator is encountered.
|
|
;; Otherwise, only write the given length.
|
|
(def-function-signature-global write-introspect-function (write-string (addr (const char))
|
|
optional-length (unsigned int)
|
|
userdata (addr void)
|
|
&return bool))
|
|
|
|
(defun-comptime is-type-string (tokens (ref (const (template (in std vector) Token)))
|
|
start-type-token-index int
|
|
;; Will distinguish which sub-type of string it is
|
|
possible-string-introspect-type (addr (addr (const char)))
|
|
&return bool)
|
|
(var start-type-token (addr (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) "addr")
|
|
(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) "array")
|
|
(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 (addr (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 (addr char) buffer-size size_t
|
|
struct-name (addr (const char)))
|
|
(SafeSnprintf buffer-out buffer-size "%s--metadata-def"
|
|
struct-name))
|
|
|
|
(defun-comptime introspect-metadata-pointer-name-from-struct-name (buffer-out (addr char)
|
|
buffer-size size_t
|
|
struct-name (addr (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 (addr (template (in std vector) Token)) (new (template (in std vector) Token)))
|
|
(call-on push_back (field environment comptimeTokens) processed-arguments)
|
|
|
|
(var fields-metadata (addr (template (in std vector) Token)) (new (template (in 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))
|
|
|
|
(defstruct non-constant-field-data
|
|
field-metadata-struct-name Token
|
|
field-index int)
|
|
(var non-constant-fields (template (in std vector) non-constant-field-data))
|
|
|
|
(var field-index int 0)
|
|
|
|
(each-token-argument-in tokens start-members end-token-index i
|
|
(var name-token (addr (const Token))
|
|
(addr (at i tokens)))
|
|
|
|
(set i (getNextArgument tokens i end-token-index))
|
|
(var type-token-index int i)
|
|
(var type-token (addr (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 (addr (const Token))
|
|
(addr (at possible-annotation-index tokens)))
|
|
|
|
(var tags-tokens (template (in std vector) Token))
|
|
(call-on resize tags-tokens (introspect-get-num-tags))
|
|
(each-in-range (call-on size tags-tokens) tag-index
|
|
(set (at tag-index tags-tokens) (deref type-token))
|
|
(set (field (at tag-index tags-tokens) type) TokenType_Symbol)
|
|
(set (field (at tag-index 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 (addr (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 (addr (const char)) null)
|
|
|
|
(var core-type-token (addr (const Token)) type-token)
|
|
(var core-type-token-index int type-token-index)
|
|
|
|
(var is-override-pointer bool false)
|
|
|
|
(var array-count-token (addr (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) "addr")
|
|
;; 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 (addr (const X))
|
|
(set core-type-token (addr (at core-type-token-index tokens))))
|
|
|
|
(when (and (std-str-equals (path (+ 1 core-type-token) > contents) "array")
|
|
;; 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 (addr (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 (array 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 new-non-const-field non-constant-field-data)
|
|
(set (field new-non-const-field field-metadata-struct-name) field-type-metadata-token)
|
|
(set (field new-non-const-field field-index) field-index)
|
|
(call-on push_back non-constant-fields new-non-const-field))
|
|
|
|
(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 (template (in std vector) Token))
|
|
;; This used to output the type metadata struct pointer, but when fields reference types in
|
|
;; other modules, that causes a non-const initializer, which is not allowed in C. Now, all
|
|
;; metadata struct pointers will be set in introspect-initialize at runtime.
|
|
(if (or true (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 (template (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 (addr 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))))
|
|
(incr field-index))
|
|
|
|
;; 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 (array 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 (array 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 (array 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)))
|
|
|
|
(forward-declare (struct metadata-field))
|
|
;; This is a hidden global so Introspection.cake can access it, but no other modules should have
|
|
;; easy access without the programmer going out of their way to expose it.
|
|
(var-hidden-global
|
|
(token-splice-addr metadata-fields-name)
|
|
(array metadata-field)
|
|
(array (token-splice-array (deref fields-metadata))))
|
|
(var (token-splice-addr metadata-name) (const 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 (addr (const metadata-struct)))
|
|
(addr (token-splice-addr metadata-name))))
|
|
|
|
;; Non-constant fields must be set at runtime
|
|
(unless (call-on empty non-constant-fields)
|
|
(get-or-create-comptime-var environment runtime-fixup (template (in std vector) Token))
|
|
(tokenize-push (deref runtime-fixup)
|
|
(declare-external (var (token-splice-addr metadata-fields-name) (array metadata-field))))
|
|
(each-in-range (call-on size non-constant-fields) non-const-field-index
|
|
(var non-const-field (addr non-constant-field-data)
|
|
(addr (at non-const-field-index non-constant-fields)))
|
|
(var field-index-token Token (path non-const-field > field-metadata-struct-name))
|
|
(token-contents-snprintf field-index-token "%d" (path non-const-field > field-index))
|
|
(tokenize-push (deref runtime-fixup)
|
|
(declare-external (var (token-splice-addr (path non-const-field > field-metadata-struct-name))
|
|
(addr (const metadata-struct))))
|
|
(set (field (at (token-splice-addr field-index-token) (token-splice-addr metadata-fields-name))
|
|
field-type-metadata)
|
|
(token-splice-addr (path non-const-field > field-metadata-struct-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 (addr (const char))
|
|
override-function-name Token
|
|
function-signature (template (in std vector) Token)
|
|
function-invocation (template (in std vector) Token)
|
|
on-override-missing (template (in std vector) Token)
|
|
function-no-return bool
|
|
|
|
registered-handlers (template (in std unordered_map)
|
|
(addr (const Token)) ;; Handler name
|
|
(addr (const Token))) ;; Condition to invoke this handler
|
|
num-installed int)
|
|
|
|
(defstruct introspect-override-state
|
|
handlers-by-type (template (in std vector) introspect-override-handler)))
|
|
(return true))
|
|
|
|
(defun-comptime destroy-introspect-override-state (data (addr void))
|
|
(introspect-override-define-types)
|
|
(delete (type-cast data (addr introspect-override-state))))
|
|
|
|
;; Must return void because types cannot be defined in comptime
|
|
(defun-comptime create-introspect-override-state (environment (ref EvaluatorEnvironment)
|
|
state-out (addr (addr void))
|
|
;; Needs to return bool only because tokenize-push
|
|
&return bool)
|
|
(set (deref state-out) null)
|
|
(introspect-override-define-types)
|
|
(var overrides-state (addr introspect-override-state) (new introspect-override-state))
|
|
(unless (CreateCompileTimeVariable environment
|
|
"introspect-override-handlers" "(addr introspect-override-state)"
|
|
(type-cast overrides-state (addr 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 (array 0))
|
|
(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 (addr (const metadata-struct))
|
|
field (addr (const metadata-field))
|
|
struct-to-write (addr (const void))
|
|
value-offset size_t
|
|
write-func write-introspect-function
|
|
write-func-userdata (addr void)
|
|
write-options write-introspect-struct-options
|
|
&return bool))
|
|
(tokenize-push (field handler function-invocation)
|
|
struct-metadata
|
|
field
|
|
struct-to-write
|
|
value-offset
|
|
write-func write-func-userdata
|
|
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 (array 0))
|
|
(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 (addr (const metadata-struct))
|
|
field (addr (const metadata-field))
|
|
struct-out (addr void)
|
|
value-offset size_t
|
|
value-argument-start (addr (const char))
|
|
;; May not be valid in every context! Only trust with strings for now
|
|
value-argument-end (addr (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
|
|
value-argument-end
|
|
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 (array 0))
|
|
(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 (addr (const metadata-struct))
|
|
field (addr (const metadata-field))
|
|
struct-a (addr void)
|
|
struct-b (addr 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 (array 0))
|
|
(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 (addr (const metadata-struct))
|
|
field (addr (const metadata-field))
|
|
struct-dest (addr void)
|
|
struct-src (addr 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 (array 0))
|
|
(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")
|
|
(set (field handler function-no-return) true)
|
|
(tokenize-push (field handler function-signature)
|
|
(struct-metadata (addr (const metadata-struct))
|
|
field (addr (const metadata-field))
|
|
struct-to-destroy (addr 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 (addr 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 (ref EvaluatorEnvironment)
|
|
handler-type (addr (const char))
|
|
handler-out (addr (addr void))
|
|
&return bool)
|
|
(introspect-override-get-shared-variables)
|
|
(for-in handler-by-type (ref 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) (addr 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 (addr 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"
|
|
"(addr introspect-override-state)"
|
|
(type-cast (addr overrides-state) (addr (addr void))))
|
|
(unless (create-introspect-override-state environment
|
|
(type-cast (addr overrides-state) (addr (addr void))))
|
|
(return false))))
|
|
(return true))
|
|
|
|
(defmacro introspect-override-invocation-args (handler-type symbol)
|
|
(introspect-override-get-shared-variables)
|
|
(var handler (addr introspect-override-handler) null)
|
|
(introspect-override-get-handler-by-type environment
|
|
(call-on c_str (path handler-type > contents))
|
|
(type-cast (addr handler) (addr (addr 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 (addr introspect-override-handler) null)
|
|
(introspect-override-get-handler-by-type environment
|
|
(call-on c_str (path operation > contents))
|
|
(type-cast (addr handler) (addr (addr void))))
|
|
(unless handler
|
|
(ErrorAtToken (deref operation)
|
|
"expected operation to be one of the following symbols:")
|
|
(for-in handler-by-type (ref 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 (ref (const (addr (template (in std pair)
|
|
(const (addr (const Token)))
|
|
(addr (const Token))))))
|
|
b (ref (const (addr (template (in std pair)
|
|
(const (addr (const Token)))
|
|
(addr (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 (ref EvaluatorEnvironment)
|
|
&return bool)
|
|
(introspect-override-get-shared-variables)
|
|
|
|
(for-in handler-by-type (ref 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 (template (in std vector) (addr (template (in std pair)
|
|
(const (addr (const Token)))
|
|
(addr (const Token))))))
|
|
(for-in handler-cond-pair (ref (template (in std pair) (const (addr (const Token)))
|
|
(addr (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 (template (in std vector) Token))
|
|
(var handler-cond-tokens (template (in std vector) Token))
|
|
(for-in handler-cond-pair (addr (template (in std pair) (const (addr (const Token)))
|
|
(addr (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))))
|
|
(if (field handler-by-type function-no-return)
|
|
(scope ;; No return value
|
|
(tokenize-push handler-cond-tokens
|
|
;; Condition
|
|
((token-splice (path handler-cond-pair > second))
|
|
;; Invocation
|
|
((token-splice (path handler-cond-pair > first))
|
|
(token-splice-array (field handler-by-type function-invocation)))
|
|
(return))))
|
|
(scope ;; Return value from override
|
|
(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 (addr (template (in std vector) Token)) (new (template (in 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))
|
|
|
|
;; 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)
|
|
|
|
(defun introspect-fixup-runtime-pointers ())
|
|
|
|
(defmacro introspect-initialize ()
|
|
(get-or-create-comptime-var environment introspect-initialize-called bool false)
|
|
(set (deref introspect-initialize-called) true)
|
|
(tokenize-push output (introspect-fixup-runtime-pointers))
|
|
(return true))
|
|
|
|
(defun-comptime introspect-runtime-fixup-install (environment (ref EvaluatorEnvironment)
|
|
&return bool)
|
|
;; TODO: Validate the user calls the fixup function much like data-bundle
|
|
(get-or-create-comptime-var environment runtime-fixup (template (in std vector) Token))
|
|
(get-or-create-comptime-var environment num-runtime-fixups-installed int)
|
|
(when (= (deref num-runtime-fixups-installed) (call-on-ptr size runtime-fixup))
|
|
(return true))
|
|
(set (deref num-runtime-fixups-installed) (call-on-ptr size runtime-fixup))
|
|
|
|
(var runtime-fixup-function (addr (template (in std vector) Token))
|
|
(new (template (in std vector) Token)))
|
|
;; Environment will handle freeing tokens for us
|
|
(call-on push_back (field environment comptimeTokens) runtime-fixup-function)
|
|
(tokenize-push (deref runtime-fixup-function)
|
|
(defun introspect-fixup-runtime-pointers ()
|
|
(token-splice-array (deref runtime-fixup))))
|
|
(unless (ReplaceAndEvaluateDefinition
|
|
environment
|
|
"introspect-fixup-runtime-pointers"
|
|
(deref runtime-fixup-function))
|
|
(return false))
|
|
(return true))
|
|
|
|
(add-compile-time-hook post-references-resolved introspect-runtime-fixup-install)
|
|
|
|
(defun-comptime introspect-check-initialize-called (manager (ref ModuleManager)
|
|
module (addr Module)
|
|
&return bool)
|
|
(get-or-create-comptime-var
|
|
(field manager environment)
|
|
num-runtime-fixups-installed int)
|
|
(unless (deref num-runtime-fixups-installed)
|
|
;; No reason to call introspect-initialize because no fixups are necessary
|
|
(return true))
|
|
(get-or-create-comptime-var
|
|
(field manager environment)
|
|
introspect-initialize-called bool false)
|
|
(unless (deref introspect-initialize-called)
|
|
(Log "error: call (introspect-initialize) somewhere in your program initialization in " \
|
|
"order to properly set introspection metadata.\n")
|
|
(return false))
|
|
(return true))
|
|
(add-compile-time-hook-module pre-build introspect-check-initialize-called)
|
|
|
|
;;
|
|
;; 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 (addr (const char))
|
|
type introspect-type
|
|
field-type-metadata (addr (const metadata-struct))
|
|
offset size_t
|
|
element-size size_t
|
|
count size_t ;; For arrays
|
|
tags (array 2 (addr (const char))))
|
|
|
|
(defstruct metadata-struct
|
|
name (addr (const char))
|
|
;; type introspect-struct-type ;; Almost always field-by-field, but TODO let them override the whole process
|
|
members (addr (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) (addr 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 (addr (const metadata-field))
|
|
tag (addr (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 (addr (const char)))
|
|
(return (? value "true" "false")))
|
|
|
|
(defun escape-write-string-element (write-func write-introspect-function
|
|
write-func-userdata (addr void)
|
|
string-to-output (addr (const char))
|
|
&return bool)
|
|
(when (or (not string-to-output) (= (deref string-to-output) 0))
|
|
(unless (write-func " \"\"" 0 write-func-userdata) (return false))
|
|
(return true))
|
|
|
|
;; Space between element and string
|
|
(unless (write-func " \"" 0 write-func-userdata) (return false))
|
|
(var write-start (addr (const char)) string-to-output)
|
|
(var previous-char (addr (const char)) string-to-output)
|
|
(each-char-in-string-const string-to-output current-char
|
|
;; Note that we allow newlines to be rendered to the file. This way, the user can just type
|
|
;; the string without having to think about it being multiline
|
|
(when (or (= '\"' (deref current-char))
|
|
(= '\\' (deref current-char)))
|
|
(var range size_t (- current-char write-start))
|
|
(when (> range 0)
|
|
(unless (write-func write-start range write-func-userdata) (return false)))
|
|
;; TODO: Cakelisp gets confused by a string with that
|
|
(var backslash-hack (array (const char)) (array '\\' 0))
|
|
(unless (write-func backslash-hack 0 write-func-userdata) (return false))
|
|
;; The next big write will write the now escaped character out
|
|
(set write-start current-char))
|
|
(set previous-char current-char))
|
|
;; previous-char is now the final character before null terminator.
|
|
(var range size_t (+ (- previous-char write-start) 1))
|
|
(unless (write-func write-start range write-func-userdata) (return false))
|
|
(unless (write-func "\"" 0 write-func-userdata) (return false))
|
|
(return true))
|
|
|
|
(defun read-escaped-string (buffer-out (addr char) value-length size_t
|
|
read-string (addr (const char)))
|
|
(var write-head (addr char) buffer-out)
|
|
(var read-start (addr (const char)) read-string)
|
|
(var final-character (addr (const char)) read-string)
|
|
(each-char-in-string-const read-string current-char
|
|
(when (>= (- current-char read-string) value-length)
|
|
(break))
|
|
(when (= '\\' (deref current-char))
|
|
(var copy-range size_t (- current-char read-start))
|
|
(strncpy write-head read-start copy-range)
|
|
(set write-head (+ write-head copy-range))
|
|
(set read-start (+ 1 current-char))
|
|
(when (= '\\' (deref (+ 1 current-char)))
|
|
;; Note that we don't increment the read start again so that it will write out the escaped
|
|
;; backslash on next write
|
|
;; Skip over escaped backslash
|
|
(incr current-char)))
|
|
(set final-character current-char))
|
|
(var copy-range size_t (+ 1 (- final-character read-start)))
|
|
(strncpy write-head read-start copy-range)
|
|
(set write-head (+ write-head copy-range))
|
|
;; Finish with the null terminator
|
|
(set (deref write-head) 0))
|
|
|
|
;; TODO: Change this to be flags enum
|
|
(defenum write-introspect-struct-options
|
|
write-introspect-struct-default
|
|
write-introspect-struct-add-newline)
|
|
|
|
(defun write-introspect-struct-file-writer (write-string (addr (const char))
|
|
optional-length (unsigned int)
|
|
userdata (addr void)
|
|
&return bool)
|
|
(var-cast-to output-file (addr FILE) userdata)
|
|
(if optional-length
|
|
(fwrite write-string optional-length 1 output-file)
|
|
(fprintf output-file "%s" write-string))
|
|
(return true))
|
|
|
|
(defstruct write-introspect-struct-buffer-data
|
|
buffer (addr char)
|
|
write-head (addr char)
|
|
size size_t)
|
|
|
|
(defun write-introspect-struct-buffer-writer (write-string (addr (const char))
|
|
optional-length (unsigned int)
|
|
userdata (addr void)
|
|
&return bool)
|
|
(var-cast-to buffer-data (addr write-introspect-struct-buffer-data) userdata)
|
|
(var remaining-space size_t (- (path buffer-data > size)
|
|
(- (path buffer-data > write-head)
|
|
(path buffer-data > buffer))))
|
|
(when (>= optional-length remaining-space)
|
|
(fprintf stderr "Not enough space in buffer remaining\n")
|
|
(return false))
|
|
|
|
(if optional-length
|
|
(scope
|
|
(strncpy (path buffer-data > write-head) write-string optional-length)
|
|
(set (path buffer-data > write-head) (+ (path buffer-data > write-head)
|
|
optional-length)))
|
|
(scope
|
|
(var write-length size_t
|
|
(snprintf (path buffer-data > write-head)
|
|
remaining-space
|
|
"%s" write-string))
|
|
(unless (< write-length remaining-space)
|
|
(fprintf stderr "write-introspect-struct-s-expr buffer was not large enough to fit\n")
|
|
(return false))
|
|
(set (path buffer-data > write-head) (+ (path buffer-data > write-head)
|
|
write-length))))
|
|
(return true))
|
|
|
|
(defmacro snprintf-or-return-false (output-buffer any format any &optional &rest arguments any)
|
|
(tokenize-push output
|
|
(unless (< (snprintf (token-splice output-buffer)
|
|
(sizeof (token-splice output-buffer))
|
|
(token-splice format)
|
|
(token-splice-rest arguments tokens))
|
|
(- (sizeof (token-splice output-buffer)) 1))
|
|
(fprintf stderr "write-introspect-struct-s-expr format-buffer was not large enough to fit\n")
|
|
(return false)))
|
|
(return true))
|
|
|
|
(defun write-introspect-struct-s-expr (struct-metadata (addr (const metadata-struct))
|
|
struct-to-write (addr (const void))
|
|
write-func write-introspect-function
|
|
write-func-userdata (addr void)
|
|
write-options write-introspect-struct-options
|
|
&return bool)
|
|
(var format-buffer (array 2048 char) (array 0))
|
|
(snprintf-or-return-false format-buffer "(%s" (path struct-metadata > name))
|
|
(unless (write-func format-buffer 0 write-func-userdata) (return false))
|
|
|
|
(each-in-range (path struct-metadata > num-members) i
|
|
(var field (addr (const metadata-field)) (addr (at i (path struct-metadata > members))))
|
|
(snprintf-or-return-false format-buffer " :%s" (path field > name))
|
|
(unless (write-func format-buffer 0 write-func-userdata) (return false))
|
|
(when (path field > count)
|
|
(unless (write-func " (array" 0 write-func-userdata) (return false)))
|
|
|
|
(cond
|
|
;; Numeric and boolean types
|
|
((= (path field > type) introspect-type-int)
|
|
(introspect-field-dispatch field value-offset
|
|
(var int-write (addr int)
|
|
(offset-pointer-to-type struct-to-write value-offset (addr int)))
|
|
(snprintf-or-return-false format-buffer " %d" (deref int-write))
|
|
(unless (write-func format-buffer 0 write-func-userdata) (return false))))
|
|
((= (path field > type) introspect-type-float)
|
|
(introspect-field-dispatch field value-offset
|
|
(var float-write (addr float)
|
|
(offset-pointer-to-type struct-to-write value-offset (addr float)))
|
|
(snprintf-or-return-false format-buffer " %f" (deref float-write))
|
|
(unless (write-func format-buffer 0 write-func-userdata) (return false))))
|
|
((= (path field > type) introspect-type-bool)
|
|
(introspect-field-dispatch field value-offset
|
|
(var bool-write (addr bool)
|
|
(offset-pointer-to-type struct-to-write value-offset (addr bool)))
|
|
(snprintf-or-return-false format-buffer " %s" (bool-to-string (deref bool-write)))
|
|
(unless (write-func format-buffer 0 write-func-userdata) (return false))))
|
|
((= (path field > type) introspect-type-char)
|
|
(var char-write (addr char)
|
|
(offset-pointer-to-type struct-to-write (path field > offset) (addr char)))
|
|
;; Write chars as integers to avoid writing e.g. '\0' in text
|
|
(snprintf-or-return-false format-buffer " %d" (deref char-write))
|
|
(unless (write-func format-buffer 0 write-func-userdata) (return false)))
|
|
|
|
;; Strings
|
|
((= (path field > type) introspect-type-fixed-size-string)
|
|
(introspect-field-dispatch field value-offset
|
|
(var str-write (addr (const char))
|
|
(offset-pointer-to-type struct-to-write value-offset (addr (const char))))
|
|
(unless (escape-write-string-element write-func write-func-userdata
|
|
(? str-write str-write ""))
|
|
(return false))))
|
|
((= (path field > type) introspect-type-string)
|
|
(introspect-field-dispatch field value-offset
|
|
(var str-write (addr (addr (const char)))
|
|
(offset-pointer-to-type struct-to-write value-offset (addr (addr (const char)))))
|
|
(unless (escape-write-string-element write-func write-func-userdata
|
|
(? (deref str-write) (deref str-write) ""))
|
|
(return false))))
|
|
|
|
;; TODO: Add indentation for substructs to improve readability
|
|
((= (path field > type) introspect-type-introspect-struct)
|
|
(introspect-field-dispatch field value-offset
|
|
(var substruct-write (addr void)
|
|
(offset-pointer-to-type struct-to-write value-offset (addr void)))
|
|
(unless (write-func " " 0 write-func-userdata) (return false))
|
|
(write-introspect-struct-s-expr (path field > field-type-metadata)
|
|
substruct-write
|
|
write-func write-func-userdata
|
|
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 stderr "error: attempted to write field of unknown type %d\n" (path field > type))
|
|
(return false)))
|
|
|
|
(when (path field > count)
|
|
(unless (write-func ")" 0 write-func-userdata) (return false)))
|
|
(when (< i (- (path struct-metadata > num-members) 1))
|
|
(unless (write-func "\n" 0 write-func-userdata) (return false))))
|
|
|
|
(unless (write-func ")" 0 write-func-userdata) (return false))
|
|
(when (= write-options write-introspect-struct-add-newline)
|
|
(unless (write-func "\n" 0 write-func-userdata) (return false)))
|
|
(return true))
|
|
|
|
(def-function-signature-global allocate-string-function (num-bytes size_t &return (addr void)))
|
|
(def-function-signature-global free-string-function (string-to-free (addr void)))
|
|
|
|
(defun print-string-range (start (addr (const char))
|
|
end (addr (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 (addr (const metadata-struct))
|
|
field (addr (const metadata-field))
|
|
struct-out (addr void)
|
|
value-offset size_t
|
|
in-string (addr (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 (addr int)
|
|
(offset-pointer-to-type struct-out value-offset (addr int)))
|
|
(set (deref int-write) (atoi in-string)))
|
|
((= (path field > type) introspect-type-float)
|
|
(var float-write (addr float)
|
|
(offset-pointer-to-type struct-out value-offset (addr float)))
|
|
(set (deref float-write) (atof in-string)))
|
|
((= (path field > type) introspect-type-bool)
|
|
(var bool-write (addr bool)
|
|
(offset-pointer-to-type struct-out value-offset (addr 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 (addr char)
|
|
(offset-pointer-to-type struct-out value-offset (addr 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 (addr char)
|
|
(offset-pointer-to-type struct-out value-offset (addr 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))
|
|
(read-escaped-string str-write value-length in-string)
|
|
;; 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 (addr (addr (const char)))
|
|
(offset-pointer-to-type struct-out value-offset (addr (addr (const char)))))
|
|
(var-cast-to copied-string (addr char) (string-allocate (+ 1 value-length)))
|
|
(read-escaped-string copied-string value-length in-string)
|
|
(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 (addr void)
|
|
(offset-pointer-to-type struct-out value-offset (addr 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 (addr (const char)) &return bool)
|
|
(return
|
|
(and (= '\"' (deref char-in-string))
|
|
(or
|
|
(!= '\\' (deref (- char-in-string 1)))
|
|
;; Handle strings which end in backslash: "\\"
|
|
(and
|
|
(= '\\' (deref (- char-in-string 1)))
|
|
(= '\\' (deref (- char-in-string 2))))))))
|
|
|
|
;; Hack to avoid Emacs getting confused by C-style '(' and ')'
|
|
(var open-paren (const char) 0x28)
|
|
(var close-paren (const char) 0x29)
|
|
|
|
(defun s-expr-get-next-argument-start-end (in-string (addr (const char))
|
|
start-out (addr (addr (const char)))
|
|
end-out (addr (addr (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))
|
|
;; '(' character code added for emacs paren detection; otherwise unnecessary
|
|
((= open-paren (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
|
|
((= open-paren (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 (addr (const metadata-struct))
|
|
struct-out (addr void)
|
|
in-string (addr (const char))
|
|
string-allocate allocate-string-function
|
|
characters-read-out (addr (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 (addr (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 (= open-paren (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))
|
|
(= '\r' (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 (array 1024 char) (array 0))
|
|
(var current-symbol-write (addr char) current-symbol-buffer)
|
|
(var current-field (addr (const metadata-field)) null)
|
|
|
|
(set state state-read-member-name)
|
|
(var argument-start (addr (const char)) null)
|
|
(var argument-end (addr (const char)) null)
|
|
(var last-valid-argument-end (addr (const char)) null)
|
|
(var current-char (addr (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 (addr (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 (addr (const char)) argument-start)
|
|
(var value-argument-end (addr (const char)) argument-end)
|
|
(when (path current-field > count) ;; Handle (array)
|
|
(var array-keyword-length int 5) ;; 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 (addr (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) open-paren) ;; 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 (array 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)
|
|
(when (metadata-field-has-tag current-field "'array-allow-subset")
|
|
(set state state-read-member-name)
|
|
;; introspect-field-dispatch is a loop for all fields
|
|
(break))
|
|
(fprintf stderr "error: field %s expected %d elements but found only %d. Add 'array-allow-subset to allow this.\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 (addr (const metadata-struct))
|
|
struct-to-destroy (addr void)
|
|
string-free free-string-function)
|
|
(each-in-range (path struct-metadata > num-members) i
|
|
(var field (addr (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 (addr (addr char))
|
|
(offset-pointer-to-type struct-to-destroy value-offset (addr (addr 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 (addr void)
|
|
(offset-pointer-to-type struct-to-destroy value-offset (addr 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 (addr (const metadata-struct))
|
|
struct-a (addr void)
|
|
struct-b (addr void)
|
|
print-difference bool
|
|
&return int)
|
|
(each-in-range (path struct-metadata > num-members) i
|
|
(var field (addr (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 (addr int)
|
|
(offset-pointer-to-type struct-a value-offset (addr int)))
|
|
(var int-b (addr int)
|
|
(offset-pointer-to-type struct-b value-offset (addr 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 (addr float)
|
|
(offset-pointer-to-type struct-a value-offset (addr float)))
|
|
(var float-b (addr float)
|
|
(offset-pointer-to-type struct-b value-offset (addr 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 (addr bool)
|
|
(offset-pointer-to-type struct-a value-offset (addr bool)))
|
|
(var bool-b (addr bool)
|
|
(offset-pointer-to-type struct-b value-offset (addr 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 (addr char)
|
|
(offset-pointer-to-type struct-a (path field > offset) (addr char)))
|
|
(var char-b (addr char)
|
|
(offset-pointer-to-type struct-b (path field > offset) (addr 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 (addr (const char))
|
|
(offset-pointer-to-type struct-a value-offset (addr (const char))))
|
|
(var str-b (addr (const char))
|
|
(offset-pointer-to-type struct-b value-offset (addr (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 (addr (addr (const char)))
|
|
(offset-pointer-to-type struct-a value-offset (addr (addr (const char)))))
|
|
(var str-b (addr (addr (const char)))
|
|
(offset-pointer-to-type struct-b value-offset (addr (addr (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 (addr void)
|
|
(offset-pointer-to-type struct-a value-offset (addr void)))
|
|
(var substruct-b (addr void)
|
|
(offset-pointer-to-type struct-b value-offset (addr 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 (addr (const metadata-struct))
|
|
struct-a (addr void)
|
|
struct-b (addr void)
|
|
&return int)
|
|
(return (compare-introspect-struct-internal
|
|
struct-metadata
|
|
struct-a
|
|
struct-b
|
|
false)))
|
|
|
|
(defun introspect-struct-= (struct-metadata (addr (const metadata-struct))
|
|
struct-a (addr void)
|
|
struct-b (addr void)
|
|
&return bool)
|
|
(return (= 0 (compare-introspect-struct-internal
|
|
struct-metadata
|
|
struct-a
|
|
struct-b
|
|
false))))
|
|
|
|
(defun compare-introspect-struct-print-result (struct-metadata (addr (const metadata-struct))
|
|
struct-a (addr void)
|
|
struct-b (addr void)
|
|
&return int)
|
|
(return (compare-introspect-struct-internal
|
|
struct-metadata
|
|
struct-a
|
|
struct-b
|
|
true)))
|
|
|
|
(defun copy-introspect-struct (struct-metadata (addr (const metadata-struct))
|
|
struct-dest (addr void)
|
|
struct-src (addr void)
|
|
string-allocate allocate-string-function
|
|
&return bool)
|
|
(each-in-range (path struct-metadata > num-members) i
|
|
(var field (addr (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 (addr int)
|
|
(offset-pointer-to-type struct-dest value-offset (addr int)))
|
|
(var int-src (addr int)
|
|
(offset-pointer-to-type struct-src value-offset (addr int)))
|
|
(set (deref int-dest) (deref int-src))))
|
|
((= (path field > type) introspect-type-float)
|
|
(introspect-field-dispatch field value-offset
|
|
(var float-dest (addr float)
|
|
(offset-pointer-to-type struct-dest value-offset (addr float)))
|
|
(var float-src (addr float)
|
|
(offset-pointer-to-type struct-src value-offset (addr float)))
|
|
(set (deref float-dest) (deref float-src))))
|
|
((= (path field > type) introspect-type-bool)
|
|
(introspect-field-dispatch field value-offset
|
|
(var bool-dest (addr bool)
|
|
(offset-pointer-to-type struct-dest value-offset (addr bool)))
|
|
(var bool-src (addr bool)
|
|
(offset-pointer-to-type struct-src value-offset (addr bool)))
|
|
(set (deref bool-dest) (deref bool-src))))
|
|
((= (path field > type) introspect-type-char)
|
|
(var char-dest (addr char)
|
|
(offset-pointer-to-type struct-dest (path field > offset) (addr char)))
|
|
(var char-src (addr char)
|
|
(offset-pointer-to-type struct-src (path field > offset) (addr 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 (addr char)
|
|
(offset-pointer-to-type struct-dest value-offset (addr char)))
|
|
(var str-src (addr (const char))
|
|
(offset-pointer-to-type struct-src value-offset (addr (const char))))
|
|
(strcpy str-dest str-src)))
|
|
((= (path field > type) introspect-type-string)
|
|
(introspect-field-dispatch field value-offset
|
|
(var str-dest (addr (addr char))
|
|
(offset-pointer-to-type struct-dest value-offset (addr (addr char))))
|
|
(var str-src (addr (addr (const char)))
|
|
(offset-pointer-to-type struct-src value-offset (addr (addr (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))
|
|
(addr 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 (addr void)
|
|
(offset-pointer-to-type struct-dest value-offset (addr void)))
|
|
(var substruct-src (addr void)
|
|
(offset-pointer-to-type struct-src value-offset (addr 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 (addr (const metadata-struct))
|
|
baseline (addr void)
|
|
serialization-filename (addr (const char))
|
|
is-quiet bool
|
|
&return bool)
|
|
(unless is-quiet
|
|
(fprintf stderr "Baseline:\n")
|
|
(unless (write-introspect-struct-s-expr struct-metadata baseline
|
|
write-introspect-struct-file-writer stderr
|
|
write-introspect-struct-add-newline)
|
|
(return false)))
|
|
|
|
(scope ;; Write to a file
|
|
(var out-file (addr FILE) (fopen serialization-filename "wb"))
|
|
(unless out-file (return false))
|
|
(unless (write-introspect-struct-s-expr struct-metadata baseline
|
|
write-introspect-struct-file-writer out-file
|
|
write-introspect-struct-add-newline)
|
|
(fclose out-file)
|
|
(return false))
|
|
(fclose out-file))
|
|
|
|
(scope ;; Now read it back
|
|
(var read-struct (addr void) (malloc (path struct-metadata > struct-size)))
|
|
(memset read-struct 0 (path struct-metadata > struct-size))
|
|
(scope
|
|
(var in-file (addr FILE) (fopen serialization-filename "rb"))
|
|
(unless in-file (return false))
|
|
(var file-contents (addr (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 (addr 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 (addr void))))
|
|
|
|
(unless is-quiet
|
|
(fprintf stderr "Read-in struct:\n")
|
|
(unless (write-introspect-struct-s-expr struct-metadata read-struct
|
|
write-introspect-struct-file-writer 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 (addr 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 (addr (const metadata-struct))
|
|
baseline (addr void)
|
|
serialization-filename (addr (const char))
|
|
&return bool)
|
|
(return (introspect-test-struct-internal
|
|
struct-metadata
|
|
baseline
|
|
serialization-filename
|
|
false)))
|
|
|
|
(defun introspect-test-struct-quiet (struct-metadata (addr (const metadata-struct))
|
|
baseline (addr void)
|
|
serialization-filename (addr (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 (addr (const char))
|
|
is-awesome bool)
|
|
|
|
(def-introspect-struct my-struct
|
|
name (addr (const char))
|
|
other-name (array 32 char)
|
|
yet-another-name (addr char)
|
|
optional-name (addr char)
|
|
value int
|
|
decimal float
|
|
bad (array 3 float) (ignore)
|
|
support-arrays (array 3 float)
|
|
support-substruct-arrays (array 2 my-nested-struct)
|
|
truthy bool
|
|
charry char
|
|
nested my-nested-struct
|
|
special-field my-type (override 'Type-Hint "Unowned NoEditor")
|
|
another-special (array 2 my-type) (override 'Type-Hint)
|
|
my-thing (addr my-nested-struct))
|
|
|
|
(introspect-override-register-handler 'write-s-expr
|
|
(metadata-field-has-tag field "'Type-Hint")
|
|
write-my-type
|
|
(var my-type-write (addr my-type)
|
|
(offset-pointer-to-type struct-to-write value-offset (addr my-type)))
|
|
(var format-buffer (array 64 char) (array 0))
|
|
(snprintf-or-return-false format-buffer " %d" (deref my-type-write))
|
|
(unless (write-func format-buffer 0 write-func-userdata) (return false))
|
|
(return true))
|
|
|
|
(introspect-override-register-handler 'read-s-expr
|
|
(metadata-field-has-tag field "'Type-Hint")
|
|
read-my-type
|
|
(var my-type-read (addr my-type)
|
|
(offset-pointer-to-type struct-out value-offset (addr 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 (addr my-type)
|
|
(offset-pointer-to-type struct-a value-offset (addr my-type)))
|
|
(var my-type-b (addr my-type)
|
|
(offset-pointer-to-type struct-b value-offset (addr 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 (addr my-type)
|
|
(offset-pointer-to-type struct-dest value-offset (addr my-type)))
|
|
(var my-type-src (addr my-type)
|
|
(offset-pointer-to-type struct-src value-offset (addr 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 (addr (addr my-nested-struct))
|
|
(offset-pointer-to-type struct-to-write value-offset (addr (addr my-nested-struct))))
|
|
(if (deref my-nested-struct-ptr-write)
|
|
;; (fprintf out-file " %d" (deref (deref my-nested-struct-ptr-write)))
|
|
(unless (write-func " TODO" 0 write-func-userdata) (return false))
|
|
(unless (write-func " null" 0 write-func-userdata) (return false)))
|
|
(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 (addr (addr my-nested-struct))
|
|
(offset-pointer-to-type struct-out value-offset (addr (addr 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 (addr (addr my-nested-struct))
|
|
(offset-pointer-to-type struct-a value-offset (addr (addr my-nested-struct))))
|
|
(var my-nested-struct-ptr-b (addr (addr my-nested-struct))
|
|
(offset-pointer-to-type struct-b value-offset (addr (addr 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 (addr (addr my-nested-struct))
|
|
(offset-pointer-to-type struct-dest value-offset (addr (addr my-nested-struct))))
|
|
(var my-nested-struct-ptr-src (addr (addr my-nested-struct))
|
|
(offset-pointer-to-type struct-src value-offset (addr (addr 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)
|
|
;; (declare-extern-function strdup (str (addr (const char)) &return (addr char)))
|
|
(var another-name (addr char) (strdup "Another name"))
|
|
(defer (free another-name))
|
|
(var a my-struct
|
|
(array #"#"Hello!" This is a naughty
|
|
naughty string with \\ backslashes and such \\#"# "Other name" 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 (addr FILE) (fopen "MultiReads.cakedata" "wb"))
|
|
(unless out-file (return false))
|
|
(unless (write-introspect-struct-s-expr my-struct--metadata (addr a)
|
|
write-introspect-struct-file-writer out-file
|
|
write-introspect-struct-add-newline)
|
|
(fclose out-file)
|
|
(return false))
|
|
(unless (write-introspect-struct-s-expr my-struct--metadata (addr a)
|
|
write-introspect-struct-file-writer 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 (addr FILE) (fopen "MultiReads.cakedata" "rb"))
|
|
(unless in-file (return 1))
|
|
(var file-contents (addr (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 (addr 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 (addr 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 (addr 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-2 my-struct
|
|
(array "Test struct" "Other name" 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-2) malloc)
|
|
(return 1))
|
|
(unless (= 0 (compare-introspect-struct-print-result my-struct--metadata
|
|
(addr a-2)
|
|
(addr b)))
|
|
(fprintf stderr "error: copied struct does not equal baseline\n")
|
|
(return 1))
|
|
(free-introspect-struct-fields
|
|
my-struct--metadata (addr b) free))
|
|
|
|
(scope ;; Test errors
|
|
(var read-struct my-struct (array 0))
|
|
(scope
|
|
(var in-file (addr FILE) (fopen "Errors.cakedata" "rb"))
|
|
(unless in-file (return 1))
|
|
(var file-contents (addr (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 (addr void)))
|
|
(return 1))
|
|
(free (type-cast file-contents (addr void)))
|
|
|
|
(free-introspect-struct-fields
|
|
my-struct--metadata (addr read-struct) free)))
|
|
|
|
(return 0))))
|
|
|