|
|
|
@ -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)))) |
|
|
|
|
