summaryrefslogtreecommitdiff
path: root/libguile/foreign.c
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2010-01-18 11:42:35 +0100
committerAndy Wingo <wingo@pobox.com>2010-01-26 22:56:41 +0100
commit52fd9639fdeee068434342e1bdb8693b05ecac5c (patch)
tree9d8ab132c65a07ce2c2b102ae66682df5085d977 /libguile/foreign.c
parent75c242a256c273ab0690397df4277d44f01946e6 (diff)
downloadguile-52fd9639fdeee068434342e1bdb8693b05ecac5c.tar.gz
foreign.h presents a more pointer-centric interface
* libguile/foreign.c: * libguile/foreign.h: Rework interface to be more pointer-centric. Details are: (SCM_FOREIGN_TYPE_STRUCT, SCM_FOREIGN_TYPE_POINTER): Removed; now the pointer in a foreign is first-class. If it points to a native type like uint32, then it still has a tag; but if it points to something else, like a struct or a pointer or something, then its type is VOID (i.e., void*). (SCM_FOREIGN_POINTER): Rename from SCM_FOREIGN_OBJECT. (SCM_FOREIGN_VALUE_REF, SCM_FOREIGN_VALUE_SET): Rename from SCM_FOREIGN_OBJECT_REF and SCM_FOREIGN_OBJECT_SET, to indicate that they only work with value types. (SCM_FOREIGN_HAS_FINALIZER): Reserve a bit to indicate if the foreign pointer in question has a finalizer registered. (SCM_FOREIGN_LEN): For void* pointers, optionally store the length in bytes of the associated memory region. (SCM_FOREIGN_VALUE_P): Rename from SCM_FOREIGN_SIMPLE_P. (SCM_VALIDATE_FOREIGN_VALUE): Rename from SCM_VALIDATE_FOREIGN_SIMPLE. (scm_take_foreign_pointer): Rename from scm_c_take_foreign. Remove scm_c_from_foreign. (scm_foreign_type): New accessor. (scm_foreign_ref, scm_foreign_set_x): Take some optional args, used when dereferencing void pointers. * libguile/dynl.h: * libguile/dynl.c (scm_dynamic_pointer): New function, used by scm_dynamic_func. Adapt code to foreign.h changes. * libguile/goops.c (scm_enable_primitive_generic_x) (scm_set_primitive_generic_x): Use the SCM_SET_SUBR_GENERIC macro. * libguile/gsubr.c (create_gsubr): Adapt to API change. * libguile/gsubr.h (SCM_SUBRF, SCM_SUBR_GENERIC): Store the pointer directly, not indirected. * libguile/snarf.h (SCM_DEFINE, SCM_IMMUTABLE_FOREIGN): Store subr pointers directly. Adapt to SCM_FOREIGN_TYPE_VOID change. * libguile/vm-i-system.c (subr-call): Access the void* directly.
Diffstat (limited to 'libguile/foreign.c')
-rw-r--r--libguile/foreign.c268
1 files changed, 151 insertions, 117 deletions
diff --git a/libguile/foreign.c b/libguile/foreign.c
index 4a4b2181a..ec76a00aa 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -26,52 +26,29 @@
-static size_t
-sizeof_type (scm_t_foreign_type type)
-{
- switch (type)
- {
- case SCM_FOREIGN_TYPE_VOID: abort ();
- case SCM_FOREIGN_TYPE_FLOAT: return sizeof(float);
- case SCM_FOREIGN_TYPE_DOUBLE: return sizeof(double);
- case SCM_FOREIGN_TYPE_UINT8: return sizeof(scm_t_uint8);
- case SCM_FOREIGN_TYPE_INT8: return sizeof(scm_t_int8);
- case SCM_FOREIGN_TYPE_UINT16: return sizeof(scm_t_uint16);
- case SCM_FOREIGN_TYPE_INT16: return sizeof(scm_t_int16);
- case SCM_FOREIGN_TYPE_UINT32: return sizeof(scm_t_uint32);
- case SCM_FOREIGN_TYPE_INT32: return sizeof(scm_t_int32);
- case SCM_FOREIGN_TYPE_UINT64: return sizeof(scm_t_uint64);
- case SCM_FOREIGN_TYPE_INT64: return sizeof(scm_t_int64);
- case SCM_FOREIGN_TYPE_STRUCT: abort ();
- case SCM_FOREIGN_TYPE_POINTER: return sizeof(void*);
- default: abort ();
- }
-}
-
-
static void
foreign_finalizer_trampoline (GC_PTR ptr, GC_PTR data)
{
scm_t_foreign_finalizer finalizer = data;
- finalizer (SCM_FOREIGN_OBJECT (PTR2SCM (ptr), void*));
+ finalizer (SCM_FOREIGN_POINTER (PTR2SCM (ptr), void));
}
SCM
-scm_c_from_foreign (scm_t_foreign_type type, void *val, size_t size,
- scm_t_foreign_finalizer finalizer)
+scm_take_foreign_pointer (scm_t_foreign_type type, void *ptr, size_t len,
+ scm_t_foreign_finalizer finalizer)
{
SCM ret;
- if (!size)
- size = sizeof_type (type);
+ scm_t_bits word0;
- ret = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_bits) * 2 + size,
+ word0 = (scm_t_bits)(scm_tc7_foreign | (type<<8)
+ | (finalizer ? (1<<16) : 0) | (len<<17));
+ if (SCM_UNLIKELY ((word0 >> 16) != len))
+ scm_out_of_range ("scm_take_foreign_pointer", scm_from_size_t (len));
+
+ ret = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_bits) * 2,
"foreign"));
- SCM_SET_CELL_WORD_0 (ret, (scm_t_bits)(scm_tc7_foreign | (type<<8)));
-
- /* set SCM_FOREIGN_OBJECT to point to the third word of the object, which will
- be 8-byte aligned. Then copy *val into that space. */
- SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2));
- memcpy (SCM_FOREIGN_OBJECT (ret, void), val, size);
+ SCM_SET_CELL_WORD_0 (ret, word0);
+ SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)ptr);
if (finalizer)
{
@@ -88,124 +65,167 @@ scm_c_from_foreign (scm_t_foreign_type type, void *val, size_t size,
return ret;
}
-SCM
-scm_c_take_foreign (scm_t_foreign_type type, void *val,
- scm_t_foreign_finalizer finalizer)
+static void
+keepalive (GC_PTR obj, GC_PTR data)
{
- SCM ret;
-
- ret = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_bits) * 2,
- "foreign"));
- SCM_SET_CELL_WORD_0 (ret, (scm_t_bits)(scm_tc7_foreign | (type<<8)));
- /* Set SCM_FOREIGN_OBJECT to the given pointer. */
- SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)val);
-
- if (finalizer)
- {
- /* Register a finalizer for the newly created instance. */
- GC_finalization_proc prev_finalizer;
- GC_PTR prev_finalizer_data;
- GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret),
- foreign_finalizer_trampoline,
- finalizer,
- &prev_finalizer,
- &prev_finalizer_data);
- }
-
- return ret;
}
-SCM_DEFINE (scm_foreign_ref, "foreign-ref", 1, 0, 0,
- (SCM foreign),
+SCM_DEFINE (scm_foreign_ref, "foreign-ref", 1, 3, 0,
+ (SCM foreign, SCM type, SCM offset, SCM len),
"Reference the foreign value wrapped by @var{foreign}.\n\n"
- "Note that only \"simple\" types may be referenced by this\n"
- "function. See @code{foreign-struct-ref} or @code{foreign-pointer-ref}\n"
- "for structs or pointers, respectively.")
+ "The value will be referenced according to its type.\n"
+ "If and only if the type of the foreign value is @code{void},\n"
+ "this function accepts optional @var{type} and @var{offset}\n"
+ "arguments, indicating that the pointer wrapped by\n"
+ "@var{foreign} should be incremented by @var{offset} bytes,\n"
+ "and treated as a pointer to a value of the given @var{type}.\n"
+ "@var{offset} defaults to 0.\n\n"
+ "If @var{type} itself is @code{void}, @var{len} will be used\n"
+ "to specify the size of the resulting @code{void} pointer.")
#define FUNC_NAME s_scm_foreign_ref
{
- SCM_VALIDATE_FOREIGN_SIMPLE (1, foreign);
+ scm_t_foreign_type ftype;
+ scm_t_uint8 *ptr;
- switch (SCM_FOREIGN_TYPE (foreign))
+ SCM_VALIDATE_FOREIGN (1, foreign);
+ ptr = SCM_FOREIGN_POINTER (foreign, scm_t_uint8);
+
+ ftype = SCM_FOREIGN_TYPE (foreign);
+ if (ftype == SCM_FOREIGN_TYPE_VOID)
+ {
+ if (SCM_UNBNDP (type))
+ scm_error_num_args_subr (FUNC_NAME);
+ ftype = scm_to_unsigned_integer (type, 0, SCM_FOREIGN_TYPE_LAST);
+ if (!SCM_UNBNDP (offset))
+ ptr += scm_to_ssize_t (offset);
+ }
+ else
+ {
+ if (!SCM_UNBNDP (type))
+ scm_error_num_args_subr (FUNC_NAME);
+ }
+
+ /* FIXME: is there a window in which we can see ptr but not foreign? */
+ switch (ftype)
{
case SCM_FOREIGN_TYPE_FLOAT:
- return scm_from_double (SCM_FOREIGN_OBJECT_REF (foreign, float));
+ return scm_from_double (*(float*)ptr);
case SCM_FOREIGN_TYPE_DOUBLE:
- return scm_from_double (SCM_FOREIGN_OBJECT_REF (foreign, double));
+ return scm_from_double (*(double*)ptr);
case SCM_FOREIGN_TYPE_UINT8:
- return scm_from_uint8 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint8));
+ return scm_from_uint8 (*(scm_t_uint8*)ptr);
case SCM_FOREIGN_TYPE_INT8:
- return scm_from_int8 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int8));
+ return scm_from_int8 (*(scm_t_int8*)ptr);
case SCM_FOREIGN_TYPE_UINT16:
- return scm_from_uint16 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint16));
+ return scm_from_uint16 (*(scm_t_uint16*)ptr);
case SCM_FOREIGN_TYPE_INT16:
- return scm_from_int16 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int16));
+ return scm_from_int16 (*(scm_t_int16*)ptr);
case SCM_FOREIGN_TYPE_UINT32:
- return scm_from_uint32 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint32));
+ return scm_from_uint32 (*(scm_t_uint32*)ptr);
case SCM_FOREIGN_TYPE_INT32:
- return scm_from_int32 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int32));
+ return scm_from_int32 (*(scm_t_int32*)ptr);
case SCM_FOREIGN_TYPE_UINT64:
- return scm_from_uint64 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint64));
+ return scm_from_uint64 (*(scm_t_uint64*)ptr);
case SCM_FOREIGN_TYPE_INT64:
- return scm_from_int64 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int64));
+ return scm_from_int64 (*(scm_t_int64*)ptr);
case SCM_FOREIGN_TYPE_VOID:
- case SCM_FOREIGN_TYPE_STRUCT:
- case SCM_FOREIGN_TYPE_POINTER:
+ /* seems we're making a new pointer, woo */
+ {
+ GC_finalization_proc prev_finalizer;
+ GC_PTR prev_finalizer_data;
+ SCM ret = scm_take_foreign_pointer
+ (ftype, ptr, SCM_UNBNDP (len) ? 0 : scm_to_size_t (len), NULL);
+ /* while the kid is alive, keep the parent alive */
+ if (SCM_FOREIGN_HAS_FINALIZER (foreign))
+ GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret), keepalive, foreign,
+ &prev_finalizer, &prev_finalizer_data);
+ return ret;
+ }
default:
- /* other cases should have been caught by the FOREIGN_SIMPLE check */
abort ();
}
}
#undef FUNC_NAME
-SCM_DEFINE (scm_foreign_set_x, "foreign-set!", 2, 0, 0,
- (SCM foreign, SCM val),
+SCM_DEFINE (scm_foreign_set_x, "foreign-set!", 2, 2, 0,
+ (SCM foreign, SCM val, SCM type, SCM offset),
"Set the foreign value wrapped by @var{foreign}.\n\n"
- "Note that only \"simple\" types may be set by this function.\n"
- "See @code{foreign-struct-ref} or @code{foreign-pointer-ref} for\n"
- "structs or pointers, respectively.")
+ "The value will be set according to its type.\n"
+ "If and only if the type of the foreign value is @code{void},\n"
+ "this function accepts optional @var{type} and @var{offset}\n"
+ "arguments, indicating that the pointer wrapped by\n"
+ "@var{foreign} should be incremented by @var{offset} bytes,\n"
+ "and treated as a pointer to a value of the given @var{type}.\n"
+ "@var{offset} defaults to 0.")
#define FUNC_NAME s_scm_foreign_set_x
{
- SCM_VALIDATE_FOREIGN_SIMPLE (1, foreign);
+ scm_t_foreign_type ftype;
+ scm_t_uint8 *ptr;
- switch (SCM_FOREIGN_TYPE (foreign))
+ SCM_VALIDATE_FOREIGN (1, foreign);
+ ptr = SCM_FOREIGN_POINTER (foreign, scm_t_uint8);
+
+ ftype = SCM_FOREIGN_TYPE (foreign);
+ if (ftype == SCM_FOREIGN_TYPE_VOID)
+ {
+ if (SCM_UNBNDP (type))
+ scm_error_num_args_subr (FUNC_NAME);
+ ftype = scm_to_unsigned_integer (type, 0, SCM_FOREIGN_TYPE_LAST);
+ if (!SCM_UNBNDP (offset))
+ ptr += scm_to_ssize_t (offset);
+ }
+ else
+ {
+ if (!SCM_UNBNDP (type))
+ scm_error_num_args_subr (FUNC_NAME);
+ }
+
+ /* FIXME: is there a window in which we can see ptr but not foreign? */
+ switch (ftype)
{
case SCM_FOREIGN_TYPE_FLOAT:
- SCM_FOREIGN_OBJECT_SET (foreign, float, scm_to_double (val));
+ *(float*)ptr = scm_to_double (val);
break;
case SCM_FOREIGN_TYPE_DOUBLE:
- SCM_FOREIGN_OBJECT_SET (foreign, double, scm_to_double (val));
+ *(double*)ptr = scm_to_double (val);
break;
case SCM_FOREIGN_TYPE_UINT8:
- SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint8, scm_to_uint8 (val));
+ *(scm_t_uint8*)ptr = scm_to_uint8 (val);
break;
case SCM_FOREIGN_TYPE_INT8:
- SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int8, scm_to_int8 (val));
+ *(scm_t_int8*)ptr = scm_to_int8 (val);
break;
case SCM_FOREIGN_TYPE_UINT16:
- SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint16, scm_to_uint16 (val));
+ *(scm_t_uint16*)ptr = scm_to_uint16 (val);
break;
case SCM_FOREIGN_TYPE_INT16:
- SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int16, scm_to_int16 (val));
+ *(scm_t_int16*)ptr = scm_to_int16 (val);
break;
case SCM_FOREIGN_TYPE_UINT32:
- SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint32, scm_to_uint32 (val));
+ *(scm_t_uint32*)ptr = scm_to_uint32 (val);
break;
case SCM_FOREIGN_TYPE_INT32:
- SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int32, scm_to_int32 (val));
+ *(scm_t_int32*)ptr = scm_to_int32 (val);
break;
case SCM_FOREIGN_TYPE_UINT64:
- SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint64, scm_to_uint64 (val));
+ *(scm_t_uint64*)ptr = scm_to_uint64 (val);
break;
case SCM_FOREIGN_TYPE_INT64:
- SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int64, scm_to_int64 (val));
+ *(scm_t_int64*)ptr = scm_to_int64 (val);
break;
case SCM_FOREIGN_TYPE_VOID:
- case SCM_FOREIGN_TYPE_STRUCT:
- case SCM_FOREIGN_TYPE_POINTER:
+ SCM_VALIDATE_FOREIGN (2, val);
+ if (SCM_FOREIGN_HAS_FINALIZER (val))
+ /* setting a pointer inside one foreign value to the pointer of another?
+ that is asking for trouble */
+ scm_wrong_type_arg_msg (FUNC_NAME, 2, val,
+ "foreign value without finalizer");
+ *(void**)ptr = SCM_FOREIGN_POINTER (val, void*);
+ break;
default:
- /* other cases should have been caught by the FOREIGN_SIMPLE check */
abort ();
}
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -216,55 +236,69 @@ scm_i_foreign_print (SCM foreign, SCM port, scm_print_state *pstate)
scm_puts ("#<foreign ", port);
switch (SCM_FOREIGN_TYPE (foreign))
{
- case SCM_FOREIGN_TYPE_VOID:
- abort ();
case SCM_FOREIGN_TYPE_FLOAT:
scm_puts ("float ", port);
- scm_display (scm_foreign_ref (foreign), port);
+ scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
+ SCM_UNDEFINED),
+ port);
break;
case SCM_FOREIGN_TYPE_DOUBLE:
scm_puts ("double ", port);
- scm_display (scm_foreign_ref (foreign), port);
+ scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
+ SCM_UNDEFINED),
+ port);
break;
case SCM_FOREIGN_TYPE_UINT8:
scm_puts ("uint8 ", port);
- scm_display (scm_foreign_ref (foreign), port);
+ scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
+ SCM_UNDEFINED),
+ port);
break;
case SCM_FOREIGN_TYPE_INT8:
scm_puts ("int8 ", port);
- scm_display (scm_foreign_ref (foreign), port);
+ scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
+ SCM_UNDEFINED),
+ port);
break;
case SCM_FOREIGN_TYPE_UINT16:
scm_puts ("uint16 ", port);
- scm_display (scm_foreign_ref (foreign), port);
+ scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
+ SCM_UNDEFINED),
+ port);
break;
case SCM_FOREIGN_TYPE_INT16:
scm_puts ("int16 ", port);
- scm_display (scm_foreign_ref (foreign), port);
+ scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
+ SCM_UNDEFINED),
+ port);
break;
case SCM_FOREIGN_TYPE_UINT32:
scm_puts ("uint32 ", port);
- scm_display (scm_foreign_ref (foreign), port);
+ scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
+ SCM_UNDEFINED),
+ port);
break;
case SCM_FOREIGN_TYPE_INT32:
scm_puts ("int32 ", port);
- scm_display (scm_foreign_ref (foreign), port);
+ scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
+ SCM_UNDEFINED),
+ port);
break;
case SCM_FOREIGN_TYPE_UINT64:
scm_puts ("uint64 ", port);
- scm_display (scm_foreign_ref (foreign), port);
+ scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
+ SCM_UNDEFINED),
+ port);
break;
case SCM_FOREIGN_TYPE_INT64:
scm_puts ("int64 ", port);
- scm_display (scm_foreign_ref (foreign), port);
+ scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
+ SCM_UNDEFINED),
+ port);
break;
- case SCM_FOREIGN_TYPE_STRUCT:
- scm_puts ("struct at 0x", port);
- scm_uintprint (SCM_CELL_WORD_1 (foreign), 16, port);
- break;
- case SCM_FOREIGN_TYPE_POINTER:
+ case SCM_FOREIGN_TYPE_VOID:
scm_puts ("pointer 0x", port);
- scm_uintprint (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_bits), 16, port);
+ scm_uintprint ((scm_t_bits)SCM_FOREIGN_POINTER (foreign, void), 16, port);
break;
default:
abort ();