Differences From
Artifact [a0ecf192d6]:
33 33 (<- (any (+ (* `\` (backmatch :quo))
34 34 (if-not (backmatch :quo) 1))))
35 35 (backmatch :quo)) :quo)))
36 36 (defn fail [cause]
37 37 (defn mk [ln col]
38 38 {:kind :parse
39 39 :cause cause
40 + :src (dyn *src-file* "<stdin>")
40 41 :ln ln :col col})
41 42 ~(error (cmt (* (line) (column)) ,mk)))
42 43 (defn req [id body]
43 44 ~(+ (* ,;body) ,(fail (keyword :malformed- id))))
44 45 (defn kw [id body]
45 46 ~(* ,id (> 1 :bound) ,(req id ~(:s+ ,;body))))
46 47 (defn comment-syntax [id open close]
................................................................................
186 187 (enter body ""))
187 188
188 189 (defn err->msg [e]
189 190 (defn err-span [h & m] [:span [:hl [:red h]] ": " ;m ])
190 191 (match e
191 192 {:kind :parse} (err-span "parse error"
192 193 (string (e :cause) " at ")
193 - [:hl (string/format "%d:%d" (e :ln) (e :col))])
194 + [:hl (string/format "%s:%d:%d" (e :src) (e :ln) (e :col))])
194 195 _ (error e)))
195 196 # _ (err-span "error"
196 197 # "something went wrong (" [:em (string e)] ")")))
197 198
198 199
199 200 (defn indent [n lst]
200 201 (map |(string (string/repeat "\t" n) $) lst))
................................................................................
360 361 [:ref _] :object
361 362 x (keyword x)))
362 363 (defn gdtype->ctype [t]
363 364 (match t
364 365 :void :void
365 366 :float :double
366 367 :int :int64_t
367 - :bool :bool
368 + :bool :uint8_t
368 369 [:array _] :gd_array
369 370 [:dictionary _] :gd_dictionary
370 371 [:ref _] :GDExtensionObjectPtr
371 372
372 373 # use an opaque wrapper struct defined in interface.h
373 374 x (string "gd_" (:say (:read <sym> t)))))
374 375
................................................................................
377 378 ~(do (var ,acc ,init)
378 379 (loop ,binds
379 380 (set ,acc (do ,;body)))
380 381 ,acc))
381 382
382 383
383 384 (defn unit-files [u]
384 - (def h @[ `#pragma once` `#include "gdjn.h"` `#include "util.h"`
385 + (def h @[ `#pragma once` `#include "gdjn.h"`
385 386 ;(u :header-prefix)])
386 387 (def c @[
387 388 (string `#include "` (:stab (u :name)) `.h"`)
388 389 `typedef struct gdjn_vcall {`
389 390 ` GDExtensionClassMethodPtrCall caller; `
390 391 ` void* tgt;`
391 392 `} gdjn_vcall;`
................................................................................
700 701 :method (array/push (cls :methods) meth)
701 702 :impl (array/push (cls :impls) meth)))
702 703 )))
703 704
704 705 (def root (:new <cursor> :unit unit))
705 706 (each n ast (process n root))
706 707
707 - (defn class-prefix [c & r]
708 + (defn class-prefix* [sep c begin r]
708 709 (def pf (let [p (:prefix c)]
709 710 (if (empty? p) [] [p])))
710 - (string/join ["gdjn_class" ;pf ;r] "_"))
711 + (string/join [;begin ;pf ;r] sep))
712 + (defn class-prefix. [c & r]
713 + (class-prefix* "." c [] r))
714 + (defn class-prefix_ [c & r]
715 + (class-prefix* "_" c ["gdjn_class"] r))
711 716
712 717 (defn bind-methods [class]
713 718 (defn bind [f kind]
714 719 (def t-args (map (fn [[t] &] t)
715 720 (f :args)))
716 721 (def invocant
717 - ((unit :invocants) [(f :ret) t-args]))
722 + |((unit :invocants) [(f :ret) t-args]))
718 723 (def invocant-ptr
719 - ((unit :invocants-ptr) [(f :ret) t-args]))
724 + |((unit :invocants-ptr) [(f :ret) t-args]))
720 725 (def fp-t (func-ptr-t (gdtype->ctype (f :ret))
721 726 [(string "typeof("
722 - (class-prefix (class :cursor)
723 - (class :id))")*")
727 + (class-prefix_ (class :cursor)
728 + (class :id))")*")
724 729 ;(map gdtype->ctype t-args)]))
725 730
726 731 (def strings-lst @[])
727 732 (def strings
728 733 (cache (fn [idx text]
729 734 (def id (string "_priv_str_" idx))
730 735 (array/push strings-lst id text)
................................................................................
763 768 `,`])
764 769 :impl [`.return_value = `
765 770 ;(prop-info (if (= :void (f :ret)) :nil
766 771 (f :ret)))]
767 772 )])
768 773 )
769 774
770 - (def fn-path (class-prefix (f :cursor) "method" (f :id)))
775 + (def fn-path (class-prefix_ (f :cursor) "method" (f :id)))
771 776 (with-names [:s_methodName (f :id) ;strings-lst]
772 777 (if (not= kind :method) ""
773 778 (string fp-t " func = " fn-path ";"))
774 779 (string/format `auto info = (%s) {`
775 780 (case kind
776 781 :method "GDExtensionClassMethodInfo"
777 782 :impl "GDExtensionClassVirtualMethodInfo"))
................................................................................
780 785 (length t-args) ",")
781 786 ;(indent 1 arg-info)
782 787 ;(if (= kind :method) [
783 788 ` .method_userdata = func,`
784 789 ` .method_flags = GDEXTENSION_METHOD_FLAGS_DEFAULT,`
785 790 (string "\t.has_return_value = "
786 791 (if (= :void (f :ret)) "false" "true") ",")
787 - (string "\t.call_func = " invocant ",")
788 - (string "\t.ptrcall_func = " invocant-ptr ",")
792 + (string "\t.call_func = " (invocant) ",")
793 + (string "\t.ptrcall_func = " (invocant-ptr) ",")
789 794 ] [])
790 795 ;ret-info
791 796 `};`
792 797 (comment (string `printf("binding method %s\n",`
793 798 (string/format "%q" fn-path)
794 799 `);`))
795 800 (string `_t(classdb).`
796 801 (case kind
797 802 :method "registerExtensionClassMethod"
798 803 :impl "registerExtensionClassVirtualMethod")
799 804 `(gdjn_ctx -> gd.lib, &s_className, &info);`)))
800 - (array/concat @[] "{" ;(with-names [:s_className (class :id)]
805 + (def class-path (class-prefix* "_" (class :cursor) [] [(class :id)]))
806 + (array/concat @[] "{" ;(with-names [:s_className class-path]
801 807 ;(map |(bind $ :method) (class :methods))
802 808 ;(map |(bind $ :impl) (class :impls))) "}"))
803 809
804 810 (defn push-item [kind cursor item] # abuse hashtables for fun & profit
805 811 (array/push (unit kind) item)
806 812 (when (and cursor (cursor :doc))
807 813 (put (unit :doc) item (cursor :doc))))
808 814
809 815 (loop [c :in (unit :classes)]
810 - (def id (class-prefix (c :cursor) (c :id)))
816 + (def id (class-prefix_ (c :cursor) (c :id)))
811 817 (def [id-ctor id-dtor
812 818 id-ctor-api
813 819 id-init id-create]
814 820 (map |(string id "_" $) ["new" "del"
815 821 "api_new" "init" "create"]))
816 822
817 823 (def id-base (as-> (c :base) b
................................................................................
820 826 (string "gdjn_class_" b))) #HAAACK
821 827 (when (not (empty? (c :impls)))
822 828 (def vtbl @[])
823 829 (loop [i :range [0 (length (c :impls))]
824 830 :let [f ((c :impls) i)]]
825 831 (def t-args (map (fn [[t] &] t)
826 832 (f :args)))
827 - (def call (class-prefix (f :cursor) "method" (f :id)))
833 + (def call (class-prefix_ (f :cursor) "method" (f :id)))
828 834 (def caller ((unit :invocants-ptr) [(f :ret) t-args]))
829 835 (put (c :vtbl-map) (f :id) i)
830 836 (array/push vtbl
831 837 (string "{.caller=" caller ", .tgt=" call "}"))
832 838 )
833 839 (let [vstr (string/join (map |(string "\n\t" $ ",") vtbl))
834 840 vwr (string "{" vstr "\n}") ]
................................................................................
862 868 (with-names ["superName" (c :base)]
863 869 "super = _t(classdb).constructObject(&superName);")
864 870 [(string/format "super = %s_create();"
865 871 id-base)])
866 872 "return super;"))
867 873
868 874 (def icb-null "(&(GDExtensionInstanceBindingCallbacks){})")
875 + (def class-path (class-prefix* "_" (c :cursor) [] [(c :id)]))
869 876 (array/push (unit :funcs)
870 877 (:dec <func-c> self-ref-t id-ctor []
878 + (string `printf("creating object ` id `\n");`)
871 879 (string "typeof("id")* me = _alloc("id", 1);")
872 - ;(with-names ["className" (c :id)]
880 + ;(with-names ["className" class-path]
873 881 (string/format "auto gdobj = %s();"
874 882 id-create)
875 883 #`printf("constructed super object %p\n", gdobj);`
876 884 "_t(object).setInstance(gdobj, &className, me);"
877 885 # register the instance as a binding so
878 886 # that other classes can access it. this
879 887 # is so dumb
................................................................................
884 892 (string id-init "(me, gdobj);"))
885 893 "return me;"))
886 894 (push-event :dtor id-dtor :void
887 895 [[:void* :_data]
888 896 [:GDExtensionClassInstancePtr :_ptr_me]]
889 897 |[(string "typeof("id")* me = _ptr_me;")
890 898 ;$
891 - "_free(me);"])
892 - (def id-virt (class-prefix (c :cursor) (c :id) "virt"))
899 + (if (= :native (c :base-mode)) "_free(me);"
900 + (string/format "%s_del(_data, &me -> super);"
901 + id-base))])
902 + (def id-virt (class-prefix_ (c :cursor) (c :id) "virt"))
893 903 (array/push (unit :funcs)
894 904 (:dec* <func-c> [:inline :static]
895 905 self-ref-t (string id "_data")
896 906 [[:GDExtensionObjectPtr :self]]
897 907 "return _t(object).getInstanceBinding("
898 908 " self, gdjn_ctx -> gd.lib,"
899 909 icb-null
900 910 ");"))
901 911
902 912 (array/push (unit :funcs) (:dec- <func-c> :void* id-virt
903 913 [[:void* :data]
904 914 [:GDExtensionConstStringNamePtr :method]
905 915 [:uint32_t :hash]]
906 - `bool res = false;`
907 - ;(catseq [[name idx] :pairs (c :vtbl-map)] [
908 - ;(with-names [:name name]
909 - `_t(stringName).equal(&name, method, &res);`
910 - `if (res) {`
911 - (string "\treturn (void*)&" id "_vtbl[" idx "];")
912 - `}`)])
916 + ;(catseq [[name idx] :pairs (c :vtbl-map)]
917 + [ `{bool res = false;`
918 + ;(with-names [:name name]
919 + `_t(stringName).equal(&name, method, &res);`)
920 + `if (res) {`
921 + (string "\treturn (void*)&" id "_vtbl[" idx "];")
922 + `}}`])
913 923 ;(if (= :native (c :base-mode)) [`return nullptr;`]
914 924 # inherits from a gdextension class; call up
915 925 [(string/format "return %s_virt(data, method, hash);"
916 926 id-base)])
917 927 ))
918 - (def id-virt-call (class-prefix (c :cursor) (c :id) "virt_call"))
928 + (def id-virt-call (class-prefix_ (c :cursor) (c :id) "virt_call"))
919 929 (array/push (unit :funcs) (:dec- <func-c> :void id-virt-call
920 930 [[:GDExtensionClassInstancePtr :inst]
921 931 [:GDExtensionConstStringNamePtr :method]
922 932 [:void* :vcall]
923 933 ["const GDExtensionConstTypePtr*" :args]
924 934 [:GDExtensionTypePtr :ret]]
925 935 `auto c = (const gdjn_vcall*)vcall;`
926 936 `c -> caller(c -> tgt, inst, args, ret);`))
937 + (def class-path (class-prefix* "_" (c :cursor) [] [(c :id)]))
927 938 (array/push (unit :load)
928 - ;(with-names ["className" (c :id)
939 + ;(with-names ["className" class-path
929 940 "superName" (c :base)]
930 941 "auto classDesc = (GDExtensionClassCreationInfo4) {"
931 942 ` .is_virtual = false,`
932 943 (string "\t.is_abstract = " (if (c :abstract) "true" "false")",")
933 944 ` .is_exposed = true,`
934 945 ` .is_runtime = true,`
935 946 (string "\t.create_instance_func = " id-ctor-api ",")
................................................................................
956 967 (def binder (bind-methods c))
957 968 (array/concat (unit :load) binder)
958 969
959 970
960 971
961 972 )
962 973 (loop [f :in (unit :methods)]
963 - (def class (class-prefix (f :cursor)))
964 - (def cid (class-prefix (f :cursor) "method" (f :id)))
974 + (def class (class-prefix_ (f :cursor)))
975 + (def cid (class-prefix_ (f :cursor) "method" (f :id)))
965 976 (def cfn (:dec <func-c> (gdtype->ctype (f :ret)) cid
966 977 [ [(string class "*") "me"]
967 978 ;(map (fn [[t id dox]]
968 979 [(gdtype->ctype t) id])
969 980 (f :args))]
970 981 (f :text)))
971 982 (def arg-dox
................................................................................
997 1008 (let [uf (unit-files unit)]
998 1009 (:write stdout (case emit
999 1010 "header" (lines->str (uf :header))
1000 1011 "loader" (lines->str (uf :impl))
1001 1012 (error :bad-cmd)))))
1002 1013
1003 1014 (defn main [& argv]
1004 - # (entry ;argv))
1005 - (try (entry ;argv)
1006 - ([e] (:write stderr (style ;(err->msg e))))))
1015 + (entry ;argv))
1016 + # (try (entry ;argv)
1017 + # ([e] (:write stderr (style ;(err->msg e)) "\n"))))