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

529 lines
24 KiB

(set-cakelisp-option cakelisp-src-dir "Dependencies/cakelisp/src")
(add-cakelisp-search-directory "Dependencies/cakelisp/runtime")
(import &comptime-only "CHelpers.cake")
(import &comptime-only "STB.cake")
(use-stb-ds clone-stb-headers-dictionary)
;;
;; Hash table with string keys
;;
;; Automatically allocate each string key to a string arena
(def-c-function-alias strdict-use-key-arena sh_new_arena)
;; Automatically strdup and free string keys
(def-c-function-alias strdict-use-key-strdup sh_new_strdup)
(def-c-function-alias strdict-length shlenu)
;; (dict (* <your Key Value type>) &return size_t)
(def-c-function-alias strdict-free shfree)
;; (dict (* <your Key Value type>))
;; These are used for the following functions:
;; - strdict-ptr-or-default-at
;; - strdict-struct-at
;; - strdict-value-at
(def-c-function-alias strdict-set-not-found-default shdefaults)
;; (dict (* <your Key Value type>) item <your Key Value type>
;; &return <your Key Value type>)
(def-c-function-alias strdict-set-not-found-default-value shdefault)
;; (dict (* <your Key Value type>) value <your Value type>
;; &return <your Value type>)
;; Setting
(def-c-function-alias strdict-set-key-value shput)
;; (dict (* <your Key Value type>) key (* char) value <your Value type>
;; &return <your Value type>)
;; Requires a key field
(def-c-function-alias strdict-set-struct shputs)
;; (dict (* <your Key Value type>) item <your Key Value type> &return <your Key Value type>)
;; Getting
(def-c-function-alias strdict-ptr-at shgetp_null)
;; (dict (* <your Key Value type>) key (* (const char)) &return (* <your Key Value type>))
(def-c-function-alias strdict-ptr-or-default-at shgetp)
;; (dict (* <your Key Value type>) key (* (const char)) &return (* <your Key Value type>))
(def-c-function-alias strdict-index-at shgeti)
;; (dict (* <your Key Value type>) key (* (const char)) &return ptrdiff_t)
(def-c-function-alias strdict-struct-at shgets)
;; (dict (* <your Key Value type>) key (* (const char)) &return <your Key Value type>)
(def-c-function-alias strdict-value-at shget)
;; (dict (* <your Key Value type>) &return <your value type>)
(defmacro each-in-strdict (strdict any index-iterator-name symbol &rest body any)
(tokenize-push output
(c-for
(var (token-splice index-iterator-name) size_t 0)
;; We could hoist this out but it should be a quick op anyways
(< (token-splice index-iterator-name) (strdict-length (token-splice strdict)))
(incr (token-splice index-iterator-name))
(token-splice-rest body tokens)))
(return true))
(defmacro each-key-in-strdict (strdict any index-iterator-name symbol
key-name symbol &rest body any)
(tokenize-push output
(c-for
(var (token-splice index-iterator-name) size_t 0)
;; We could hoist this out but it should be a quick op anyways
(< (token-splice index-iterator-name) (strdict-length (token-splice strdict)))
(incr (token-splice index-iterator-name))
(var (token-splice key-name) (* char)
(field (at (token-splice index-name strdict)) key))
(token-splice-rest body tokens)))
(return true))
(defmacro each-item-in-strdict (strdict any index-name symbol
item-name symbol item-type any
&rest body any)
(tokenize-push output
(each-in-strdict (token-splice strdict) (token-splice index-name)
(var (token-splice item-name item-type) (at (token-splice index-name strdict)))
(token-splice-rest body tokens)))
(return true))
(defmacro each-item-addr-in-strdict (strdict any index-name symbol
item-name symbol ptr-to-item-type any
&rest body any)
(tokenize-push output
(each-in-strdict (token-splice strdict) (token-splice index-name)
(var (token-splice item-name ptr-to-item-type)
(addr (at (token-splice index-name strdict))))
(token-splice-rest body tokens)))
(return true))
;;
;; Hash table with arbitrary key
;;
(def-c-function-alias dict-length hmlenu)
;; (dict (* <your Key Value type>) &return size_t)
(def-c-function-alias dict-free hmfree)
;; (dict (* <your Key Value type>))
;; These are used for the following functions:
;; - dict-ptr-or-default-at
;; - dict-struct-at
;; - dict-value-at
(def-c-function-alias dict-set-not-found-default hmdefaults)
;; (dict (* <your Key Value type>) item <your Key Value type>
;; &return <your Key Value type>)
(def-c-function-alias dict-set-not-found-default-value hmdefault)
;; (dict (* <your Key Value type>) value <your Value type>
;; &return <your Value type>)
;; Setting
(def-c-function-alias dict-set-key-value hmput)
;; (dict (* <your Key Value type>) key <your Key type> value <your Value type>
;; &return <your Value type>)
;; Requires a key field
(def-c-function-alias dict-set-struct hmputs)
;; (dict (* <your Key Value type>) item <your Key Value type> &return <your Key Value type>)
;; Getting
(def-c-function-alias dict-ptr-at hmgetp_null)
;; (dict (* <your Key Value type>) key <your Key type> &return (* <your Key Value type>))
(def-c-function-alias dict-ptr-or-default-at hmgetp)
;; (dict (* <your Key Value type>) key <your Key type> &return (* <your Key Value type>))
(def-c-function-alias dict-index-at hmgeti)
;; (dict (* <your Key Value type>) key <your Key type> &return ptrdiff_t)
(def-c-function-alias dict-struct-at hmgets)
;; (dict (* <your Key Value type>) key <your Key type> &return <your Key Value type>)
(def-c-function-alias dict-value-at hmget)
;; (dict (* <your Key Value type>) &return <your value type>)
(defmacro each-key-in-dict (dict any index-iterator-name symbol
key-name symbol key-type symbol &rest body any)
(tokenize-push output
(c-for
(var (token-splice index-iterator-name) size_t 0)
;; We could hoist this out but it should be a quick op anyways
(< (token-splice index-iterator-name) (dict-length (token-splice dict)))
(incr (token-splice index-iterator-name))
(var (token-splice key-name) (token-splice key-type)
(field (at (token-splice index-name dict)) key))
(token-splice-rest body tokens)))
(return true))
(defmacro each-item-in-dict (dict any index-iterator-name symbol
item-name symbol ptr-to-item-type any &rest body any)
(tokenize-push output
(c-for
(var (token-splice index-iterator-name) size_t 0)
;; We could hoist this out but it should be a quick op anyways
(< (token-splice index-iterator-name) (dict-length (token-splice dict)))
(incr (token-splice index-iterator-name))
(var (token-splice item-name) (token-splice ptr-to-item-type)
(addr (at (token-splice index-iterator-name dict))))
(token-splice-rest body tokens)))
(return true))
(defmacro each-item-addr-in-dict (dict any index-name symbol
item-name symbol ptr-to-item-type any
&rest body any)
(tokenize-push output
(each-in-dict (token-splice dict) (token-splice index-name)
(var (token-splice item-name ptr-to-item-type)
(addr (at (token-splice index-name dict))))
(token-splice-rest body tokens)))
(return true))
;;
;; Introspection
;;
(comptime-cond
('Introspection
(import "Introspection.cake")
(defmacro dict-header-pointer-void (void-ptr-to-dict any element-size any)
(tokenize-push output
(stbds_header (- (type-cast (token-splice void-ptr-to-dict) (* char))
(token-splice element-size))))
(return true))
(defmacro dict-get-length-void (void-ptr-to-dict any element-size any)
(tokenize-push output
(? (token-splice void-ptr-to-dict)
(- (path
(dict-header-pointer-void (token-splice void-ptr-to-dict element-size))
> length)
1)
0))
(return true))
(defmacro dict-free-void (void-ptr-to-dict any element-size any)
(tokenize-push output
(when (token-splice void-ptr-to-dict)
(stbds_hmfree_func (dict-header-pointer-void (token-splice void-ptr-to-dict element-size))
(token-splice element-size))))
(return true))
(defmacro dict-set-struct-void (void-ptr-to-dict any element-size any
new-element-key any new-element-key-size any
struct-to-add any)
(tokenize-push output
(set (deref (token-splice void-ptr-to-dict))
(stbds_hmput_key_wrapper (deref (token-splice void-ptr-to-dict))
(token-splice element-size)
(addr (token-splice new-element-key))
(token-splice new-element-key-size)
STBDS_HM_BINARY))
(memcpy
(+ (* (token-splice element-size)
(path (dict-header-pointer-void (token-splice void-ptr-to-dict element-size)) > temp))
(type-cast (deref (token-splice void-ptr-to-dict)) (* char)))
(token-splice struct-to-add)
(token-splice element-size)))
(return true))
;; Protect against really crazy array sizes due to e.g. text parsing error
(var reasonable-max-dictionary-read-length (const int) 100000)
(introspect-override-register-handler 'write-s-expr
(metadata-field-has-tag field "'dictionary")
write-dictionary-ptr
(var dictionary-ptr-write (* (* void))
(offset-pointer-to-type struct-to-write value-offset (* (* void))))
(if (and (deref dictionary-ptr-write)
(dict-get-length-void (deref dictionary-ptr-write)
(path (path field > field-type-metadata) > struct-size)))
(scope
(fprintf out-file " (dictionary ")
(var num-elements int
(dict-get-length-void (deref dictionary-ptr-write)
(path (path field > field-type-metadata) > struct-size)))
;; NOT required, because otherwise it'd make hand-editing a pain. This is for performance
;; only; the reader should not take this as a guarantee, hence "hint"
(fprintf out-file ":length-hint %d " num-elements)
(each-in-range num-elements i
(var current-element (* void)
(offset-pointer-to-type (deref dictionary-ptr-write)
(* i (path (path field > field-type-metadata) > struct-size))
(* void)))
(unless (write-introspect-struct-s-expr
(path field > field-type-metadata)
current-element out-file
;; TODO: Pay attention to parent output settings
(? (= i (- num-elements 1)) write-introspect-struct-default
write-introspect-struct-add-newline))
(return false)))
(fprintf out-file ")"))
(fprintf out-file " null"))
(return true))
(introspect-override-register-handler 'read-s-expr
(metadata-field-has-tag field "'dictionary")
read-dictionary-ptr
(var dictionary-ptr-read (* (* void))
(offset-pointer-to-type struct-out value-offset (* (* void))))
;; You need to clean up the elements; I'd just clear them in this function, but that could lead
;; to memory leaks
(assert (not (dict-get-length-void (deref dictionary-ptr-read)
(path (path field > field-type-metadata) > struct-size))))
;; Determine some details about elements
(var element-key-offset size_t 0)
(var element-key-size size_t 0)
(each-in-range (path field > field-type-metadata > num-members) i
(var possible-key-field (* (const metadata-field))
(addr (at i (path field > field-type-metadata > members))))
(when (= 0 (strcmp "key" (path possible-key-field > name)))
(set element-key-offset (path possible-key-field > offset))
(set element-key-size (path possible-key-field > element-size))
(break)))
(unless element-key-size
(fprintf stderr "error: failed to find field named \"key\" in element struct %s\n"
(path field > field-type-metadata > name))
(dict-free-void (deref dictionary-ptr-read)
(path (path field > field-type-metadata) > struct-size))
(set (deref dictionary-ptr-read) null)
(return false))
(var start-tag (* (const char)) "(dictionary")
(var start-tag-length (const size_t) (strlen start-tag))
(var length-hint-tag (* (const char)) ":length-hint")
(var length-hint-tag-length (const size_t) (strlen length-hint-tag))
(unless (= 0 (strncmp start-tag value-argument-start start-tag-length))
(fprintf stderr "error: expected \"%s\", got \"%s\"\n" start-tag value-argument-start)
(return false))
(var start-arguments (* (const char)) (+ value-argument-start start-tag-length))
(var argument-start (* (const char)) null)
(var argument-end (* (const char)) null)
(s-expr-get-next-argument-start-end start-arguments (addr argument-start) (addr argument-end))
(while (and argument-start argument-end)
(cond
((= 0 (strncmp length-hint-tag argument-start length-hint-tag-length))
(s-expr-get-next-argument-start-end argument-end (addr argument-start)
(addr argument-end))
;; TODO Reduce duplication!
(var basic-type-buffer ([] 64 char) (array 0))
(var value-length size_t (- argument-end argument-start))
(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)
(var length-hint int (atoi basic-type-buffer))
(assert (< length-hint reasonable-max-dictionary-read-length))
(ignore ;; TODO: Dictionary initial size, which doesn't seem exposed by stb
(fprintf stderr "Reserving capacity %d\n" length-hint)
(dict-set-capacity-with-element-size
dictionary-ptr-read
(path (path field > field-type-metadata) > struct-size)
length-hint)))
(true
;; TODO: Expose option to not use malloc
(var new-element (* void) (malloc (path (path field > field-type-metadata) > struct-size)))
(unless (read-introspect-struct-s-expr (path field > field-type-metadata)
new-element
argument-start string-allocate)
(fprintf stderr "error: failed to read element into dictionary: ")
(print-string-range argument-start argument-end true)
(dict-free-void (deref dictionary-ptr-read)
(path (path field > field-type-metadata) > struct-size))
(set (deref dictionary-ptr-read) null)
(return false))
(var new-element-key (* void)
(offset-pointer-to-type new-element element-key-offset (* void)))
(dict-set-struct-void dictionary-ptr-read
(path (path field > field-type-metadata) > struct-size)
new-element-key element-key-size
new-element)))
(s-expr-get-next-argument-start-end argument-end (addr argument-start)
(addr argument-end)))
(return true))
;; (introspect-override-register-handler 'compare
;; (metadata-field-has-tag field "'dictionary")
;; compare-dictionary
;; (var dictionary-a (* (* void))
;; (offset-pointer-to-type struct-a value-offset (* (* void))))
;; (var dictionary-b (* (* void))
;; (offset-pointer-to-type struct-b value-offset (* (* void))))
;; (when (!= (deref dictionary-a) (deref dictionary-b))
;; (var num-elements-a int (dict-get-length-void (deref dictionary-a)
;; (path (path field > field-type-metadata) > struct-size)))
;; (var num-elements-b int (dict-get-length-void (deref dictionary-b)
;; (path (path field > field-type-metadata) > struct-size)))
;; (when (!= num-elements-a num-elements-b)
;; (when print-difference
;; (fprintf stderr "structs differ by field '%s' [%d] length (%d vs %d)\n"
;; (path field > name)
;; (type-cast dispatch-value-index int)
;; (type-cast (dict-length dictionary-a) int)
;; (type-cast (dict-length dictionary-b) int)))
;; (return (- num-elements-a num-elements-b)))
;; (each-in-range num-elements-a i
;; (var current-element-a (* void)
;; (offset-pointer-to-type (deref dictionary-a)
;; (* i (path (path field > field-type-metadata) > struct-size))
;; (* void)))
;; (var current-element-b (* void)
;; (offset-pointer-to-type (deref dictionary-b)
;; (* i (path (path field > field-type-metadata) > struct-size))
;; (* void)))
;; (var return-value int
;; (compare-introspect-struct-internal (path field > field-type-metadata)
;; current-element-a
;; current-element-b
;; print-difference))
;; (when (!= 0 return-value)
;; (when print-difference
;; (fprintf stderr "structs differ by field '%s' [%d][%d]\n"
;; (path field > name)
;; (type-cast dispatch-value-index int) i))
;; (return return-value))))
;; (return 0))
;; (introspect-override-register-handler 'free
;; (metadata-field-has-tag field "'dictionary")
;; free-dict-ptr
;; (var dict-ptr (* (* void))
;; (offset-pointer-to-type struct-to-destroy value-offset (* (* void))))
;; (dict-free (deref dict-ptr))
;; (set (deref dict-ptr) null))
))
;;
;; Tests
;;
(comptime-cond
('auto-test
(c-import "stdio.h")
(defun test--dictionary (&return int)
(scope ;; Simple key value entries
(defstruct dictionary-entry
key (* char)
value (* (const char)))
(var my-dictionary (* dictionary-entry) null)
(strdict-use-key-arena my-dictionary)
(strdict-set-key-value my-dictionary "cakelisp" "a programming language")
(strdict-set-key-value my-dictionary "gamelib" "a helpful library")
(var keys ([] (* (const char))) (array "cakelisp" "gamelib"))
(each-in-array keys i
(var returned-entry-copy (* (const char)) (strdict-value-at my-dictionary (at i keys)))
(unless returned-entry-copy
(fprintf stderr "Expected to get string back. Length: %ld\n"
(strdict-length my-dictionary))
(return 1))
(fprintf stderr "what is %s? %s\n" (at i keys) returned-entry-copy)
(var entry-index ptrdiff_t (strdict-index-at my-dictionary (at i keys)))
(unless (>= entry-index 0)
(fprintf stderr "Expected to get entry index back\n")
(return 1))
(fprintf stderr "Element is at %d (%p). Key = %s\n" (type-cast entry-index int)
(addr (at entry-index my-dictionary))
(field (at entry-index my-dictionary) key))
(var returned-entry (* dictionary-entry) (strdict-ptr-or-default-at my-dictionary (at i keys)))
(unless (and returned-entry (path returned-entry > key) (path returned-entry > value))
(fprintf stderr "Expected to get valid entry back, got %p (array[-1] = %p). Length: %ld\n"
returned-entry (addr (at -1 my-dictionary)) (strdict-length my-dictionary))
(return 1))
(fprintf stderr "what is %s (%p)? %s\n"
(path returned-entry > key) (path returned-entry > key)
(path returned-entry > value)))
(strdict-free my-dictionary))
(scope ;; Arbitrary fields dictionary
(defstruct complex-dictionary-entry
key (* char)
thing-category (* (const char))
thing-description (* (const char)))
(var my-dictionary (* complex-dictionary-entry) null)
(strdict-use-key-arena my-dictionary)
(var items ([] complex-dictionary-entry)
(array
(array (strdup "cakelisp") "programming language" "cakelisp is a programming language")
(array (strdup "gamelib") "library" "gamelib is a library for making games")))
(each-in-array items i
(strdict-set-struct my-dictionary (at i items)))
(unless (= (array-size items) (strdict-length my-dictionary))
(fprintf stderr "Expected size %d, got %d"
(type-cast (array-size items) int)
(type-cast (strdict-length my-dictionary) int))
(return 1))
(each-in-array items i
(var returned-entry (* complex-dictionary-entry)
(strdict-ptr-or-default-at my-dictionary (field (at i items) key)))
(unless (and returned-entry
(path returned-entry > key)
(path returned-entry > thing-category)
(path returned-entry > thing-description))
(fprintf stderr "Expected to get valid entry back, got %p (array[-1] = %p). Length: %ld\n"
returned-entry (addr (at -1 my-dictionary)) (strdict-length my-dictionary))
(return 1))
(fprintf stderr "What is %s? (%s) %s\n"
(path returned-entry > key)
(path returned-entry > thing-category)
(path returned-entry > thing-description)))
(each-item-addr-in-strdict my-dictionary i entry (* complex-dictionary-entry)
(fprintf stderr "[%d] %s = %s\n" (type-cast i int)
(path entry > key)
(path entry > thing-description)))
(scope
(var returned-entry (* complex-dictionary-entry)
(strdict-ptr-or-default-at my-dictionary "bad value"))
(fprintf stderr "Expected to get default (not found) entry back, got %p (array[-1] = %p).
Length: %ld\n"
returned-entry (addr (at -1 my-dictionary)) (strdict-length my-dictionary))
(unless (= returned-entry (addr (at -1 my-dictionary)))
(return 1)))
(scope
(var returned-entry (* complex-dictionary-entry)
(strdict-ptr-at my-dictionary "bad value"))
(fprintf stderr "Expected to get null back, got %p (array[-1] = %p). Length: %ld\n"
returned-entry (addr (at -1 my-dictionary)) (strdict-length my-dictionary))
(when returned-entry
(return 1)))
(each-in-array items i
(free (type-cast (field (at i items) key) (* void))))
(strdict-free my-dictionary))
(return 0))
(comptime-cond
('Introspection
(import "Introspection.cake")
(def-introspect-struct dict-entry
key int
value float)
(def-introspect-struct my-dict
dictionary (* dict-entry) (override 'dictionary)) ;; TODO strdict
(defun test--dictionary-introspection (&return int)
(var baseline my-dict (array 0))
(var my-entry dict-entry (array 1 42.f))
(dict-set-struct (field baseline dictionary) my-entry)
;; (dynarray-set-length (field baseline items) 10)
;; (each-item-addr-in-dynarray (field baseline items) i data (* array-data)
;; (set (path data > value) (type-cast i float)))
(unless (introspect-test-struct my-dict--metadata (addr baseline)
"TestDictionarySerialize.cakedata")
(return 1))
(free-introspect-struct-fields my-dict--metadata (addr baseline) free)
(return 0))))))