Browse Source

Added support for arrays to Introspection.cake

* Use a macro introspect-field-dispatch to handle iterating through
values in an array and calculating the pointer offset
windows-imgui
Macoy Madson 4 months ago
parent
commit
b6c8313996
  1. 2
      .gitignore
  2. 553
      src/Introspection.cake
  3. 11
      test/Errors.cakedata
  4. 4
      tools/gamelib.el

2
.gitignore

@ -71,4 +71,4 @@ test/data/Models/*
test/imgui.ini
test/TestSerialize.cake
test/TestSerialize.cakedata

553
src/Introspection.cake

@ -1,9 +1,10 @@
(import &comptime-only "CHelpers.cake" "ComptimeHelpers.cake")
(c-import "<stdio.h>"
"<stdlib.h>" ;; atoi, atof
(c-import "<stdlib.h>" ;; atoi, atof
"<string.h>" ;; strcmp
"<ctype.h>" ;; For isspace
&with-decls "<stddef.h>") ;; For size_t, offsetof
&with-decls "<stdio.h>" ;; FILE ;; TODO: How can I remove this from header?
"<stddef.h>") ;; For size_t, offsetof
;;
;; Comptime
;;
@ -26,7 +27,7 @@
(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
(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)
@ -101,33 +102,55 @@
;; Absorb the argument as part of this field
(set i possible-annotation-index))
(unless ignore-field ;; Output field metadata
(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 field-introspect-type Token (deref type-token))
(var core-type-token (* (const Token)) type-token)
(var core-type-token-index int type-token-index)
(var array-count-token (* (const Token)) null)
(when (and (= (path core-type-token > type) TokenType_OpenParen)
(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)))
;; (Log "Found array. core-type-token is now ") (printFormattedToken stderr (deref core-type-token)) (Log "\n")
)
(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 possible-string-introspect-type (* (const char)) null)
(var type-is-string bool false)
(var field-type-metadata-token Token (deref type-token))
(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))
(cond
((std-str-equals (path type-token > contents) "int")
((std-str-equals (path core-type-token > contents) "int")
(set determined-type-string "introspect-type-int"))
((std-str-equals (path type-token > contents) "float")
((std-str-equals (path core-type-token > contents) "float")
(set determined-type-string "introspect-type-float"))
((std-str-equals (path type-token > contents) "bool")
((std-str-equals (path core-type-token > contents) "bool")
(set determined-type-string "introspect-type-bool"))
((std-str-equals (path type-token > contents) "char")
((std-str-equals (path core-type-token > contents) "char")
(set determined-type-string "introspect-type-char"))
((is-type-string tokens type-token-index (addr possible-string-introspect-type))
((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 type-token) "cannot generate metadata for unknown type")
;; (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?
@ -135,34 +158,41 @@
(var substruct-type-metadata ([] 128 char) (array 0))
(introspect-metadata-name-from-struct-name
substruct-type-metadata (sizeof substruct-type-metadata)
(call-on c_str (path type-token > contents)))
(call-on c_str (path core-type-token > contents)))
(set (field field-type-metadata-token contents) substruct-type-metadata)))
(set (field field-introspect-type contents) determined-type-string)
(var field-count Token (deref type-token))
(set (field field-count type) TokenType_Symbol)
(set (field field-count contents) "0")
(if (not (call-on empty (field field-type-metadata-token contents)))
(tokenize-push (deref fields-metadata)
(array (token-splice-addr name-to-string-token)
(token-splice-addr field-introspect-type)
(addr (token-splice-addr field-type-metadata-token))
(offsetof (type (token-splice struct-name)) (token-splice name-token))
(token-splice-addr field-count)
(array null null)))
(tokenize-push (deref fields-metadata)
(array (token-splice-addr name-to-string-token)
(token-splice-addr field-introspect-type)
null
(offsetof (type (token-splice struct-name)) (token-splice name-token))
(token-splice-addr field-count)
(array null null)))))
(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
(addr (token-splice-addr field-type-metadata-token))))
(var field-type-element-size (<> (in std vector) Token))
(if type-is-string
(tokenize-push field-type-element-size (sizeof char))
(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 null null))))
;; 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))
@ -196,7 +226,7 @@
;;
(defenum introspect-type
introspect-type-override ;; Use custom callbacks when operating on this type
;; introspect-type-override ;; Use custom callbacks when operating on this type
introspect-type-int
introspect-type-float
@ -218,6 +248,7 @@
type introspect-type
field-type-metadata (* metadata-struct)
offset size_t
element-size size_t
count size_t ;; For arrays
;; Tags are arbitrarily limited to 2. They are strings to facilitate cross-executable
;; communication as well as not require any enum updating
@ -236,39 +267,65 @@
(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))
(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)
(defun-local bool-to-string (value bool &return (* (const char)))
(return (? value "true" "false")))
;; TODO Make const correct, expose
;; TODO Make const correct
;; TODO Escape quotes, newlines, etc.
(defun-local write-introspect-struct-sexp (struct-metadata (* metadata-struct)
struct-to-write (* void)
out-file (* FILE)
write-options write-introspect-struct-options)
(defun write-introspect-struct-s-exp (struct-metadata (* metadata-struct)
struct-to-write (* void)
out-file (* FILE)
write-options write-introspect-struct-options)
(fprintf out-file "(%s" (path struct-metadata > name))
(each-in-range (path struct-metadata > num-members) i
(var field (* 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)
(var int-write (* int)
(offset-pointer-to-type struct-to-write (path field > offset) (* int)))
(fprintf out-file " %d" (deref int-write)))
(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-int)
;; (var int-write (* int)
;; (offset-pointer-to-type struct-to-write (path field > offset) (* int)))
;; (fprintf out-file " %d" (deref int-write)))
((= (path field > type) introspect-type-float)
(var float-write (* float)
(offset-pointer-to-type struct-to-write (path field > offset) (* float)))
(fprintf out-file " %f" (deref float-write)))
(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)
(var bool-write (* bool)
(offset-pointer-to-type struct-to-write (path field > offset) (* bool)))
(fprintf out-file " %s" (bool-to-string (deref bool-write))))
(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)))
@ -277,25 +334,31 @@
;; Strings
((= (path field > type) introspect-type-fixed-size-string)
(var str-write (* (const char))
(offset-pointer-to-type struct-to-write (path field > offset) (* (const char))))
;; TODO: This will require quoting any '"' in the string (etc.)
(fprintf out-file " \"%s\"" (? str-write str-write "")))
(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)
(var str-write (* (* (const char)))
(offset-pointer-to-type struct-to-write (path field > offset) (* (* (const char)))))
;; TODO: This will require quoting any '"' in the string (etc.)
(fprintf out-file " \"%s\"" (? (deref str-write) (deref str-write) "")))
(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) ""))))
((= (path field > type) introspect-type-introspect-struct)
(var substruct-write (* void)
(offset-pointer-to-type struct-to-write (path field > offset) (* void)))
(fprintf out-file " ")
(write-introspect-struct-sexp (path field > field-type-metadata)
substruct-write out-file
write-introspect-struct-default))
(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-exp (path field > field-type-metadata)
substruct-write out-file
write-introspect-struct-default)))
(true
(fprintf out-file " <unknown>")
(fprintf stderr "warning: attempted to write field of unknown type %d\n" (path field > type))))
(when (path field > count)
(fprintf out-file ")"))
(when (< i (- (path struct-metadata > num-members) 1))
(fprintf out-file "\n")))
@ -316,6 +379,7 @@
(defun-local set-metadata-field-from-string (field (* metadata-field)
struct-out (* void)
value-offset size_t
in-string (* (const char)) value-length size_t
string-allocate allocate-string-function
&return bool)
@ -323,28 +387,33 @@
;; Numeric and boolean types
((= (path field > type) introspect-type-int)
(var int-write (* int)
(offset-pointer-to-type struct-out (path field > offset) (* 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 (path field > offset) (* 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 (path field > offset) (* bool)))
(if (= 0 (strcmp "true" in-string))
(set (deref bool-write) true)
(set (deref bool-write) false)))
(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 (path field > offset) (* 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 (path field > offset) (* char)))
(offset-pointer-to-type struct-out value-offset (* char)))
;; TODO Validate size
(strncpy str-write in-string value-length))
((= (path field > type) introspect-type-string)
@ -352,7 +421,7 @@
(unless value-length
(return true))
(var str-write (* (* (const char)))
(offset-pointer-to-type struct-out (path field > offset) (* (* (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 (+ 1 value-length) copied-string) 0)
@ -361,11 +430,11 @@
;; Nested introspectable structs
((= (path field > type) introspect-type-introspect-struct)
(var substruct-out (* void)
(offset-pointer-to-type struct-out (path field > offset) (* void)))
(return (read-introspect-struct-sexp (path field > field-type-metadata)
substruct-out
in-string
string-allocate)))
(offset-pointer-to-type struct-out value-offset (* void)))
(return (read-introspect-struct-s-exp (path field > field-type-metadata)
substruct-out
in-string
string-allocate)))
(true
(fprintf stderr "error: do not know how to parse field '%s' with type %d from string \"%s\"\n"
@ -383,9 +452,9 @@
;; Hack to avoid Emacs getting confused by ')'
(var close-paren (const char) (at 0 ")"))
(defun-local sexp-get-next-argument-start-end (in-string (* (const char))
start-out (* (* (const char)))
end-out (* (* (const char))))
(defun-local s-exp-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
@ -447,11 +516,11 @@
(set (deref end-out) (+ 1 current-char))
(break))))))))
(defun read-introspect-struct-sexp (struct-metadata (* metadata-struct)
struct-out (* void)
in-string (* (const char))
string-allocate allocate-string-function
&return bool)
(defun read-introspect-struct-s-exp (struct-metadata (* metadata-struct)
struct-out (* void)
in-string (* (const char))
string-allocate allocate-string-function
&return bool)
;; 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)
@ -494,7 +563,7 @@
(var argument-start (* (const char)) null)
(var argument-end (* (const char)) null)
(var current-char (* (const char)) struct-member-start)
(sexp-get-next-argument-start-end current-char (addr argument-start) (addr argument-end))
(s-exp-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)
@ -517,45 +586,75 @@
(set found-field true)
(break)))
(unless found-field
(fprintf stderr "encountered unknown field named ")
(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-length size_t (- argument-end argument-start))
(cond
((= (deref argument-start) '\"') ;; Strings
(unless (set-metadata-field-from-string current-field struct-out
;; Trim the open and close quotes
(+ 1 argument-start)
(- argument-end 1 (+ 1 argument-start))
string-allocate)
(return false)))
((= (deref argument-start) '\(') ;; Nested structures or arrays
(unless (set-metadata-field-from-string current-field struct-out
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 argument-start argument-end true)
(return false))
(memcpy basic-type-buffer argument-start value-length)
(unless (set-metadata-field-from-string current-field struct-out
basic-type-buffer value-length
string-allocate)
(return false))))
(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-exp-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))
(cond
((= (deref value-argument-start) '\"') ;; Strings
(unless (set-metadata-field-from-string 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 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 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-exp-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)))
(sexp-get-next-argument-start-end argument-end (addr argument-start) (addr argument-end)))
(s-exp-get-next-argument-start-end argument-end (addr argument-start) (addr argument-end)))
(return true))
(defun-local free-introspect-struct-fields (struct-metadata (* metadata-struct)
struct-to-destroy (* void)
string-free free-string-function)
(defun free-introspect-struct-fields (struct-metadata (* metadata-struct)
struct-to-destroy (* void)
string-free free-string-function)
(each-in-range (path struct-metadata > num-members) i
(var field (* metadata-field) (addr (at i (path struct-metadata > members))))
(cond
@ -591,35 +690,44 @@
(cond
;; Numeric and boolean types
((= (path field > type) introspect-type-int)
(var int-a (* int)
(offset-pointer-to-type struct-a (path field > offset) (* int)))
(var int-b (* int)
(offset-pointer-to-type struct-b (path field > offset) (* int)))
(when (!= (deref int-a) (deref int-b))
(when print-difference
(fprintf stderr "structs differ by field '%s' (%d vs %d)\n" (path field > name)
(deref int-a) (deref int-b)))
(return (- int-a int-b))))
(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)
(var float-a (* float)
(offset-pointer-to-type struct-a (path field > offset) (* float)))
(var float-b (* float)
(offset-pointer-to-type struct-b (path field > offset) (* float)))
(when (!= (deref float-a) (deref float-b))
(when print-difference
(fprintf stderr "structs differ by field '%s' (%f vs %f)\n" (path field > name)
(deref float-a) (deref float-b)))
(return (- float-a float-b))))
(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))
(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)
(var bool-a (* bool)
(offset-pointer-to-type struct-a (path field > offset) (* bool)))
(var bool-b (* bool)
(offset-pointer-to-type struct-b (path field > offset) (* bool)))
(when (!= (deref bool-a) (deref bool-b))
(when print-difference
(fprintf stderr "structs differ by field '%s' (%s vs %s)\n" (path field > name)
(bool-to-string (deref bool-a)) (bool-to-string (deref bool-b))))
(return (? bool-a 1 -1))))
(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)))
@ -628,59 +736,67 @@
;; 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)
(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)
(var str-a (* (const char))
(offset-pointer-to-type struct-a (path field > offset) (* (const char))))
(var str-b (* (const char))
(offset-pointer-to-type struct-b (path field > offset) (* (const char))))
(var result int (strcmp str-a str-b))
(when (!= 0 result)
(when print-difference
(fprintf stderr "structs differ by field '%s' (%s vs %s)\n" (path field > name)
str-a str-b))
(return result)))
(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)
(var str-a (* (* (const char)))
(offset-pointer-to-type struct-a (path field > offset) (* (* (const char)))))
(var str-b (* (* (const char)))
(offset-pointer-to-type struct-b (path field > 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' ('%s' vs '%s')\n" (path field > name)
(deref str-a) (deref str-b)))
(return result)))
(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)
(var substruct-a (* void)
(offset-pointer-to-type struct-a (path field > offset) (* void)))
(var substruct-b (* void)
(offset-pointer-to-type struct-b (path field > 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)))
(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))))
(true
(fprintf stderr "error: do not know how to parse field '%s' with type %d\n"
@ -688,20 +804,20 @@
(return -1))))
(return 0))
(defun-local compare-introspect-struct (struct-metadata (* metadata-struct)
struct-a (* void)
struct-b (* void)
&return int)
(defun compare-introspect-struct (struct-metadata (* metadata-struct)
struct-a (* void)
struct-b (* void)
&return int)
(return (compare-introspect-struct-internal
struct-metadata
struct-a
struct-b
false)))
(defun-local compare-introspect-struct-print-result (struct-metadata (* metadata-struct)
struct-a (* void)
struct-b (* void)
&return int)
(defun compare-introspect-struct-print-result (struct-metadata (* metadata-struct)
struct-a (* void)
struct-b (* void)
&return int)
(return (compare-introspect-struct-internal
struct-metadata
struct-a
@ -729,34 +845,35 @@
value int
decimal float
bad ([] 3 float) (ignore)
support-arrays ([] 3 float)
truthy bool
charry char
nested my-nested-struct)
(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)
42 -0.33f (array 0.f 1.f 2.f) (array 10.f 20.f 30.f)
false 'a'
(array "Hello!" true)))
(write-introspect-struct-sexp (addr my-struct--metadata) (addr a) stderr
write-introspect-struct-add-newline)
(write-introspect-struct-s-exp (addr my-struct--metadata) (addr a) stderr
write-introspect-struct-add-newline)
(scope ;; Write to a file
(var out-file (* FILE) (fopen "TestSerialize.cake" "w"))
(var out-file (* FILE) (fopen "TestSerialize.cakedata" "w"))
(unless out-file (return 1))
(write-introspect-struct-sexp (addr my-struct--metadata) (addr a) out-file
write-introspect-struct-add-newline)
(write-introspect-struct-s-exp (addr my-struct--metadata) (addr a) out-file
write-introspect-struct-add-newline)
(fclose out-file))
(scope ;; Now read it back
(var read-struct my-struct (array 0))
(scope
(var in-file (* FILE) (fopen "TestSerialize.cake" "r"))
(var in-file (* FILE) (fopen "TestSerialize.cakedata" "r"))
(unless in-file (return 1))
(var file-contents (* (const char)) (read-file-into-memory in-file))
(unless (read-introspect-struct-sexp (addr my-struct--metadata) (addr read-struct)
file-contents malloc)
(unless (read-introspect-struct-s-exp (addr my-struct--metadata) (addr read-struct)
file-contents malloc)
(free (type-cast file-contents (* void)))
(fclose in-file)
(return 1))
@ -764,8 +881,8 @@
(free (type-cast file-contents (* void)))
(fclose in-file))
(write-introspect-struct-sexp (addr my-struct--metadata) (addr read-struct) stderr
write-introspect-struct-add-newline)
(write-introspect-struct-s-exp (addr my-struct--metadata) (addr read-struct) stderr
write-introspect-struct-add-newline)
;; (set (field read-struct value) 0)
(unless (= 0 (compare-introspect-struct-print-result (addr my-struct--metadata)
@ -779,6 +896,22 @@
(free-introspect-struct-fields
(addr my-struct--metadata) (addr read-struct) free))
(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))
(when (read-introspect-struct-s-exp (addr my-struct--metadata) (addr read-struct)
file-contents malloc)
(fprintf stderr "error: expected to fail to read struct from Errors.cakedata\n")
(free (type-cast file-contents (* void)))
(fclose in-file)
(return 1))
(free (type-cast file-contents (* void)))
(fclose in-file)))
(free (field a yet-another-name))
(return 0))))

11
test/Errors.cakedata

@ -0,0 +1,11 @@
(my-struct :name "Test struct"
:other-name "Other name"
:yet-another-name "Another name"
:optional-name ""
:value 42
:decimal -0.330000
:support-arrays (array 1.f 2.f)
:truthy false
:charry 97
:nested (my-nested-struct :message "Hello!"
:is-awesome true))

4
tools/gamelib.el

@ -9,6 +9,8 @@
(put 'imgui-call 'lisp-indent-function 1)
(put 'scope-timed 'lisp-indent-function 1))
(put 'scope-timed 'lisp-indent-function 1)
(put 'introspect-field-dispatch 'lisp-indent-function 2))
(add-hook 'cakelisp-mode-hook 'gamelib-cakelisp-mode)

Loading…
Cancel
Save