improve forege

Makefile.am

@@ -8,7 +8,6 @@ libguile_ts_la_SOURCES= \
 	ts/init.h		\
 	ts/language.c	\
 	ts/foreign.h	\
-	ts/foreign.c	\
 	ts/query.c		\
 	ts/tree.c		\
 	ts/parser.c

ts/foreign.h

@@ -2,18 +2,12 @@
 #define _GTS_FOREIGN_H
 #include <libguile.h>
 
-#define DEFINE_FOREGE_TYPE(c_name, scheme_name, display_name, finalizer)       \
-  SCM_SNARF_HERE(SCM c_name)                                            \
-  SCM_SNARF_INIT({                                                             \
-    SCM _v = make_foreign_object_type(                                         \
-        display_name ? display_name : scheme_name, finalizer);                 \
-    c_name = _v;                                                               \
-    scm_c_define(scheme_name, _v);                                             \
-  })
 #define DEFINE_ENUM(n) \
   SCM_SNARF_INIT(scm_c_define(#n, scm_from_uint32(n)); scm_c_export(#n,NULL));
 #define foreign_object_ref(o) scm_foreign_object_ref(o, 0)
 
-SCM make_foreign_object(SCM type, void *o);
-SCM make_foreign_object_type(char* cname, scm_t_struct_finalize finalizer);
+inline SCM make_foreign_object(SCM type, void *o){
+  return scm_call_2(scm_c_private_ref("ts init", "find-or-create-fobject"),
+                    type, scm_from_pointer(o, NULL));
+};
 #endif

ts/init.scm

@@ -1,3 +1,20 @@
-(define-module (ts init))
+(define-module (ts init)
+  #:use-module (oop goops)
+  #:use-module (system foreign-object)
+  #:use-module ((system foreign) #:prefix ffi:)
+  #:export (find-or-create-fobject))
+
+(define %foreign-objects (make-weak-value-hash-table 3000))
+
+(define (find-fobject pointer)
+  (hash-ref %foreign-objects pointer #f))
+
+(define (find-or-create-fobject type pointer)
+  (let ((exists? (find-fobject pointer)))
+    (or exists?
+        (let ((new-obj (make type #:%data (ffi:pointer-address pointer))))
+          (hash-set! %foreign-objects pointer new-obj)
+          new-obj))))
+
 (eval-when (expand load eval)
   (load-extension "libguile_ts" "init_ts"))

ts/language.c

@@ -5,16 +5,10 @@
 #include "foreign.h"
 #include "util.h"
 
-DEFINE_FOREGE_TYPE(tsl_type,"<ts-language>",NULL,NULL);
 DEFINE_ENUM(TSSymbolTypeRegular);
 DEFINE_ENUM(TSSymbolTypeAnonymous);
 DEFINE_ENUM(TSSymbolTypeAuxiliary);
 
-SCM_DEFINE(ref_or_set, "%rf", 2, 0, 0, (SCM type,SCM point),
-           "") {
-  return make_foreign_object(type,scm_to_pointer(point));
-}
-
 SCM_DEFINE(tsl_field_count, "ts-language-field-count", 1, 0, 0,
            (SCM o), "") {
   ASSERT_TSL(o);

ts/language.scm

@@ -12,6 +12,10 @@
             ts-language-field-name-for-id
             ts-language-version))
 
+(define <ts-language>
+  (make-foreign-object-type
+   '<ts-language> '(%data)))
+
 (eval-when (expand load eval)
   (load-extension "libguile_ts" "init_ts_language"))
 
@@ -21,4 +25,4 @@
                    (parse-path (getenv "TREE_SITTER_GRAMMAR_PATH"))
                    (ltdl-library-path))))
     (let ((o (foreign-library-function lib name #:return-type '*)))
-      (and o (%rf <ts-language> (o))))))
+      (and o (find-or-create-fobject <ts-language> (o))))))

ts/parser.c

@@ -5,9 +5,14 @@
 #include "foreign.h"
 #include "util.h"
 
-static void ts_parser_finalizer(SCM scm) { ts_parser_delete(FR(scm)); }
-
-DEFINE_FOREGE_TYPE(tsp_type,"<%ts-parser>",NULL,ts_parser_finalizer);
+SCM_DEFINE(tsp_delete, "%tsp-delete!", 1, 0, 0, (SCM p), "")
+#define FUNC_NAME s_tsp_delete
+{
+  TSParser *parser=scm_to_pointer(p);
+  ts_parser_delete(parser);
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
 
 inline static void log_call(void *payload, TSLogType logtype, const char *string) {
   SCM proc=payload;
@@ -73,7 +78,7 @@ SCM_DEFINE(tsp_language, "%tsp-language", 1, 0, 0, (SCM o), "") {
   TSParser *tsp = FR(o);
   scm_remember_upto_here_1(o);
   const TSLanguage *tsl = ts_parser_language(tsp);
-  return tsl ? make_foreign_object(tsl_type, tsl) : SCM_BOOL_F;
+  return tsl ? make_foreign_object(scm_c_private_ref("ts language", "<ts-language>"), tsl) : SCM_BOOL_F;
 }
 
 SCM_DEFINE(tsp_included_ranges, "%tsp-included-ranges", 1, 0, 0, (SCM o),
@@ -157,7 +162,7 @@ SCM_DEFINE(tsp_parse_string, "%ts-parser-parse-string", 3, 1, 0,
       ts_parser_parse_string(FR(p), (scm_is_true(tree)) ? (FR(tree)) : NULL,
                              cstring,
                              clength);
-  SCM s_tst=tst ? make_foreign_object(tst_type, tst) : SCM_BOOL_F;
+  SCM s_tst=tst ? make_foreign_object(scm_c_private_ref("ts tree", "<ts-tree>"), tst) : SCM_BOOL_F;
   scm_dynwind_end();
   scm_remember_upto_here_2(p,tree);
   return s_tst;

ts/parser.scm

@@ -1,4 +1,5 @@
 (define-module (ts parser)
+  #:use-module (ts init)
   #:use-module (oop goops)
   #:use-module (ice-9 format)
   #:use-module (srfi srfi-26)
@@ -18,6 +19,14 @@
 (eval-when (expand load eval)
   (load-extension "libguile_ts" "init_ts_parser"))
 
+(define (tsp-delete! o)
+  (let ((%data (slot-ref o '%data)))
+    (%tsp-delete! (make-pointer %data))))
+
+(define <%ts-parser>
+  (make-foreign-object-type
+   '<%ts-parser> '(%data)
+   #:finalizer tsp-delete!))
 (define-class <ts-parser> (<%ts-parser>)
   (language #:allocation #:virtual
             #:slot-ref %tsp-language
@@ -37,7 +46,8 @@
   (logger #:allocation #:virtual
           #:slot-ref %tsp-logger
           #:slot-set! %tsp-set-logger!
-          #:accessor ts-parser-logger))
+          #:accessor ts-parser-logger)
+  #:finalizer tsp-delete!)
 
 (define-method (initialize (obj <ts-parser>) initarg)
   (next-method obj (cons* #:%data (pointer-address (%tsp-new)) initarg)))

ts/query.c

@@ -3,19 +3,13 @@
 #include <string.h>
 #include "foreign.h"
 #include "util.h"
+#define query_type scm_c_private_ref("ts query", "<ts-query>")
+#define query_cursor_type scm_c_private_ref("ts query", "<ts-query-cursor>")
 #define ASSERT_QUERY(o) scm_assert_foreign_object_type(query_type, o)
 #define ASSERT_QC(o) scm_assert_foreign_object_type(query_cursor_type, o)
-static void query_finalizer(SCM q) {
-  TSQuery *query=foreign_object_ref(q);
-  ts_query_delete(query);
-}
-static void qc_finalizer(SCM qc) {
-  TSQueryCursor *c=foreign_object_ref(qc);
-  ts_query_cursor_delete(c);
-}
 
-DEFINE_FOREGE_TYPE(query_type,"<ts-query>",NULL,query_finalizer);
-DEFINE_FOREGE_TYPE(query_cursor_type,"<ts-query-cursor>",NULL,qc_finalizer);
+
+
 DEFINE_ENUM(TSQueryErrorNone);
 DEFINE_ENUM(TSQueryErrorSyntax);
 DEFINE_ENUM(TSQueryErrorNodeType);
@@ -30,6 +24,18 @@ DEFINE_ENUM(TSQuantifierZeroOrMore);
 DEFINE_ENUM(TSQuantifierOne);
 DEFINE_ENUM(TSQuantifierOneOrMore);
 
+SCM_DEFINE(query_delete,"%ts_query_delete",1,0,0,(SCM p),""){
+  TSQuery *tsq=scm_to_pointer(p);
+  ts_query_delete(tsq);
+  return SCM_UNSPECIFIED;
+}
+
+SCM_DEFINE(query_cursor_delete,"%ts_query_cursor_delete",1,0,0,(SCM p),""){
+  TSQueryCursor *tsq=scm_to_pointer(p);
+  ts_query_cursor_delete(tsq);
+  return SCM_UNSPECIFIED;
+}
+
 SCM_DEFINE(query_new, "%ts-query-new", 2,0, 0,
            (SCM language,SCM source),
            "")

ts/query.scm

@@ -2,6 +2,8 @@
   #:use-module (ts init)
   #:use-module (ts util)
   #:use-module (ts language)
+  #:use-module (system foreign-object)
+  #:use-module ((system foreign) #:select (make-pointer))
   #:use-module (oop goops)
   #:use-module (srfi srfi-171)
   #:use-module (srfi srfi-71)
@@ -40,6 +42,24 @@
   (offset ts-query-syntax-error-offset)
   (type ts-query-syntax-error-type))
 
+(define (%ts-query-delete obj)
+  (let ((%data (slot-ref obj '%data)))
+    (%ts_query_delete (make-pointer %data))))
+
+(define (%ts-query-cursor-delete obj)
+  (let ((%data (slot-ref obj '%data)))
+    (%ts_query_cursor_delete (make-pointer %data))))
+
+(define <ts-query>
+  (make-foreign-object-type
+   '<ts-query> '(%data)
+   #:finalizer %ts-query-delete))
+
+(define <ts-query-cursor>
+  (make-foreign-object-type
+   '<ts-query-cursor> '(%data)
+   #:finalizer %ts-query-cursor-delete))
+
 (eval-when (expand load eval)
   (load-extension "libguile_ts" "init_ts_query"))
 

ts/tree.c

@@ -20,43 +20,42 @@ SCM make_node(TSNode tsn) {
   Node *node=gts_malloc(sizeof(Node));
   node->node=tsn;
   scm_gc_protect_object(node_tree(tsn));
-  return make_foreign_object(tsn_type,node);
+  return make_foreign_object(scm_c_private_ref("ts tree", "<ts-node>"),node);
 }
 
 SCM node_tree(TSNode tsn) {
-  return make_foreign_object(tst_type, tsn.tree);
+  return make_foreign_object(scm_c_private_ref("ts tree", "<ts-tree>"), tsn.tree);
 }
 
-static void node_finalizer(SCM o) {
-  Node *node=FR(o);
-  scm_gc_unprotect_object(node_tree(node->node));
-  gts_free(node);
-}
-
-DEFINE_FOREGE_TYPE(tsn_type,"<ts-node>",NULL,node_finalizer);
-
 typedef struct {
   TSTreeCursor cursor;
 } Tcursor;
 
-static void ts_tree_finalizer(SCM scm) {
-  ts_tree_delete(FR(scm));
+SCM_DEFINE(node_finalizer,"%node_finalizer",1,0,0,(SCM p),""){
+  Node *node=scm_to_pointer(p);
+  scm_gc_unprotect_object(node_tree(node->node));
+  gts_free(node);
+  return SCM_UNSPECIFIED;
 }
-DEFINE_FOREGE_TYPE(tst_type,"<ts-tree>",NULL,ts_tree_finalizer);
 
-static void ts_tcursor_finalizer(SCM cursor) {
-  Tcursor *tc = FR(cursor);
+SCM_DEFINE(tree_delete,"%ts_tree_delete",1,0,0,(SCM p),""){
+  TSTree *obj=scm_to_pointer(p);
+  ts_tree_delete(obj);
+  return SCM_UNSPECIFIED;
+}
+SCM_DEFINE(tcursor_finalizer,"%tcursor_finalizer",1,0,0,(SCM p),""){
+  Tcursor *tc = scm_to_pointer(p);
   ts_tree_cursor_delete(&tc->cursor);
   gts_free(tc);
 }
-DEFINE_FOREGE_TYPE(tstc_type,"<ts-tree-cursor>",NULL,ts_tcursor_finalizer);
+
 #define ASSERT_TSTC(o)                                 \
-  scm_assert_foreign_object_type(tstc_type, o)
+  scm_assert_foreign_object_type(scm_c_private_ref("ts tree", "<ts-tree-cursor>"), o)
 
 static SCM make_tcursor(TSTreeCursor tstc) {
   Tcursor *t=gts_malloc(sizeof(Tcursor));
   t->cursor=tstc;
-  SCM ts=make_foreign_object(tstc_type,t);
+  SCM ts=make_foreign_object(scm_c_private_ref("ts tree", "<ts-tree-cursor>"),t);
   return ts;
 }
 
@@ -66,7 +65,7 @@ SCM_DEFINE(tst_copy, "ts-tree-copy", 1, 0, 0, (SCM o), "")
   ASSERT_TST(o);
   TSTree *tst = FR(o);
   scm_remember_upto_here_1(o);
-  return make_foreign_object(tst_type, ts_tree_copy(tst));
+  return make_foreign_object(scm_c_private_ref("ts tree", "<ts-tree>"), ts_tree_copy(tst));
 }
 #undef FUNC_NAME
 
@@ -75,7 +74,7 @@ SCM_DEFINE(tst_language, "ts-tree-language", 1, 0, 0, (SCM o), "")
 {
   ASSERT_TST(o);
   TSTree *tst = FR(o);
-  SCM l=make_foreign_object(tsl_type, ts_tree_language(tst));
+  SCM l=make_foreign_object(scm_c_private_ref("ts language", "<ts-language>"), ts_tree_language(tst));
   scm_remember_upto_here_1(o);
   return l;
 }

ts/tree.scm

@@ -46,6 +46,31 @@
             ts-tree-edit
             ts-tree-get-changed-ranges))
 
+(define (%tcursor-finalizer o)
+  (let ((%data (slot-ref o '%data)))
+    (%tcursor_finalizer (make-pointer %data))))
+
+(define (%ts-tree-delete! o)
+  (let ((%data (slot-ref o '%data)))
+    (%ts_tree_delete (make-pointer %data))))
+
+(define (%node-finalizer o)
+  (let ((%data (slot-ref o '%data)))
+    (%node_finalizer (make-pointer %data))))
+
+(define <ts-node>
+  (make-foreign-object-type
+   '<ts-node> '(%data)
+   #:finalizer %node-finalizer))
+(define <ts-tree>
+  (make-foreign-object-type
+   '<ts-tree> '(%data)
+   #:finalizer %ts-tree-delete!))
+(define <ts-tree-cursor>
+  (make-foreign-object-type
+   '<ts-tree-cursor> '(%data)
+   #:finalizer %tcursor-finalizer))
+
 (eval-when (expand load eval)
   (load-extension "libguile_ts" "init_ts_tree"))
 

ts/util.c

@@ -15,10 +15,6 @@ value_range_error (const char* subr, SCM bad_val, SCM min, SCM max)
              scm_list_1 (bad_val));
 }
 
-extern SCM type_table ;
-
-
-DEFINE_FOREGE_TYPE(tsr_type,"<%ts-range>",NULL,NULL);
 DEFINE_ENUM(TSSymbolTypeRegular);
 DEFINE_ENUM(TSSymbolTypeAnonymous);
 DEFINE_ENUM(TSSymbolTypeAuxiliary);
@@ -80,8 +76,6 @@ SCM_DEFINE(tsr_set_end_byte, "%tsr-set-end-byte!", 2, 0, 0, (SCM r,SCM o),
 }
 
 void init_ts_util() {
-  type_table=scm_make_weak_value_hash_table(scm_from_int(3000));
-
 #ifndef SCM_MAGIC_SNARFER
 #include "util.x"
 #endif