# [ʞ] c-bind-gen.janet
# ~ lexi hale <lexi@hale.su>, may the gods have mercy on
# the tattered remnants of my soul
# 🄯 CC0 (please, megacorps, im begging you, steal this
# piece of shit. YOUVE EARNED IT)
# > janet tool/c-bind-gen.janet (header|loader)
#
# ! look, im not gonna bullshit you. this code is terrible
# i started writing it when i was still getting the hang
# of janet, in particular working with its lispified OOP
# system, and i made some terrible mistakes. in
# particular because i've never actually used a proper
# prototype-based object system before (lua doesn't
# really count here). at some point i realized the code
# was unfixably bad and i just stopped caring. at some
# point, if this project goes anywhere, this whole
# gibbering aberration deserves to be ripped out and
# redone from scratch, ideally using some of the cleaner
# mechanisms i ended up putting together for
# tool/class-compile.janet
(import :/lib/json)
(def <gd-sym> (let
[transform (fn[{:seg segments} tx delim]
(string/join (map tx segments) delim))
capitalize (fn[x] (string
(string/ascii-upper (slice x 0 1))
(slice x 1)))]
{:@inherit (fn gd-sym:inherit[class & defs]
(struct/with-proto class ;defs))
:@new (fn gd-sym:new[class & args]
(struct/with-proto class ;((class :%init) ;args)))
:%init (fn gd-sym:init[dfn]
[:id (dfn :id)
:seg (get dfn :seg [;(string/split "-" (string (dfn :id)))])])
:from |(:@new $0 {:id $1})
:from-snek |(as-> $1 x
(string/ascii-lower x)
(string/split "_" x)
{:id (string/join x "-")
:seg x}
(:@new $0 x))
:vstr |(if (> ($ :ver) 1) (string ($ :ver)) "")
:tall |(transform $ capitalize "")
:sulk |(transform $ identity "_")
:scream |(transform $ string/ascii-upper "_")
:name |(apply string [ (first ($ :seg))
;(map capitalize (slice ($ :seg) 1))])}))
(def <gd-method>
(:@inherit <gd-sym>
:%init (fn [spec]
[ ;((<gd-sym> :%init) spec)
:ver (spec :ver) ])))
(def <gd-type>
(:@inherit <gd-sym>
:%init (fn[spec]
(defn bind-def[bind-spec]
(:@new <gd-method>
(match bind-spec
(obj (struct? obj)) obj
[sym ver] {:id sym :ver ver}
sym {:id sym :ver 1 })))
[ ;((<gd-sym> :%init) spec)
:binds (map bind-def
(or (spec :binds) []))
:methods (map bind-def
(or (spec :methods) []))
:ops (map bind-def
(or (spec :ops) []))
:indexed (or (spec :indexed) false)
:ctors (or (spec :ctors) {})
:mode (spec :mode)
:c-repr (spec :c-repr)])
:binds []
:methods []
:ctors {}
:ops []
:mode :
:c-type (fn [me]
(string (or (me :c-repr)
(string "gd_" (:name me)))))
:enum (fn [me]
(string "GDEXTENSION_VARIANT_TYPE_" (:scream me)))
))
(defn env: [v dflt]
(or ((os/environ) v) dflt))
(def api-spec
(let [api-spec-path
(env: "gd_api_spec"
(string (env: "gd_build_gen" "gen")
"/extension_api.json" ))]
(json/parse
(with [fd (file/open api-spec-path :r)]
(:read fd :all)))))
(def vector-types-float (map |(symbol 'vector $) (range 2 5)))
(def vector-types
(tuple/join vector-types-float
(map |(symbol $ 'i) vector-types-float)))
(def packed-types
(map |(symbol 'packed- $ '-array)
(tuple/join vector-types-float
['color 'byte 'string
'int32 'int64
'float32 'float64])))
(defn names-variant? [x]
(-> (map |(:tall (:from <gd-sym> $)) packed-types)
(array/join ["String" "StringName"
"Array" "Dictionary"])
(has-value? x)))
(defn names-prim? [x]
(-> ["int" "float" "bool"]
(has-value? x)))
(def variants (map |(:@new <gd-type> $) ~[
{:id variant :binds [get-ptr-constructor
get-ptr-destructor
get-ptr-operator-evaluator
get-ptr-internal-getter
get-ptr-builtin-method
get-indexed set-indexed
get-named set-named
get-type
booleanize]}
{:id bool }
{:id int }
{:id float }
{:id color }
,;(map |{:id $ :mode :dc} vector-types)
,;(map |{:id $ :mode :dc
:methods '[get set size resize fill clear
append append_array insert remove-at
has is-empty find rfind count
reverse slice duplicate]
:ctors {:empty []}
}
packed-types)
{:id array :mode :dc
:binds [ref set-typed operator-index operator-index-const]
:methods [size is-empty clear append append-array insert]
:ctors {:empty []}
:indexed true}
{:id dictionary :mode :dc
:binds [set-typed operator-index operator-index-const]
:methods [size is-empty clear]
:ctors {:empty []}
:indexed true}
{:id string-name :mode :dc
:ops [equal]
:binds [new-with-utf8-chars
new-with-utf8-chars-and-len]
:methods [length
ends-with begins-with
trim-suffix trim-prefix]
:ctors {:empty []
:copy [[:from string-name]]
:from-string [[:from string]]}}
{:id string :mode :dc
:ops [equal]
:binds [[new-with-utf8-chars 1]
[new-with-utf8-chars-and-len 2]
to-utf8-chars]
:methods [length
ends-with begins-with
trim-suffix trim-prefix]
:ctors {:empty []
:copy [[:from string]]
:from-string-name [[:from string-name]]}}
]))
(def classes (map |(:@new <gd-type> $) '[
{:id classdb :binds [[register-extension-class 4]
unregister-extension-class
register-extension-class-method
register-extension-class-virtual-method
get-method-bind
get-class-tag
[construct-object 2]]}
{:id object :binds [set-instance
set-instance-binding
get-instance-binding
get-class-name
cast-to
has-script-method
call-script-method
method-bind-ptrcall
destroy
]}
{:id global :binds [get-singleton]} #hax
]))
(def internals (map |(:@new <gd-type> $) ~[
{:id engine :binds [register-script-language
unregister-script-language]}
{:id ref-counted :binds [reference unreference
get-reference-count]}
{:id script :binds [get-source-code set-source-code]}
{:id file-access :binds [open close store-string get-as-text]}
{:id resource-loader :binds [add-resource-format-loader
remove-resource-format-loader]}
{:id resource-saver :binds [add-resource-format-saver
remove-resource-format-saver]}
{:id script-language-extension}
{:id script-extension}
]))
(def global-enums (map |(:from <gd-sym> $) '[
error
]))
(def singletons (map |(:from <gd-sym> $) '[
engine
resource-loader
resource-saver
]))
(def c-fetch-decl (string
"void gdjn_types_fetch\n"
"( struct gdjn_typeDB* t,\n"
" GDExtensionInterfaceGetProcAddress getProc\n"
")"))
(defn main [_ mode & args]
(def api {
:decls @[]
:aliases @[]
:calls @[]
:defer-calls @[] # dependency Hel bypass
:types @[]
:method-defs @[]
:methods-inline @[]
:wrappers @[]
})
(def config (env: "gd_config" "double_64"))
(def sizes (do
(var sz-list nil)
(loop [cfg :in (api-spec "builtin_class_sizes")
:until (not= nil sz-list)]
(when (= config (cfg "build_configuration"))
(set sz-list (cfg "sizes"))))
(def vt @{})
(loop [sz :in sz-list]
(put vt (sz "name") (sz "size")))
vt))
(defn prim:gd->c [x]
(defn bp [x small big]
(case (sizes x)
4 small
8 big
(error (string "bad type size " (sizes x) " for " x))))
(case x
"int" (bp "int" "int32_t" "int64_t")
"float" (bp "float" "float" "double")
"bool" "bool"
"object" "GDExtensionObjectPtr"))
(defn variant:gd->c [x]
(def v (find |(= x (:tall (:@new <gd-sym> {:id ($ :id)}))) variants))
(string "gd_" (:name v)))
(defn translate-type [st &opt flags]
(defn fl [x] (string/check-set (or flags :) x))
(match (string/split "::" st)
# enums can be directly mapped to a C
# instantiation of the enum
["enum" ty]
(match (string/split "." ty)
[a b] (string/format "gd_%s_%s" a b)
[x] (string "gd_" x))
# primitives will be returned directly
([ty] (names-prim? ty))
(prim:gd->c ty)
# opaques ("variant" members) will be
# returned as the appropriate opaque object
([ty] (names-variant? ty))
(let [t (variant:gd->c ty)]
(if (not (fl :r)) t
(string/format "typeof(%s)%s*" t
(if (fl :c) " const" ""))))
# everything else has to be an object; return
# a pointer
[ty] (string "GDExtension"
(if (fl :c) "Const" "")
"ObjectPtr /*"ty"*/")
fbk (error (string/format "bad type %q" fbk))))
(defn method:return-type [method]
(let [rv (method :return_value)] (cond
(nil? rv) "void"
(empty? rv) "void"
(translate-type (rv "type")))))
(defn method:args [method t-self &opt self-flags]
(as-> (if (has-key? method :arguments)
(method :arguments)
[]) lst
(if (method :is_static) lst
(tuple/join [{"name" "self"
"type" t-self
:flags (keyword :r (or self-flags :))}] lst))
(map |(string (translate-type ($ "type") ($ :flags))
" const "
($ "name")) lst)))
(def gdclasses (merge
;(seq [src :in ["classes" "builtin_classes"]]
(tabseq [class :in (api-spec src)]
(class "name")
{:methods (if (= nil (class "methods")) {}
(tabseq [meth :in (class "methods")]
(meth "name")
(tabseq [[k v] :pairs meth]
(keyword k) v)))
:enums (get class "enums" [])}))))
(defn add [to fmt & vals]
(array/push to (string/format fmt ;vals)))
(defn add-get-proc [class method]
(def version-str (:vstr method))
# this is so hateful and evil im not even going to pretty it up
(def ptr-t (if (= (method :id) 'get-ptr-internal-getter)
"GDExtensionInterfaceGetVariantGetInternalPtrFunc"
(string/format "GDExtensionInterface%s%s"
(string (:tall class) (:tall method)) version-str
)))
(add (api :calls) "t -> gd_%s.%s = (%s)getProc(\"%s%s\");"
(:name class) (:name method) ptr-t
(string (:sulk class) "_" (:sulk method)) version-str))
(def gd-iface-pfx "GDExtensionInterface")
(defn add-methods [class binds]
(loop [bind :in binds
:let [c-type (string gd-iface-pfx
(:tall class) (:tall bind))]]
(def ptr-t (if (= (bind :id) 'get-ptr-internal-getter)
"GDExtensionInterfaceGetVariantGetInternalPtrFunc"
c-type))
(add (api :decls) "\t%s%s %s;" ptr-t (:vstr bind) (:name bind))
(add-get-proc class bind)))
(defn add-enums [class]
(def api-ent (get-in gdclasses [(:tall class) :enums] []))
(defn ln [& x] (add (api :types) ;x))
(each e api-ent
(def id (string "gd_" (:tall class) "_" (e "name")))
# the underlying type is IMPORTANT! godot enums
# appear to use the godot int type, which (at present)
# is always 8 bytes long. this means trying to write
# a godot "enum" to a plain old C enum will, if you
# are very lucky, cause your program to barf all over
# the stack and immediately segfault
(ln "typedef enum %s : GDExtensionInt {" id)
# thank the gods for C23. this would have been really
# unpleasant otherwise
(each n (e "values")
(def ident (:from-snek <gd-sym> (n "name")))
(def sym (:@new <gd-sym> ident))
(ln "\t%s_%s = %d," id (:name sym) (n "value"))
(ln "\t/* %s */"
(n "description")))
(ln "} %s;\n" id)))
(defn add-ctors [class ctors]
(loop [[id form] :pairs ctors]
(def id-sym (:from <gd-sym> id))
(def key (freeze (seq [[name t] :in form
:let [tsym (:from <gd-sym> t)]]
{"name" (string name)
"type" (string (:tall tsym))})))
(def ent (as-> (api-spec "builtin_classes") x
(find |(= (freeze ($ "name")) (:tall class)) x)
(x "constructors")
(find |(if (empty? key) (not (has-key? $ "arguments"))
(let [args (freeze ($ "arguments"))]
(= key args))) x)))
(assert ent (string/format "no matching constructor: %q" form))
(let [ctor-idx (ent "index")]
(add (api :decls) "\tGDExtensionPtrConstructor %s;" (:name id-sym))
(add (api :calls) "t -> gd_%s.%s = t -> gd_variant.getPtrConstructor(%s, %d);"
(:name class) (:name id-sym) (:enum class) ctor-idx)
)))
(add (api :aliases) "#define _opaque(n) struct{unsigned char _opaque_ [n];}")
(defn with-names [ln names func]
(ln "{")
(each [id val] names
(ln "gd_stringName %s;" id)
(ln "t -> gd_stringName.newWithUtf8Chars(&%s, %q);" id val))
(func)
(each [id _] names
(ln "t -> gd_stringName.dtor(&%s);" id))
(ln "}"))
(loop [e :in global-enums]
(defn ln [& x] (add (api :types) ;x))
(def spec (find |(= ($ "name") (:tall e))
(api-spec "global_enums")))
(assert spec (string/format "no enum with name %s found"
(:tall e)))
(ln "typedef enum gd_%s : int64_t {" (:tall e))
(each v (spec "values")
(def name (:from-snek <gd-sym> (v "name")))
(ln "\tgd_%s_%s = %d," (:tall e) (:name name) (v "value"))
(when (v "description")
(ln "\t/* %s */" (v "description"))))
(ln "} gd_%s;\n" (:tall e))
)
(add (api :wrappers)
(string
"auto getWrap = "
"(GDExtensionInterfaceGetVariantFromTypeConstructor)"
`getProc("get_variant_from_type_constructor");`
"\nauto getCast = "
"(GDExtensionInterfaceGetVariantToTypeConstructor)"
`getProc("get_variant_to_type_constructor");` "\n"))
(loop [v :in variants
:let [vsz (or (sizes (:tall v))
(sizes (string (v :id) )))]]
(add (api :aliases) # these are all opaque objects
"typedef _opaque(%d) gd_%s;"
vsz (:name v))
(add (api :decls ) "struct {")
(def my-enum (:enum v))
(add-methods v (v :binds))
(add-enums v)
(unless (= (v :id) 'variant)
(add (api :decls)
"\tGDExtensionVariantFromTypeConstructorFunc wrap;")
(add (api :decls)
"\tGDExtensionTypeFromVariantConstructorFunc cast;")
(add (api :wrappers) "t -> gd_%s.wrap = getWrap(%s);"
(:name v) (:enum v))
(add (api :wrappers) "t -> gd_%s.cast = getCast(%s);"
(:name v) (:enum v))
(def ct (or (prim:gd->c (:name v))
(variant:gd->c (:tall v))))
(add (api :methods-inline)
(string "static inline %s\n"
"gd_variant_to_%s\n"
"(\tgd_variant const* const v\n"
") {\n"
"\textern struct gdjn_typeDB* _g_typeDB;"
"\t%s ret = {};\n"
"\t_g_typeDB -> gd_%s.cast(&ret, (void*)v);\n"
"\treturn ret;\n"
"}\n")
ct (:name v)
ct (:name v) )
(add (api :methods-inline)
(string "static inline gd_variant\n"
"gd_variant_of_%s\n"
"(\t%s v\n"
") {\n"
"\textern struct gdjn_typeDB* _g_typeDB;"
"\tgd_variant ret = {};\n"
"\t_g_typeDB -> gd_%s.wrap(&ret, &v);\n"
"\treturn ret;\n"
"}\n")
(:name v)
ct
(:name v)
))
# bind builtins
# WHY IS THIS *YET ANOTHER* COMPLETELY DIFFERENT API
# for the SAME LITERAL THING fuck youuuuu
(when (has-key? gdclasses (:tall v)) (loop [m :in (v :methods)
:let [method (get-in gdclasses [(:tall v) :methods
(:sulk m)])]]
(add (api :decls) "\tGDExtensionPtrBuiltInMethod %s;" (:name m))
(def return-type
(if (not (has-key? method :return_type)) "void"
(translate-type (method :return_type))))
(def args (method:args method (:tall v)
(if (method :is_const) :c :)))
(def impl @[])
(unless (= return-type "void")
(array/push impl
(string/format "typeof(%s) ret = {};" return-type)))
(array/push impl
(string/format "_g_typeDB -> gd_%s.%s("
(:name v) (:name m)))
(array/push impl
(string "\t" (if (method :is_static)
"nullptr" "(void*)self") ",")
"\t(void const*[]) {")
(when (has-key? method :arguments)
(each a (method :arguments)
(array/push impl
(string/format "\t\t&%s," (a "name")))
))
(array/push impl (string/format "\t}, %s, %d"
(if (= return-type "void") "nullptr" "&ret")
(if (not (has-key? method :arguments)) 0
(length (method :arguments))))
");")
(unless (= return-type "void")
(array/push impl "return ret;"))
(array/push (api :method-defs)
{:dfn (string/format "%s gd_%s_%s\n(\t%s\n)"
return-type (:name v) (:name m)
(string/join args ",\n\t"))
:impl impl})
(with-names (fn [& a] (add (api :defer-calls) ;a))
[[:methodID (:sulk m)]]
(fn [] (add (api :defer-calls)
"t -> gd_%s.%s = t -> gd_variant.getPtrBuiltinMethod(%s, &methodID, %d);"
(:name v) (:name m)
my-enum (method :hash)
)
))))
(when (v :ctors)
(add-ctors v (v :ctors)))
(when (not= "variant" (:name v))
(add (api :decls) "\ttypeof(gd_%s* (*)(GDExtensionVariantType*)) raw;" (:name v))
(add (api :calls) "t -> gd_%s.raw = (typeof(t->gd_%s.raw))t -> gd_variant.getPtrInternalGetter(%s);"
(:name v) (:name v) my-enum))
(loop [o :in (v :ops)]
(add (api :decls) "\tGDExtensionPtrOperatorEvaluator %s;" (:name o))
(add (api :calls) "t -> gd_%s.%s = t -> gd_variant.getPtrOperatorEvaluator(GDEXTENSION_VARIANT_OP_%s, %s, %s);"
(:name v) (:name o) (string/ascii-upper (:sulk o))
my-enum my-enum)
)
(when (string/check-set (v :mode) :d)
(add (api :calls)
"t -> gd_%s.dtor = t -> gd_variant.getPtrDestructor(%s);"
(:name v) my-enum )
(add (api :decls) "\tGDExtensionPtrDestructor dtor;"))
(add (api :decls) "} gd_%s;" (:name v)))
(loop [c :in classes
:let [pfx (string "GDExtensionInterface" (:tall c) (:vstr c))
gd-t (:sulk c)]]
(add (api :decls) "struct {")
(add-methods c (c :binds))
(add-enums c)
(add (api :decls) "} gd_%s;" (:name c)))
(loop [i :in internals
:let [class (gdclasses (:tall i))]]
(def ctr-id (string/format "gd_m_%s" (:name i)))
(add (api :decls) "struct {")
(add-enums i)
(loop [m :in (i :binds)
:let [method ((class :methods) (:sulk m))]]
(assert method
(string/format "method %s not found in class %s"
(m :id) (i :id)))
(add (api :decls) "\tGDExtensionMethodBindPtr %s_ptr;"
(:name m))
(def return-type (method:return-type method))
(def args (method:args method (:tall i)
(if (method :is_const) :c :)))
(def impl @[])
(defn ln [& x] (array/push impl ;x))
(when (not= return-type "void")
(ln (string/format "%s ret;" return-type)))
(ln "_g_typeDB -> gd_object.methodBindPtrcall("
(string/format "\t_g_typeDB -> gd_m_%s.%s_ptr,"
(:name i) (:name m))
(if (method :is_static) "\tnullptr," "\t(void*)self,")
"\t(GDExtensionConstTypePtr[]) {")
(as-> (method :arguments) args
(if (nil? args) [] args)
(map |(string "\t\t&" ($ "name") ",") args)
(ln ;args))
(ln (string "\t}, "
(if (not= return-type "void")
"&ret"
"nullptr")) ");")
(when (not= return-type "void") (ln "return ret;"))
(array/push (api :method-defs)
{:dfn (string/format "%s gd_%s_%s\n(\t%s\n)"
return-type
(:name i)
(:name m)
(string/join args ",\n\t")
)
:impl impl})
(defn ln [& l] (add (api :calls) ;l))
(with-names ln
[["className" (:tall i)]
["methodName" (:sulk m)]]
(fn []
(ln (string
"auto ptr = t -> gd_classdb.getMethodBind(&className, &methodName, %d);\n"
"\tt -> %s.%s_ptr = ptr;\n"
#"\t"`printf("* bind method %s.%s (%%p)\n",ptr);` "\n"
"\tassert(ptr != nullptr);")
(method :hash)
ctr-id (:name m)
(:name i) (:name m)
))))
(add-ctors i (i :ctors))
(add (api :decls) "} %s;" ctr-id))
(add (api :decls) "struct {")
(loop [s :in singletons]
(add (api :decls) "\tGDExtensionObjectPtr %s;" (:name s))
(defn cln [& v] (add (api :calls) ;v))
(with-names cln
[["sgtName" (:tall s)]]
(fn []
(cln "t -> objects.%s = t -> gd_global.getSingleton(&sgtName);" (:name s))
(cln "if (t -> objects.%s == nullptr) abort();" (:name s))
)))
(add (api :decls) "} objects;")
(case mode
"list" (do
# may the gods have mercy on me
(defn print-binds [v]
(print " • \e[94;4m" (v :id)"\e[m")
(each b (v :binds)
(print " · " (b :id) "\n"
" \e[3;35mgd_" (:name v) "." (:name b) "()\e[m")))
(print "we are currently binding the following symbols")
(print "- \e[1mvariants\e[m -" )
(each v variants (print-binds v))
(print "- \e[1mclasses\e[m -" )
(each c classes (print-binds c))
(print "- \e[1mptrcalls\e[m -" )
(each i internals
(print " • \e[94;4m" (i :id)"\e[m")
(each b (i :binds)
(print " · " (b :id) "\n"
" \e[3;33mgd_m_" (:name i) "." (:name b) "_ptr\e[m\n"
" \e[3;92mgd_" (:name i) "_" (:name b) "()\e[m")))
(print "- \e[1msingletons\e[m -" )
(each s singletons
(print " • \e[94;4m" (s :id)"\e[m\n"
" \e[3;33mobjects." (:name s) "\e[m" ))
(print "- \e[1mglobal enums\e[m -" )
(each e global-enums
(print " • \e[94;4m" (e :id)"\e[m\n"
" \e[3;33mgd_" (:tall e) "\e[m" )))
"header" (do
(print "/* automatically generated by tool/c-bind-gen.janet */\n\n"
"#pragma once\n"
"#include \"gdextension_interface.h\"\n")
(loop [list :in [(api :aliases)]
val :in list] (print val))
(print "\ntypedef struct gdjn_typeDB {")
(loop [d :in (api :decls)]
(print "\t" d))
(print "} gdjn_typeDB;")
(each t (api :types) (print t))
(print c-fetch-decl ";")
(each m (api :method-defs)
(print (m :dfn) ";"))
(each m (api :methods-inline)
(print m)))
"loader" (do
(print "#include <stdlib.h>\n"
"#include <stdio.h>\n"
"#include <assert.h>\n"
"#include \"interface.h\"\n\n"
"gdjn_typeDB* _g_typeDB;\n\n"
# HORRID HACK
c-fetch-decl "{\n"
;(map |(string "\t" $ "\n")
[ "_g_typeDB = t;"
;(api :calls)
"{"
;(api :wrappers)
"}"
;(api :defer-calls) ])
"}")
(each m (api :method-defs)
(print (m :dfn) "{\n\t" (string/join (m :impl) "\n\t") "\n}\n")))))