diff options
Diffstat (limited to 'libguile')
-rw-r--r-- | libguile/Makefile.am | 2 | ||||
-rw-r--r-- | libguile/foreign-object.c | 229 | ||||
-rw-r--r-- | libguile/foreign-object.h | 62 | ||||
-rw-r--r-- | libguile/goops.c | 18 | ||||
-rw-r--r-- | libguile/init.c | 1 |
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 (); |