# [ʞ] tool/class-compile.janet
# ~ lexi hale <lexi@hale.su>
# 🄯 AGPLv3
# ? compiles a godot class definition to C source
# > janet tool/class-compile.janet <class> (loader|header)
(def *src-file* (gensym))
(def parse-doc
(do (def doc-parser (peg/compile '{
:hs (+ " " "\t")
:- "-"
:open-line (* (? " ") (? '(some (if-not "\n" 1))) "\n")
:single-line (* (? " ") (? '(some (* (not :hs) 1))) (any :hs) -1)
:mid-line (+ (* (any :hs) :- (? " ")
(? '(some (if-not "\n" 1))) "\n")
(* (? '(some (if-not "\n" 1))) "\n"))
:close-line (+ (* (any :hs) -1)
(* (any :hs) :- (? " ")
(? '(some (if-not (* (any :hs) -1) 1)))
(any :hs) -1))
:main (+ (* :open-line (any :mid-line) :close-line)
:single-line
'(any 1)) # admit defeat
}))
(fn parse-doc[str]
(peg/match doc-parser str))))
(def syntaxes
(do (def quot-syntax
'(nth 1 (unref (* (<- (+ `"` `'`) :quo)
(<- (any (+ (* `\` (backmatch :quo))
(if-not (backmatch :quo) 1))))
(backmatch :quo)) :quo)))
(defn fail [cause]
(defn mk [ln col]
{:kind :parse
:cause cause
:ln ln :col col})
~(error (cmt (* (line) (column)) ,mk)))
(defn req [id body]
~(+ (* ,;body) ,(fail (keyword :malformed- id))))
(defn kw [id body]
~(* ,id (> 1 :bound) ,(req id ~(:s+ ,;body))))
(defn comment-syntax [id open close]
~(* ,open '(any (+ ,id
:quot
(if -1 ,(fail :fell-off-comment))
(if-not ,close 1))) ,close))
{:class-def (peg/compile ~{
:b (any :s)
:bound (+ :s ";" "," `"` "{" "}" "<" ">" ":" "->" "(" ")")
:sym (some (if-not :bound 1))
:sym-kw (cmt ':sym ,keyword)
:term (* :b ";" :b)
:quot ,quot-syntax
:quot-ang (* "<" (<- (any (+ `\>`
(if-not ">" 1))))
">")
:doc (cmt (* :b ,(comment-syntax :doc "(-" "-)") :b)
,(fn [text] [:doc ;(parse-doc text)]))
:def-class (* (+ (* (constant :class) "class")
(* (constant :iface) "interface"))
:s+ (<- :sym) :s+
(+ (* (constant :native) "is")
(* (constant :gdext) "extends")
,(fail :bad-inherit))
:s+ (<- :sym)
:b "{" :b (group (any :stmt)) :b "}")
:def-import (* (constant :import)
(+ (* (constant :impl) "use")
(* (constant :head) "import"))
:b
(+ (* (constant :lit) :c-block)
(* (constant :sys) :quot-ang)
(* (constant :loc) :quot)))
:c-comment (+ (* (+ "//" "#") (any (if-not (+ "\n" -1) 1)) (+ "\n" -1))
(* "/*" (any (if-not "*/" 1)) "*/"))
:c-block (cmt (* "{" (line) (<- (any (+ (drop :quot)
(drop :c-block)
:c-comment
(if -1 ,(fail :fell-off-c-block))
(if-not "}" 1)))) "}")
,(fn [ln text]
(string/format "#line %d %q\n%s"
(+ 4 ln) (dyn *src-file*) text)))
:type-gd-vector (* "vector" (+ "2" "3" "4"))
:type-gd-basic (cmt '(+
"int"
"float"
"bool"
"string-name"
"string"
"color"
:type-gd-vector
"transform-2D"
"transform-3D"
"basis"
"projection"
"variant"
"array"
"dictionary"
(* "packed-"
(+ (* (+ "int" "float") (+ "32" "64"))
:type-gd-vector
"byte" "color" "string") "-array"))
,keyword)
:type-gd (+ (group (* (constant :ref) "ref" :b ':sym))
(group (* (constant :array) "array" :b
"[" :b :type-gd-basic :b "]"))
(group (* (constant :dictionary) "dictionary" :b
"[" :b :type-gd-basic ","
:b :type-gd-basic :b "]"))
:type-gd-basic)
:arg-spec (* (group (* :type-gd :s+ ':sym (? :doc))) (? (* :b (+ "," ";") :b :arg-spec)))
:arg-list (group (* "(" :b (? :arg-spec) :b (?";") :b ")"))
:def-method (* (constant :func) (+ (* (constant :method) "fn")
(* (constant :impl ) "impl"))
:s+ ':sym :b :arg-list :b
(+ (* "->" :b (group (* :type-gd (? :doc))))
(constant [:void]))
:b :c-block)
:def-event (* (constant :event)
(+ (* (constant :ctor) "new")
(* (constant :dtor) "del") ) :b :c-block)
:def-var (* (constant :var)
# c type
(+ (* "var" (> (* :s+ "as")) (constant :auto))
(* "var" :s+
'(any (if-not (+ (* :s+ "as" :s+)
(* :b ":" )) 1))))
(+ (* :s+ "as" :s+ :type-gd)
(constant :priv))
(* :b ":" :b) (any (* ':sym :b "," :b)) ':sym)
:def (* (? :doc)
(+ :def-class
:def-var
:def-import
:def-method
:def-event))
:stmt (* :b (+ (group :def) "") :term)
# :main (+ (* (any :stmt) -1)
# ,(fail :bad-stmt))
:main (* (any :stmt) (+ -1 ,(fail :bad-stmt)))})
:comment-eraser (peg/compile ~{
:quot ,quot-syntax
:comment ,(comment-syntax :comment "(*" "*)")
:main (% (any (+ (drop :comment)
(<- 1))))})
}))
(defn parse-class [str]
(def stripped (first (peg/match (syntaxes :comment-eraser) str)))
(peg/match (syntaxes :class-def) stripped))
(def *colorize* (gensym))
(setdyn *colorize* true)
(defn style [& body]
(def emit (if (dyn *colorize*)
(fn [sq] (string "\e[;" sq "m"))
(fn [_ ] "")))
(defn enter [body style-seq]
(defn push [st]
(if (= "" style-seq) st
(string style-seq ";" st)))
(defn enc [st str]
(def cst (push st))
(string (emit cst)
(enter str cst)
(emit style-seq)))
(match body
(str (string? str)) str
[:hl str] (enc "1" str)
[:em str] (enc "3" str)
[:rv str] (enc "7" str)
[:red str] (enc "31" str)
[:span & strs] (string ;(map |(enter $ style-seq) strs))
_ (error (string/format "bad style spec %q" body))))
(enter body ""))
(defn err->msg [e]
(defn err-span [h & m] [:span [:hl [:red h]] ": " ;m ])
(match e
{:kind :parse} (err-span "parse error"
(string (e :cause) " at ")
[:hl (string/format "%d:%d" (e :ln) (e :col))])
_ (error e)))
# _ (err-span "error"
# "something went wrong (" [:em (string e)] ")")))
(defn indent [n lst]
(map |(string (string/repeat "\t" n) $) lst))
(defn fmt-docs [dox]
(tuple/join ["/**"] (map |(string " * " $) dox) [" */"]))
(def <obj> {
:new (fn [this & args] (struct/with-proto this ;args))
:is? (fn [this obj] (and (struct? obj)
(= this (struct/getproto obj))))
:impl? (fn [this obj]
(and (struct? obj)
(match (struct/getproto obj)
nil false
(@ this) true
p (:impl? this p))))
})
(def <sym>
(let [tcap (fn tcap[str]
(def init (string/slice str 0 1))
(def rest (string/slice str 1))
(string (string/ascii-upper init)
rest))]
(:new <obj>
:segs []
:read (fn read[this id]
(if (:impl? this id)
(:new this :segs (id :segs))
(:new this :segs (string/split "-" id))))
:form (fn form[me tx &opt sep]
(keyword (string/join (map tx (me :segs))
(or sep ""))))
:tall |(:form $ tcap)
:scream |(:form $ string/ascii-upper "_")
:sulk |(:form $ identity "_")
:stab |(:form $ identity "-")
:say (fn [me]
(def s (me :segs))
(string (first s)
;(map tcap (slice s 1)))))))
(def <func-c> (:new <obj>
:id :
:args []
:ret :
:body []
:quals []
:dec* (fn [this quals ret id sig & body]
(:new this
:id id
:ret ret
:body body
:quals quals
:args (map (fn [[t id]]
{:id id :t t})
sig)))
:dec- (fn [this & dfn] (:dec* this [:static] ;dfn))
:dec (fn [this & dfn] (:dec* this [] ;dfn))
:proto (fn [me arg-ids?]
(def arg->str (if arg-ids?
|(string "typeof(" ($ :t) ") " ($ :id))
|(string "typeof(" ($ :t) ")")))
(defn arg-lines [args]
(if (empty? args) []
(let [a @[]]
(loop [arg :in args]
(when (not (empty? a))
(put a (- (length a) 1)
(string (last a) ",")))
(array/push a (string "\t" (arg->str arg))))
(tuple (string "(" (first a))
;(slice a 1)
")"))))
[ (string (if (empty? (me :quals)) ""
(string (string/join (me :quals) " ") " "))
(me :ret))
(string (me :id) (if (empty? (me :args)) "(void)" ""))
;(arg-lines (me :args)) ])
:declare* (fn [me] [ ;(:proto me false) ";" ])
:define* (fn [me] [ ;(:proto me true) "{"
;(indent 1 (me :body)) "}" ])
:declare (fn [me]
(defn flag? [f] (has-value? (me :quals) f))
(cond
(flag? :inline) (:define* me)
(flag? :static) []
(:declare* me)))
:define (fn [me] (if (has-value? (me :quals) :inline) []
(:define* me)))))
(def <type-c> (:new <obj>
:id (:new <sym>)
:dec* (fn [this mode id & meta] (:new this
:id (:read <sym> id)
:mode mode
;meta))
:dec (fn [this & dfn] (:dec* this :pub ;dfn))
:dec- (fn [this & dfn] (:dec* this :priv ;dfn))
:dec@ (fn [this & dfn] (:dec* this :opaq ;dfn))
:content (fn [me] "void")
:declare (fn [me]
[(string "typedef " (:say (me :id)) ";")])
:define (fn [me]
[(string "typedef " (:content me) " " (:say (me :id)) ";")])))
(def <struct-c> (:new <type-c>
:dec* (fn [this mode id fields & meta]
((<type-c> :dec*) this mode id
:fields fields
;meta))
:declare (fn [me]
(let [id (:say (me :id))]
[(string "typedef struct " id " " id ";")]))
:define (fn [me]
[(string "struct " (:say (me :id)) " {")
;(indent 1
(catseq [f :in (me :fields)]
(def fdesc (string/format "typeof(%s) %s;"
(f :t) (:say (:read <sym> (f :id)))))
(if (f :doc) (tuple/join (fmt-docs (f :doc))
[fdesc])
[fdesc])
))
"};"])))
(def <cursor> (:new <obj>
:path []
:unit nil
:push (fn [me what & vals]
(array/push ((me :unit) what) ;vals))
:branch (fn [me id & dfn] (:new me
:super me
:path (tuple/join (me :path) [id])
:doc false
;dfn))
:prefix (fn [me &opt sep mode]
(string/join (map (or mode :say) (me :path))
(or sep "_")))))
(defn cache [gen &opt ident]
(var idx 0)
(def box @{})
(fn [& argv]
(def sig (if (nil? ident) argv
(ident ;argv)))
(if-let [val (get box sig)] val
(let [new-val (gen idx ;argv)]
(set idx (+ 1 idx))
(put box sig new-val)
new-val))))
(defn cache/of-fn [pfx &opt inst] (cache
(fn [idx & argv] # gen
(def id (string/format "_priv_%s_%x" pfx idx))
(when inst (inst id ;argv))
id)
(fn [sig & _] sig))) # ident
(defn gdtype->vartype [t] (match t
[:array _] :array
[:dictionary _] :dictionary
[:ref _] :object
x (keyword x)))
(defn gdtype->ctype [t]
(match t
:void :void
:float :double
:int :int64_t
:bool :bool
[:array _] :gd_array
[:dictionary _] :gd_dictionary
[:ref _] :GDExtensionObjectPtr
# use an opaque wrapper struct defined in interface.h
x (string "gd_" (:say (:read <sym> t)))))
(defmacro over [acc init binds & body]
(def acc (if (= acc :) (gensym) acc))
~(do (var ,acc ,init)
(loop ,binds
(set ,acc (do ,;body)))
,acc))
(defn unit-files [u]
(def h @[ `#pragma once` `#include "gdjn.h"` `#include "util.h"`
;(u :header-prefix)])
(def c @[
(string `#include "` (:stab (u :name)) `.h"`)
`typedef struct gdjn_vcall {`
` GDExtensionClassMethodPtrCall caller; `
` void* tgt;`
`} gdjn_vcall;`
;(u :impl-prefix)
])
(defn print-docs [dest obj]
(when-let [dox (get (u :doc) obj)]
(array/concat dest (fmt-docs dox))))
(each t (u :types)
(def [f-dec f-def f-doc]
(case (t :mode)
:pub [h h h]
:priv [c c c]
:opaq [h c c]))
(print-docs f-doc t)
(array/concat f-dec (:declare t))
(array/concat f-def (:define t)))
# forward-declare private funcs
(each func (u :funcs)
(when (has-value? (func :quals) :static)
(array/join c (:declare* func))))
(each v (u :vars)
(when (not (v :priv))
(print-docs h v)
(array/push h (string/format "extern typeof(%s) %s;"
(v :t) (v :id))))
(def init (let [val (v :v)] (cond
( nil? val) ""
( keyword? val) (string " = " val)
( string? val) (string/format ` = %q` val)
(function? val) (string " = " (val)) )))
(when (v :priv) (print-docs c v))
(array/push c (string/format "%stypeof(%s) %s%s;"
(if (v :priv) "static " "")
(v :t) (v :id) init)))
(defn func-push [func]
(array/join h (:declare func))
(array/join c (:define func)))
(each func (u :funcs)
(print-docs (if (func :priv) c h) func)
(func-push func))
(let [fname (string "gdjn_unit_" (:say (u :name)) "_load")]
(func-push (:dec <func-c> :void fname []
;(indent 0 (u :load)))))
{:header h :impl c})
(defn with-names [kv & body]
(def [start end] [@[] @[]])
(loop [[k v] :pairs (struct ;kv)]
(def v-rep (cond (keyword? v) (string v)
(string/format "%q" v)))
(array/push start
(string "gd_stringName " k ";")
(string/format "_t(stringName).newWithUtf8Chars(&%s, %s);"
k v-rep))
(array/push end
(string/format "_t(stringName).dtor(&%s);" k)))
(tuple/join ["{"]
(indent 1 start)
body
(indent 1 (reverse end))
["}"]))
(defn variant-type-enum [sym]
(def s (cond (:is? <sym> sym) sym
(or (keyword? sym)
(string? sym)) (:read <sym> sym)
(:read <sym> (gdtype->vartype sym))))
(when (= :variant (:stab s))
(error "value is already a variant"))
(string "GDEXTENSION_VARIANT_TYPE_"
(:scream s)))
(defn func-ptr-t [ret args]
(defn wt [t]
(string "typeof(" t ")"))
(string/format "typeof(%s (*)(%s))"
(wt ret)
(if (empty? args) "void"
(string/join (map wt args) ", "))))
(defn lines->str [lines]
(string (string/join lines "\n") "\n"))
(defn basename [p]
(last (string/split "/" p)))
(defn entry [_ inp emit]
(def ast (with [fd (file/open inp :r)]
(with-dyns [*src-file* inp]
(parse-class (:read fd :all)))))
(def unit
(let [unit-funcs @[]
unit-vars @[]
unit-load @[] ]
(defn unit-variant-inst [kind]
(when (= kind :variant)
(error "cannot rewrap a variant"))
(def modes
{:cast {:call "cast"
:type "GDExtensionTypeFromVariantConstructorFunc"}
:wrap {:call "wrap"
:type "GDExtensionVariantFromTypeConstructorFunc"}})
(def mode (in modes kind))
(fn [id ty]
(def ty-sym (:read <sym> (gdtype->vartype ty)))
(def ty-enum (variant-type-enum ty-sym))
(array/push unit-vars
{:id id :priv true :v :nullptr
:t (mode :type)})
(array/push unit-load
(string/format `%s = gdjn_ctx -> gd.%s(%s);`
id (mode :call) ty-enum))))
(def unit-variant-wrap
(cache/of-fn "variant_wrap" (unit-variant-inst :wrap)))
(def unit-variant-cast
(cache/of-fn "variant_cast" (unit-variant-inst :cast)))
(defn unit-invocant-ptr-inst [id [t-ret t-args]]
(def invoke-args '[
# in
[void* target]
[GDExtensionClassInstancePtr inst]
["const GDExtensionConstTypePtr*" argv]
# out
[GDExtensionTypePtr ret]])
(def args*
(seq [i :range [0 (length t-args)]
:let [a (t-args i) ]]
(string/format "*((%s*)argv[%d])" (gdtype->ctype a) i)))
(def fn-t (func-ptr-t (gdtype->ctype t-ret)
[:void* ;(map gdtype->ctype t-args)]))
(def arg-str (string/join ["inst" ;args*] ", "))
(def invoke [
(string "typedef " fn-t " ptrCallFn;")
(string "ptrCallFn func = target;")
(string (if (= :void t-ret) ""
"auto rv = ") "func(" arg-str ");")
;(if (= :void t-ret) [] [
"* (typeof(rv)*) ret = rv;"])])
(array/push unit-funcs
(:dec- <func-c> :void id invoke-args
;invoke)))
(defn unit-invocant-inst [id [t-ret t-args]]
(def invoke-args '[
# in
[void* target]
[GDExtensionClassInstancePtr inst]
["const GDExtensionConstVariantPtr*" argv]
[GDExtensionInt argc]
# out
[GDExtensionVariantPtr ret]
[GDExtensionCallError* err]])
(defn call-err [kind & params]
(let [kind-sym (:read <sym> kind)
enum (string "GDEXTENSION_CALL_ERROR_"
(:scream kind-sym))
p (struct ;params)]
[(string `err -> error = ` enum `;`)
;(map (fn[[k v]]
(string `err -> ` k ` = ` v `;`))
(pairs p))
`return;`]))
(defn arity-enforce [m &opt x]
[(string/format `if (argc < %d) {` m)
;(indent 1 (call-err :too-few-arguments :expected m))
(string/format `} else if (argc > %d) {` (or x m))
;(indent 1 (call-err :too-many-arguments :expected (or x m)))
`}`])
(defn unwrap-type [n]
(def var-t (gdtype->vartype (t-args n)))
(def tsym (:read <sym> var-t))
(def tenum (variant-type-enum tsym))
(def unwrap (unit-variant-cast var-t))
[(string/format
`if (_t(variant).getType(argv[%d]) != %s) {`
n tenum)
;(indent 1 (call-err :invalid-argument
:expected tenum
:argument n))
`}`
(string (gdtype->ctype (t-args n))
" arg_" n ";")
(string/format "%s(&arg_%d, (void*)argv[%d]);" unwrap n n)
])
(def invoke
(let [tx (fn (t)
(string "typeof(" (gdtype->ctype t) ")"))
wrapper (cond (= t-ret :void) nil
(= t-ret :variant) nil
(unit-variant-wrap t-ret))]
[(string/format "typedef %s wrappedFunc;"
(func-ptr-t (gdtype->ctype t-ret) [:void*
;(map gdtype->ctype t-args)]))
(string/format "%s((wrappedFunc)target)(%s);"
(if (= t-ret :void) ""
(string (tx t-ret) " result = "))
(string/join ["inst"
;(seq [i :range [0 (length t-args)]]
(string "arg_" i))]
", "))
(cond (= t-ret :variant) "*(gd_variant*)ret = result;"
wrapper (string wrapper "(ret, &result);")
"")
]))
(array/push unit-funcs
(:dec- <func-c> :void id invoke-args
;(arity-enforce (length t-args))
;(tuple/join ;(map |(unwrap-type $)
(range (length t-args))))
;invoke)))
(def unit-invocants (cache/of-fn "invoke" unit-invocant-inst))
(def unit-invocants-ptr (cache/of-fn "invoke_ptr"
unit-invocant-ptr-inst))
{:name (:read <sym> (first (string/split "." (basename inp))))
:vars unit-vars
:funcs unit-funcs
:load unit-load
:header-prefix @[]
:impl-prefix @[]
:variant-wrap unit-variant-wrap
:variant-cast unit-variant-cast
:invocants unit-invocants
:invocants-ptr unit-invocants-ptr
:classes @[]
:methods @[]
:types @[]
:doc @{}}))
(defn process [n csr]
(match n
[[:doc & lines] & node]
(let [doc-csr (:new csr :doc lines)]
(process node doc-csr))
([cl id imode base body] (or (= cl :class) (= cl :iface)))
(let [class-def {:id id
:base base
:cursor csr
:events @{}
:fields @[]
:methods @[]
:vtbl-map @{}
:impls @[]
:base-mode imode
:abstract (= cl :iface)}
id-sym (:read <sym> id)
base-sym (:read <sym> base)
subcsr (:branch csr id-sym
:class class-def)]
(array/push (unit :classes) class-def)
(each n body (process n subcsr)))
([:var t-c t-gd id] (has-key? csr :class))
(array/push (get-in csr [:class :fields])
{:id id :cursor csr
:t-gd t-gd
:t-c (match t-c
:auto (gdtype->ctype t-gd)
t t)})
[:var t-c t-gd id] (do
(assert (= t-gd :priv)
"static globals cannot currently be exposed to godot")
(array/push (unit :vars)
{:id (string "gdjn_unit_" (:say (unit :name))
"_" (:prefix csr) id)
:cursor csr
:v (keyword "{}")
:t (match t-c
:auto (gdtype->ctype t-gd)
t t)}))
[:import mode & what]
(array/push (case mode
:head (unit :header-prefix)
:impl (unit :impl-prefix))
(match what
[:loc header] (string `#include "` header `"`)
[:sys header] (string `#include <` header `>`)
[:lit body] body))
[:event ev c]
(do (assert (csr :class)
(string "event " ev " defined outside of class"))
(put-in csr [:class :events ev]
{:cursor csr
:text c}))
[:func kind id argv [rty & meta] c]
(let [cls (csr :class)
meth {:id id
:args (map (fn [[t id & r]]
[t
(keyword id) ;r]) argv)
:ret rty
:ret-doc (match (first meta)
[:doc & d] d)
:cursor csr
:text c}]
(array/push (unit :methods) meth)
(when cls (case kind
:method (array/push (cls :methods) meth)
:impl (array/push (cls :impls) meth)))
)))
(def root (:new <cursor> :unit unit))
(each n ast (process n root))
(defn class-prefix [c & r]
(def pf (let [p (:prefix c)]
(if (empty? p) [] [p])))
(string/join ["gdjn_class" ;pf ;r] "_"))
(defn bind-methods [class]
(defn bind [f kind]
(def t-args (map (fn [[t] &] t)
(f :args)))
(def invocant
((unit :invocants) [(f :ret) t-args]))
(def invocant-ptr
((unit :invocants-ptr) [(f :ret) t-args]))
(def fp-t (func-ptr-t (gdtype->ctype (f :ret))
[(string "typeof("
(class-prefix (class :cursor)
(class :id))")*")
;(map gdtype->ctype t-args)]))
(def strings-lst @[])
(def strings
(cache (fn [idx text]
(def id (string "_priv_str_" idx))
(array/push strings-lst id text)
id)))
(defn prop-info [t &opt id] [
"(GDExtensionPropertyInfo) {" ;(indent 1 [
(if (= :variant t) ""
(string ".type = " (variant-type-enum t) ","))
(string ".name = &" (strings (if (nil? id) ""
(string id))) ",")
(string ".class_name = &" (strings (match t
[:ref c] (string (:tall (:read <sym> c)))
_ "")) ",")
(string ".hint_string = &" (strings "") ",")
`.usage = 6,` # DEFAULT
]) "}"
])
(def arg-info (if (empty? t-args) [] [
(string "." (case kind
:method "arguments_info"
:impl "arguments")
"= (GDExtensionPropertyInfo[]) {")
;(indent 1 (mapcat (fn [[t id]] [;(prop-info t id) ","]) (f :args)))
"},"
".arguments_metadata = (GDExtensionClassMethodArgumentMetadata[]) {"
;(seq [i :range [0 (length (f :args))]]
"\tGDEXTENSION_METHOD_ARGUMENT_METADATA_NONE,")
"},"
]))
(def ret-info
(indent 1 [`.return_value_metadata = GDEXTENSION_METHOD_ARGUMENT_METADATA_NONE,`
;(case kind
:method (if (= :void (f :ret)) []
[`.return_value_info = &`
;(prop-info (f :ret))
`,`])
:impl [`.return_value = `
;(prop-info (if (= :void (f :ret)) :nil
(f :ret)))]
)])
)
(def fn-path (class-prefix (f :cursor) "method" (f :id)))
(with-names [:s_methodName (f :id) ;strings-lst]
(if (not= kind :method) ""
(string fp-t " func = " fn-path ";"))
(string/format `auto info = (%s) {`
(case kind
:method "GDExtensionClassMethodInfo"
:impl "GDExtensionClassVirtualMethodInfo"))
` .name = &s_methodName,`
(string "\t.argument_count = "
(length t-args) ",")
;(indent 1 arg-info)
;(if (= kind :method) [
` .method_userdata = func,`
` .method_flags = GDEXTENSION_METHOD_FLAGS_DEFAULT,`
(string "\t.has_return_value = "
(if (= :void (f :ret)) "false" "true") ",")
(string "\t.call_func = " invocant ",")
(string "\t.ptrcall_func = " invocant-ptr ",")
] [])
;ret-info
`};`
(comment (string `printf("binding method %s\n",`
(string/format "%q" fn-path)
`);`))
(string `_t(classdb).`
(case kind
:method "registerExtensionClassMethod"
:impl "registerExtensionClassVirtualMethod")
`(gdjn_ctx -> gd.lib, &s_className, &info);`)))
(array/concat @[] "{" ;(with-names [:s_className (class :id)]
;(map |(bind $ :method) (class :methods))
;(map |(bind $ :impl) (class :impls))) "}"))
(defn push-item [kind cursor item] # abuse hashtables for fun & profit
(array/push (unit kind) item)
(when (and cursor (cursor :doc))
(put (unit :doc) item (cursor :doc))))
(loop [c :in (unit :classes)]
(def id (class-prefix (c :cursor) (c :id)))
(def [id-ctor id-dtor
id-ctor-api
id-init id-create]
(map |(string id "_" $) ["new" "del"
"api_new" "init" "create"]))
(def id-base (as-> (c :base) b
(string/split "." b)
(string/join b "_")
(string "gdjn_class_" b))) #HAAACK
(when (not (empty? (c :impls)))
(def vtbl @[])
(loop [i :range [0 (length (c :impls))]
:let [f ((c :impls) i)]]
(def t-args (map (fn [[t] &] t)
(f :args)))
(def call (class-prefix (f :cursor) "method" (f :id)))
(def caller ((unit :invocants-ptr) [(f :ret) t-args]))
(put (c :vtbl-map) (f :id) i)
(array/push vtbl
(string "{.caller=" caller ", .tgt=" call "}"))
)
(let [vstr (string/join (map |(string "\n\t" $ ",") vtbl))
vwr (string "{" vstr "\n}") ]
(array/push (unit :vars)
{:id (string id "_vtbl")
:priv true
:t "const gdjn_vcall[]"
:v |vwr})))
(defn push-event [ev-kind ev-id ret-t args gen]
(push-item :funcs (get-in c [:events ev-kind :cursor])
(:dec <func-c> ret-t ev-id
args
;(gen (if c ["{" (get-in c [:events ev-kind :text] "") "}"] [])))))
(array/push (unit :funcs)
(:dec <func-c> :GDExtensionObjectPtr id-ctor-api
[[:void* :_data]
[:GDExtensionBool :postInit]]
(string/format "return %s() -> self;" id-ctor)))
(def self-ref-t (string "typeof(" id ")*"))
(push-event :ctor id-init :void [[self-ref-t :me]
[:GDExtensionObjectPtr :obj]]
|[(string/format "me -> self = obj;")
;(if (= :native (c :base-mode)) []
[(string id-base "_init(&me -> super, obj);")])
;$])
(array/push (unit :funcs)
(:dec <func-c> :GDExtensionObjectPtr id-create []
"GDExtensionObjectPtr super;"
;(if (= :native (c :base-mode))
(with-names ["superName" (c :base)]
"super = _t(classdb).constructObject(&superName);")
[(string/format "super = %s_create();"
id-base)])
"return super;"))
(def icb-null "(&(GDExtensionInstanceBindingCallbacks){})")
(array/push (unit :funcs)
(:dec <func-c> self-ref-t id-ctor []
(string "typeof("id")* me = _alloc("id", 1);")
;(with-names ["className" (c :id)]
(string/format "auto gdobj = %s();"
id-create)
#`printf("constructed super object %p\n", gdobj);`
"_t(object).setInstance(gdobj, &className, me);"
# register the instance as a binding so
# that other classes can access it. this
# is so dumb
"_t(object).setInstanceBinding("
" gdobj, gdjn_ctx -> gd.lib, me,"
icb-null
");"
(string id-init "(me, gdobj);"))
"return me;"))
(push-event :dtor id-dtor :void
[[:void* :_data]
[:GDExtensionClassInstancePtr :_ptr_me]]
|[(string "typeof("id")* me = _ptr_me;")
;$
"_free(me);"])
(def id-virt (class-prefix (c :cursor) (c :id) "virt"))
(array/push (unit :funcs)
(:dec* <func-c> [:inline :static]
self-ref-t (string id "_data")
[[:GDExtensionObjectPtr :self]]
"return _t(object).getInstanceBinding("
" self, gdjn_ctx -> gd.lib,"
icb-null
");"))
(array/push (unit :funcs) (:dec- <func-c> :void* id-virt
[[:void* :data]
[:GDExtensionConstStringNamePtr :method]
[:uint32_t :hash]]
`bool res = false;`
;(catseq [[name idx] :pairs (c :vtbl-map)] [
;(with-names [:name name]
`_t(stringName).equal(&name, method, &res);`
`if (res) {`
(string "\treturn (void*)&" id "_vtbl[" idx "];")
`}`)])
;(if (= :native (c :base-mode)) [`return nullptr;`]
# inherits from a gdextension class; call up
[(string/format "return %s_virt(data, method, hash);"
id-base)])
))
(def id-virt-call (class-prefix (c :cursor) (c :id) "virt_call"))
(array/push (unit :funcs) (:dec- <func-c> :void id-virt-call
[[:GDExtensionClassInstancePtr :inst]
[:GDExtensionConstStringNamePtr :method]
[:void* :vcall]
["const GDExtensionConstTypePtr*" :args]
[:GDExtensionTypePtr :ret]]
`auto c = (const gdjn_vcall*)vcall;`
`c -> caller(c -> tgt, inst, args, ret);`))
(array/push (unit :load)
;(with-names ["className" (c :id)
"superName" (c :base)]
"auto classDesc = (GDExtensionClassCreationInfo4) {"
` .is_virtual = false,`
(string "\t.is_abstract = " (if (c :abstract) "true" "false")",")
` .is_exposed = true,`
` .is_runtime = true,`
(string "\t.create_instance_func = " id-ctor-api ",")
(string "\t.free_instance_func = " id-dtor ",")
(string "\t.get_virtual_call_data_func = "
id-virt ",")
(string "\t.call_virtual_with_data_func = "
id-virt-call ",")
"};"
`_t(classdb).registerExtensionClass(gdjn_ctx -> gd.lib, &className, &superName, &classDesc);`
))
(def fields
(tuple/join (if (= :native (c :base-mode)) []
[{:id "super"
:t id-base}])
[{:id "self" :t :GDExtensionObjectPtr}]
(seq [f :in (c :fields)]
{:id (f :id)
:t (f :t-c) :v {}
:doc (get-in f [:cursor :doc] nil)})))
(push-item :types (c :cursor)
(:dec <struct-c> id
fields))
(def binder (bind-methods c))
(array/concat (unit :load) binder)
)
(loop [f :in (unit :methods)]
(def class (class-prefix (f :cursor)))
(def cid (class-prefix (f :cursor) "method" (f :id)))
(def cfn (:dec <func-c> (gdtype->ctype (f :ret)) cid
[ [(string class "*") "me"]
;(map (fn [[t id dox]]
[(gdtype->ctype t) id])
(f :args))]
(f :text)))
(def arg-dox
(mapcat (fn [[t id & meta]]
(match (first meta)
([:doc & dox] (not (empty? dox)))
(do (def pfx (string "@param " id " "))
(def pad (string/repeat " " (length pfx)))
[(string pfx (first dox))
;(map |(string pad $) (slice dox 1))])
_ []))
(f :args)))
(let [func-dox (if-let [x (get-in f [:cursor :doc])]
(tuple/join x [""])
[])
ret-dox (if-let [x (f :ret-doc)]
[(string "@return " (first x))
;(if (= (length x) 1) []
(map |(string " " $) (slice x 1)))]
[])
curs (if (empty? arg-dox) (f :cursor)
(:new (f :cursor)
:doc (tuple/join func-dox
arg-dox
ret-dox)))]
(push-item :funcs curs cfn))
)
(let [uf (unit-files unit)]
(:write stdout (case emit
"header" (lines->str (uf :header))
"loader" (lines->str (uf :impl))
(error :bad-cmd)))))
(defn main [& argv]
# (entry ;argv))
(try (entry ;argv)
([e] (:write stderr (style ;(err->msg e))))))