summaryrefslogtreecommitdiff
path: root/libguile
diff options
context:
space:
mode:
Diffstat (limited to 'libguile')
-rw-r--r--libguile/Makefile.am2
-rw-r--r--libguile/foreign-object.c229
-rw-r--r--libguile/foreign-object.h62
-rw-r--r--libguile/goops.c18
-rw-r--r--libguile/init.c1
5 files changed, 301 insertions, 11 deletions
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index f5e859023..df0c7ce01 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -148,6 +148,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \
finalizers.c \
fluids.c \
foreign.c \
+ foreign-object.c \
fports.c \
frames.c \
gc-malloc.c \
@@ -587,6 +588,7 @@ modinclude_HEADERS = \
filesys.h \
fluids.h \
foreign.h \
+ foreign-object.h \
fports.h \
frames.h \
gc.h \
diff --git a/libguile/foreign-object.c b/libguile/foreign-object.c
new file mode 100644
index 000000000..830f73f80
--- /dev/null
+++ b/libguile/foreign-object.c
@@ -0,0 +1,229 @@
+/* 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_0 (SCM type)
+{
+ return scm_make_foreign_object_n (type, 0, NULL);
+}
+
+SCM
+scm_make_foreign_object_1 (SCM type, void *val0)
+{
+ return scm_make_foreign_object_n (type, 1, &val0);
+}
+
+SCM
+scm_make_foreign_object_2 (SCM type, void *val0, void *val1)
+{
+ void *vals[2];
+
+ vals[0] = val0;
+ vals[1] = val1;
+
+ return scm_make_foreign_object_n (type, 2, vals);
+}
+
+SCM
+scm_make_foreign_object_3 (SCM type, void *val0, void *val1, void *val2)
+{
+ void *vals[3];
+
+ vals[0] = val0;
+ vals[1] = val1;
+ vals[2] = val2;
+
+ return scm_make_foreign_object_n (type, 3, vals);
+}
+
+SCM
+scm_make_foreign_object_n (SCM type, size_t n, void *vals[])
+#define FUNC_NAME "make-foreign-object"
+{
+ SCM obj;
+ SCM layout;
+ size_t i;
+ const char *layout_chars;
+
+ 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));
+
+ layout_chars = scm_i_symbol_chars (layout);
+ for (i = 0; i < n; i++)
+ if (layout_chars[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, (scm_t_bits) vals[i]);
+
+ return obj;
+}
+#undef FUNC_NAME
+
+scm_t_bits
+scm_foreign_object_unsigned_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_unsigned_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
+
+scm_t_signed_bits
+scm_foreign_object_signed_ref (SCM obj, size_t n)
+{
+ scm_t_bits bits = scm_foreign_object_unsigned_ref (obj, n);
+ return (scm_t_signed_bits) bits;
+}
+
+void
+scm_foreign_object_signed_set_x (SCM obj, size_t n, scm_t_signed_bits val)
+{
+ scm_t_bits bits = (scm_t_bits) val;
+ scm_foreign_object_unsigned_set_x (obj, n, bits);
+}
+
+void*
+scm_foreign_object_ref (SCM obj, size_t n)
+{
+ scm_t_bits bits = scm_foreign_object_unsigned_ref (obj, n);
+ return (void *) bits;
+}
+
+void
+scm_foreign_object_set_x (SCM obj, size_t n, void *val)
+{
+ scm_t_bits bits = (scm_t_bits) val;
+ scm_foreign_object_unsigned_set_x (obj, n, bits);
+}
+
+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);
+}
diff --git a/libguile/foreign-object.h b/libguile/foreign-object.h
new file mode 100644
index 000000000..806b7eddb
--- /dev/null
+++ b/libguile/foreign-object.h
@@ -0,0 +1,62 @@
+#ifndef SCM_FOREIGN_OBJECT_H
+#define SCM_FOREIGN_OBJECT_H
+
+/* 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
+ */
+
+
+
+#include "libguile/__scm.h"
+#include "libguile/print.h"
+
+
+
+
+SCM_API SCM scm_make_foreign_object_type (SCM name, SCM slot_names,
+ scm_t_struct_finalize finalizer);
+
+SCM_API void scm_assert_foreign_object_type (SCM type, SCM val);
+
+/* All objects of a given foreign object type have the same number of
+ fields. When constructing a foreign object, you don't have to pass
+ initializers for all of the fields; it is always OK to call
+ scm_make_foreign_object_0 and initialize the fields by hand with
+ scm_foreign_object_set_x or other setters. The initial value of
+ fields that haven't been explicitly given a value is 0. */
+SCM_API SCM scm_make_foreign_object_0 (SCM type);
+SCM_API SCM scm_make_foreign_object_1 (SCM type, void *val0);
+SCM_API SCM scm_make_foreign_object_2 (SCM type, void *val0, void *val1);
+SCM_API SCM scm_make_foreign_object_3 (SCM type, void *val0, void *val1,
+ void *val2);
+SCM_API SCM scm_make_foreign_object_n (SCM type, size_t n, void *vals[]);
+
+SCM_API void* scm_foreign_object_ref (SCM obj, size_t n);
+SCM_API void scm_foreign_object_set_x (SCM obj, size_t n, void *val);
+
+SCM_API scm_t_bits scm_foreign_object_unsigned_ref (SCM obj, size_t n);
+SCM_API void scm_foreign_object_unsigned_set_x (SCM obj, size_t n,
+ scm_t_bits val);
+
+SCM_API scm_t_signed_bits scm_foreign_object_signed_ref (SCM obj, size_t n);
+SCM_API void scm_foreign_object_signed_set_x (SCM obj, size_t n,
+ scm_t_signed_bits val);
+
+SCM_INTERNAL void scm_register_foreign_object (void);
+
+
+#endif /* SCM_FOREIGN_OBJECT_H */
diff --git a/libguile/goops.c b/libguile/goops.c
index 2cf343f79..450ae0d55 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -640,7 +640,7 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
get_n_set = SCM_CDR (get_n_set), slots = SCM_CDR (slots))
{
SCM slot_name = SCM_CAR (slots);
- SCM slot_value = SCM_PACK (0);
+ SCM slot_value = SCM_GOOPS_UNBOUND;
if (!scm_is_null (SCM_CDR (slot_name)))
{
@@ -664,12 +664,12 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
slot_value = scm_i_get_keyword (tmp,
initargs,
n_initargs,
- SCM_PACK (0),
+ SCM_GOOPS_UNBOUND,
FUNC_NAME);
}
}
- if (SCM_UNPACK (slot_value))
+ if (!SCM_GOOPS_UNBOUNDP (slot_value))
/* set slot to provided value */
set_slot_value (class, obj, SCM_CAR (get_n_set), slot_value);
else
@@ -677,14 +677,10 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
/* set slot to its :init-form if it exists */
tmp = SCM_CADAR (get_n_set);
if (scm_is_true (tmp))
- {
- slot_value = get_slot_value (class, obj, SCM_CAR (get_n_set));
- if (SCM_GOOPS_UNBOUNDP (slot_value))
- set_slot_value (class,
- obj,
- SCM_CAR (get_n_set),
- scm_call_0 (tmp));
- }
+ set_slot_value (class,
+ obj,
+ SCM_CAR (get_n_set),
+ scm_call_0 (tmp));
}
}
diff --git a/libguile/init.c b/libguile/init.c
index 6de7a2192..b4c966caa 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -395,6 +395,7 @@ scm_i_init_guile (void *base)
scm_bootstrap_vm ();
scm_register_r6rs_ports ();
scm_register_foreign ();
+ scm_register_foreign_object ();
scm_register_srfi_1 ();
scm_register_srfi_60 ();
scm_register_poll ();