New foreign object facility, to replace SMOBs

* libguile/foreign-object.c:
* libguile/foreign-object.h:
* module/system/foreign-object.scm:
* test-suite/standalone/test-foreign-object-c.c:
* test-suite/standalone/test-foreign-object-scm: New files.

* test-suite/standalone/Makefile.am:
* module/Makefile.am:
* libguile/Makefile.am: Add new files.

* libguile.h: Add foreign-object.h.
* libguile/init.c (scm_i_init_guile): Call scm_register_foreign_object.

1 files changed, 187 insertions, 0 deletions

diff --git a/libguile/foreign-object.c b/libguile/foreign-object.c
new file mode 100644
index 000000000..78b017aa5
--- /dev/null
+++ b/libguile/foreign-object.c
@@ -0,0 +1,187 @@
+/* Copyright (C) 2014 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+
+#ifdef HAVE_CONFIG_H
+#  include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/goops.h"
+#include "libguile/foreign-object.h"
+
+
+
+
+static SCM make_fobj_type_var;
+
+static void
+init_make_fobj_type_var (void)
+{
+  make_fobj_type_var = scm_c_private_lookup ("system foreign-object",
+                                             "make-foreign-object-type");
+}
+
+SCM
+scm_make_foreign_object_type (SCM name, SCM slot_names,
+                              scm_t_struct_finalize finalizer)
+{
+  SCM type;
+
+  static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+  scm_i_pthread_once (&once, init_make_fobj_type_var);
+
+  type = scm_call_2 (scm_variable_ref (make_fobj_type_var), name, slot_names);
+
+  if (finalizer)
+    SCM_SET_VTABLE_INSTANCE_FINALIZER (type, finalizer);
+
+  return type;
+}
+
+void
+scm_assert_foreign_object_type (SCM type, SCM val)
+{
+  if (!SCM_IS_A_P (val, type))
+    scm_error (scm_arg_type_key, NULL, "Wrong type (expecting ~A): ~S",
+               scm_list_2 (scm_class_name (type), val), scm_list_1 (val));
+}
+
+SCM
+scm_make_foreign_object_1 (SCM type, scm_t_bits val0)
+{
+  return scm_make_foreign_object_n (type, 1, &val0);
+}
+
+SCM
+scm_make_foreign_object_2 (SCM type, scm_t_bits val0, scm_t_bits val1)
+{
+  scm_t_bits vals[2] = { val0, val1 };
+
+  return scm_make_foreign_object_n (type, 2, vals);
+}
+
+SCM
+scm_make_foreign_object_3 (SCM type, scm_t_bits val0, scm_t_bits val1,
+                           scm_t_bits val2)
+{
+  scm_t_bits vals[3] = { val0, val1, val2 };
+
+  return scm_make_foreign_object_n (type, 3, vals);
+}
+
+SCM
+scm_make_foreign_object_n (SCM type, size_t n, scm_t_bits vals[])
+#define FUNC_NAME "make-foreign-object"
+{
+  SCM obj;
+  SCM layout;
+  size_t i;
+
+  SCM_VALIDATE_VTABLE (SCM_ARG1, type);
+
+  layout = SCM_VTABLE_LAYOUT (type);
+
+  if (scm_i_symbol_length (layout) / 2 < n)
+    scm_out_of_range (FUNC_NAME, scm_from_size_t (n));
+
+  for (i = 0; i < n; i++)
+    if (scm_i_symbol_ref (layout, i * 2) != 'u')
+      scm_wrong_type_arg_msg (FUNC_NAME, 0, layout, "'u' field");
+
+  obj = scm_c_make_structv (type, 0, 0, NULL);
+
+  for (i = 0; i < n; i++)
+    SCM_STRUCT_DATA_SET (obj, i, vals[i]);
+
+  return obj;
+}
+#undef FUNC_NAME
+
+scm_t_bits
+scm_foreign_object_ref (SCM obj, size_t n)
+#define FUNC_NAME "foreign-object-ref"
+{
+  SCM layout;
+
+  SCM_VALIDATE_STRUCT (SCM_ARG1, obj);
+  
+  layout = SCM_STRUCT_LAYOUT (obj);
+  if (scm_i_symbol_length (layout) / 2 < n)
+    scm_out_of_range (FUNC_NAME, scm_from_size_t (n));
+
+  if (scm_i_symbol_ref (layout, n * 2) != 'u')
+    scm_wrong_type_arg_msg (FUNC_NAME, 0, layout, "'u' field");
+
+  return SCM_STRUCT_DATA_REF (obj, n);
+}
+#undef FUNC_NAME
+
+void
+scm_foreign_object_set_x (SCM obj, size_t n, scm_t_bits val)
+#define FUNC_NAME "foreign-object-set!"
+{
+  SCM layout;
+
+  SCM_VALIDATE_STRUCT (SCM_ARG1, obj);
+  
+  layout = SCM_STRUCT_LAYOUT (obj);
+  if (scm_i_symbol_length (layout) / 2 < n)
+    scm_out_of_range (FUNC_NAME, scm_from_size_t (n));
+
+  if (scm_i_symbol_ref (layout, n * 2) != 'u')
+    scm_wrong_type_arg_msg (FUNC_NAME, 0, layout, "'u' field");
+
+  SCM_STRUCT_DATA_SET (obj, n, val);
+}
+#undef FUNC_NAME
+  
+static void
+invoke_finalizer (void *obj, void *data)
+{
+  scm_call_1 (PTR2SCM (data), PTR2SCM (obj));
+}
+
+static SCM
+sys_add_finalizer_x (SCM obj, SCM finalizer)
+#define FUNC_NAME "%add-finalizer!"
+{
+  SCM_VALIDATE_PROC (SCM_ARG2, finalizer);
+
+  scm_i_add_finalizer (SCM2PTR (obj), invoke_finalizer, SCM2PTR (finalizer));
+
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+static void
+scm_init_foreign_object (void)
+{
+  scm_c_define_gsubr ("%add-finalizer!", 2, 0, 0,
+                      (scm_t_subr) sys_add_finalizer_x);
+}
+
+void
+scm_register_foreign_object (void)
+{
+  scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+                            "scm_init_foreign_object",
+                            (scm_t_extension_init_func)scm_init_foreign_object,
+                            NULL);
+}