summaryrefslogtreecommitdiff
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
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.
-rw-r--r--libguile/dynl.c61
-rw-r--r--libguile/dynl.h3
-rw-r--r--libguile/foreign.c268
-rw-r--r--libguile/foreign.h64
-rw-r--r--libguile/goops.c10
-rw-r--r--libguile/gsubr.c8
-rw-r--r--libguile/gsubr.h4
-rw-r--r--libguile/snarf.h10
-rw-r--r--libguile/vm-i-system.c2
9 files changed, 253 insertions, 177 deletions
diff --git a/libguile/dynl.c b/libguile/dynl.c
index a55ba86ea..0175c336a 100644
--- a/libguile/dynl.c
+++ b/libguile/dynl.c
@@ -100,7 +100,7 @@ sysdep_dynl_unlink (void *handle, const char *subr)
}
static void *
-sysdep_dynl_func (const char *symb, void *handle, const char *subr)
+sysdep_dynl_value (const char *symb, void *handle, const char *subr)
{
void *fptr;
@@ -214,23 +214,31 @@ SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0,
#undef FUNC_NAME
-SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
- (SCM name, SCM dobj),
- "Return a ``handle'' for the function @var{name} in the\n"
+SCM_DEFINE (scm_dynamic_pointer, "dynamic-pointer", 3, 1, 0,
+ (SCM name, SCM type, SCM dobj, SCM len),
+ "Return a ``handle'' for the pointer @var{name} in the\n"
"shared object referred to by @var{dobj}. The handle\n"
- "can be passed to @code{dynamic-call} to actually\n"
- "call the function.\n\n"
+ "aliases a C value, and is declared to be of type\n"
+ "@var{type}. Valid types are defined in the\n"
+ "@code{(system vm ffi)} module.\n\n"
+ "This facility works by asking the operating system for\n"
+ "the address of a symbol, then assuming that it aliases a\n"
+ "value of a given type. Obviously, the user must be very\n"
+ "careful to ensure that the value actually is of the\n"
+ "declared type, or bad things will happen.\n\n"
"Regardless whether your C compiler prepends an underscore\n"
"@samp{_} to the global names in a program, you should\n"
"@strong{not} include this underscore in @var{name}\n"
"since it will be added automatically when necessary.")
-#define FUNC_NAME s_scm_dynamic_func
+#define FUNC_NAME s_scm_dynamic_pointer
{
- void (*func) ();
+ void *val;
+ scm_t_foreign_type t;
SCM_VALIDATE_STRING (1, name);
+ t = scm_to_unsigned_integer (type, 0, SCM_FOREIGN_TYPE_LAST);
/*fixme* GC-problem */
- SCM_VALIDATE_SMOB (SCM_ARG2, dobj, dynamic_obj);
+ SCM_VALIDATE_SMOB (SCM_ARG3, dobj, dynamic_obj);
if (DYNL_HANDLE (dobj) == NULL) {
SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
} else {
@@ -239,15 +247,36 @@ SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
scm_dynwind_begin (0);
chars = scm_to_locale_string (name);
scm_dynwind_free (chars);
- func = (void (*) ()) sysdep_dynl_func (chars, DYNL_HANDLE (dobj),
- FUNC_NAME);
+ val = sysdep_dynl_value (chars, DYNL_HANDLE (dobj), FUNC_NAME);
scm_dynwind_end ();
- return scm_c_from_foreign (SCM_FOREIGN_TYPE_POINTER, &func, 0, NULL);
+ return scm_take_foreign_pointer (t, val,
+ SCM_UNBNDP (len) ? 0 : scm_to_size_t (len),
+ NULL);
}
}
#undef FUNC_NAME
+SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
+ (SCM name, SCM dobj),
+ "Return a ``handle'' for the function @var{name} in the\n"
+ "shared object referred to by @var{dobj}. The handle\n"
+ "can be passed to @code{dynamic-call} to actually\n"
+ "call the function.\n\n"
+ "Regardless whether your C compiler prepends an underscore\n"
+ "@samp{_} to the global names in a program, you should\n"
+ "@strong{not} include this underscore in @var{name}\n"
+ "since it will be added automatically when necessary.")
+#define FUNC_NAME s_scm_dynamic_func
+{
+ return scm_dynamic_pointer (name,
+ scm_from_uint (SCM_FOREIGN_TYPE_VOID),
+ dobj,
+ SCM_UNDEFINED);
+}
+#undef FUNC_NAME
+
+
SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0,
(SCM func, SCM dobj),
"Call a C function in a dynamic object. Two styles of\n"
@@ -272,9 +301,9 @@ SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0,
if (scm_is_string (func))
func = scm_dynamic_func (func, dobj);
- SCM_VALIDATE_FOREIGN_TYPED (SCM_ARG1, func, POINTER);
+ SCM_VALIDATE_FOREIGN_TYPED (SCM_ARG1, func, VOID);
- fptr = SCM_FOREIGN_OBJECT_REF (func, void*);
+ fptr = SCM_FOREIGN_POINTER (func, void);
fptr ();
return SCM_UNSPECIFIED;
}
@@ -302,9 +331,9 @@ SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0,
if (scm_is_string (func))
func = scm_dynamic_func (func, dobj);
- SCM_VALIDATE_FOREIGN_TYPED (SCM_ARG1, func, POINTER);
+ SCM_VALIDATE_FOREIGN_TYPED (SCM_ARG1, func, VOID);
- fptr = SCM_FOREIGN_OBJECT_REF (func, void*);
+ fptr = SCM_FOREIGN_POINTER (func, void);
argv = scm_i_allocate_string_pointers (args);
for (argc = 0; argv[argc]; argc++)
diff --git a/libguile/dynl.h b/libguile/dynl.h
index eb318ae98..2b34c2e49 100644
--- a/libguile/dynl.h
+++ b/libguile/dynl.h
@@ -3,7 +3,7 @@
#ifndef SCM_DYNL_H
#define SCM_DYNL_H
-/* Copyright (C) 1996,1998,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1998,2000,2001, 2006, 2008, 2010 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
@@ -30,6 +30,7 @@
SCM_API SCM scm_dynamic_link (SCM fname);
SCM_API SCM scm_dynamic_unlink (SCM dobj);
SCM_API SCM scm_dynamic_object_p (SCM obj);
+SCM_API SCM scm_dynamic_pointer (SCM name, SCM type, SCM dobj, SCM len);
SCM_API SCM scm_dynamic_func (SCM symb, SCM dobj);
SCM_API SCM scm_dynamic_call (SCM symb, SCM dobj);
SCM_API SCM scm_dynamic_args_call (SCM symb, SCM dobj, SCM args);
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 ();
diff --git a/libguile/foreign.h b/libguile/foreign.h
index 954c1c5b3..d48027799 100644
--- a/libguile/foreign.h
+++ b/libguile/foreign.h
@@ -21,10 +21,24 @@
-/* A subset of libffi's types. */
+/* A foreign value is some value that exists outside of Guile. It is represented
+ by a cell whose second word is a pointer. The first word has the
+ scm_tc7_foreign typecode and type of the aliased (pointed-to) value in its
+ lower 16 bits.
+
+ There are numeric types, like uint32 and float, and there is a "generic
+ pointer" type, void. Void pointers also have a length associated with them,
+ in the high bits of the first word of the SCM object, but since they really
+ are pointers out into the wild wooly world of C, perhaps we don't actually
+ know how much memory they take up. In that, most general case, the "len"
+ will be stored as 0.
+
+ The basic idea is that we can help the programmer to avoid cutting herself,
+ but we won't take away her knives.
+*/
typedef enum
{
- SCM_FOREIGN_TYPE_VOID,
+ SCM_FOREIGN_TYPE_VOID, /* a pointer out into the wilderness */
SCM_FOREIGN_TYPE_FLOAT,
SCM_FOREIGN_TYPE_DOUBLE,
SCM_FOREIGN_TYPE_UINT8,
@@ -35,8 +49,7 @@ typedef enum
SCM_FOREIGN_TYPE_INT32,
SCM_FOREIGN_TYPE_UINT64,
SCM_FOREIGN_TYPE_INT64,
- SCM_FOREIGN_TYPE_STRUCT,
- SCM_FOREIGN_TYPE_POINTER
+ SCM_FOREIGN_TYPE_LAST = SCM_FOREIGN_TYPE_INT64
} scm_t_foreign_type;
@@ -48,12 +61,16 @@ typedef void (*scm_t_foreign_finalizer) (void *);
SCM_MAKE_VALIDATE (pos, x, FOREIGN_P)
#define SCM_FOREIGN_TYPE(x) \
((scm_t_foreign_type)((SCM_CELL_WORD_0 (x) >> 8)&0xff))
-#define SCM_FOREIGN_OBJECT(x, ctype) \
- ((ctype*)SCM_CELL_OBJECT_1 (x))
-#define SCM_FOREIGN_OBJECT_REF(x, ctype) \
- (*SCM_FOREIGN_OBJECT (x, ctype))
-#define SCM_FOREIGN_OBJECT_SET(x, ctype, val) \
- (*SCM_FOREIGN_OBJECT (x, ctype) = (val))
+#define SCM_FOREIGN_POINTER(x, ctype) \
+ ((ctype*)SCM_CELL_WORD_1 (x))
+#define SCM_FOREIGN_VALUE_REF(x, ctype) \
+ (*SCM_FOREIGN_POINTER (x, ctype))
+#define SCM_FOREIGN_VALUE_SET(x, ctype, val) \
+ (*SCM_FOREIGN_POINTER (x, ctype) = (val))
+#define SCM_FOREIGN_HAS_FINALIZER(x) \
+ ((SCM_CELL_WORD_0 (x) >> 16) & 0x1)
+#define SCM_FOREIGN_LEN(x) \
+ ((size_t)(SCM_CELL_WORD_0 (x) >> 17))
#define SCM_FOREIGN_TYPED_P(x, type) \
(SCM_FOREIGN_P (x) && SCM_FOREIGN_TYPE (x) == SCM_FOREIGN_TYPE_##type)
@@ -63,21 +80,18 @@ typedef void (*scm_t_foreign_finalizer) (void *);
"FOREIGN_"#type"_P"); \
} while (0)
-#define SCM_FOREIGN_SIMPLE_P(x) \
- (SCM_FOREIGN_P (x) \
- && SCM_FOREIGN_TYPE (x) != SCM_FOREIGN_TYPE_VOID \
- && SCM_FOREIGN_TYPE (x) != SCM_FOREIGN_TYPE_STRUCT \
- && SCM_FOREIGN_TYPE (x) != SCM_FOREIGN_TYPE_POINTER)
-#define SCM_VALIDATE_FOREIGN_SIMPLE(pos, x) \
- SCM_MAKE_VALIDATE (pos, x, FOREIGN_SIMPLE_P)
-
-SCM_API SCM scm_c_from_foreign (scm_t_foreign_type type, void *val, size_t size,
- scm_t_foreign_finalizer finalizer);
-SCM_API SCM scm_c_take_foreign (scm_t_foreign_type type, void *val,
- scm_t_foreign_finalizer finalizer);
-
-SCM_API SCM scm_foreign_ref (SCM foreign);
-SCM_API SCM scm_foreign_set_x (SCM foreign, SCM val);
+#define SCM_FOREIGN_VALUE_P(x) \
+ (SCM_FOREIGN_P (x) && SCM_FOREIGN_TYPE (x) != SCM_FOREIGN_TYPE_VOID)
+#define SCM_VALIDATE_FOREIGN_VALUE(pos, x) \
+ SCM_MAKE_VALIDATE (pos, x, FOREIGN_VALUE_P)
+
+SCM_API SCM scm_take_foreign_pointer (scm_t_foreign_type type, void *ptr,
+ size_t len,
+ scm_t_foreign_finalizer finalizer);
+
+SCM_API SCM scm_foreign_type (SCM foreign);
+SCM_API SCM scm_foreign_ref (SCM foreign, SCM type, SCM offset, SCM len);
+SCM_API SCM scm_foreign_set_x (SCM foreign, SCM val, SCM type, SCM offset);
SCM_INTERNAL void scm_i_foreign_print (SCM foreign, SCM port,
scm_print_state *pstate);
diff --git a/libguile/goops.c b/libguile/goops.c
index 33293fea4..6fc073bdc 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -1725,10 +1725,10 @@ SCM_DEFINE (scm_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1
{
SCM subr = SCM_CAR (subrs);
SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARGn, FUNC_NAME);
- *SCM_SUBR_GENERIC (subr)
- = scm_make (scm_list_3 (scm_class_generic,
- k_name,
- SCM_SUBR_NAME (subr)));
+ SCM_SET_SUBR_GENERIC (subr,
+ scm_make (scm_list_3 (scm_class_generic,
+ k_name,
+ SCM_SUBR_NAME (subr))));
subrs = SCM_CDR (subrs);
}
return SCM_UNSPECIFIED;
@@ -1742,7 +1742,7 @@ SCM_DEFINE (scm_set_primitive_generic_x, "set-primitive-generic!", 2, 0, 0,
{
SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARG1, FUNC_NAME);
SCM_ASSERT (SCM_PUREGENERICP (generic), generic, SCM_ARG2, FUNC_NAME);
- *SCM_SUBR_GENERIC (subr) = generic;
+ SCM_SET_SUBR_GENERIC (subr, generic);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index f0c622290..de4bff69f 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -794,13 +794,13 @@ create_gsubr (int define, const char *name,
sname = scm_from_locale_symbol (name);
table = scm_c_make_vector (generic_loc ? 3 : 2, SCM_UNDEFINED);
SCM_SIMPLE_VECTOR_SET (table, 0,
- scm_c_from_foreign (SCM_FOREIGN_TYPE_POINTER,
- &fcn, 0, NULL));
+ scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID,
+ fcn, 0, NULL));
SCM_SIMPLE_VECTOR_SET (table, 1, sname);
if (generic_loc)
SCM_SIMPLE_VECTOR_SET (table, 2,
- scm_c_from_foreign (SCM_FOREIGN_TYPE_POINTER,
- &generic_loc, 0, NULL));
+ scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID,
+ generic_loc, 0, NULL));
/* make program */
ret = scm_make_program (scm_subr_objcode_trampoline (nreq, nopt, rest),
diff --git a/libguile/gsubr.h b/libguile/gsubr.h
index a4dc5602e..e94d0d0ad 100644
--- a/libguile/gsubr.h
+++ b/libguile/gsubr.h
@@ -43,10 +43,10 @@ SCM_API SCM scm_subr_objcode_trampoline (unsigned int nreq,
#define SCM_PRIMITIVE_P(x) (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE (x))
#define SCM_PRIMITIVE_GENERIC_P(x) (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x))
-#define SCM_SUBRF(x) ((SCM (*)()) (SCM_FOREIGN_OBJECT (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 0), void*)))
+#define SCM_SUBRF(x) ((SCM (*)()) (SCM_FOREIGN_POINTER (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 0), void)))
#define SCM_SUBR_NAME(x) (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 1))
#define SCM_SUBR_GENERIC(x) \
- (SCM_FOREIGN_OBJECT_REF (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 2), SCM*))
+ (SCM_FOREIGN_POINTER (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 2), SCM))
#define SCM_SET_SUBR_GENERIC(x, g) \
(*SCM_SUBR_GENERIC (x) = (g))
diff --git a/libguile/snarf.h b/libguile/snarf.h
index 717c953e8..98f660115 100644
--- a/libguile/snarf.h
+++ b/libguile/snarf.h
@@ -105,10 +105,8 @@ SCM_SYMBOL (scm_i_paste (FNAME, __name), PRIMNAME); \
SCM_SNARF_HERE( \
static const char scm_i_paste (s_, FNAME) [] = PRIMNAME; \
SCM_API SCM FNAME ARGLIST; \
- static const scm_t_bits scm_i_paste (FNAME, __subr_ptr) = \
- (scm_t_bits) &FNAME; /* the subr */ \
SCM_IMMUTABLE_FOREIGN (scm_i_paste (FNAME, __subr_foreign), \
- scm_i_paste (FNAME, __subr_ptr)); \
+ (scm_t_bits) &FNAME); /* the subr */ \
SCM_STATIC_SUBR_OBJVECT (scm_i_paste (FNAME, __raw_objtable), \
/* FIXME: directly be the foreign */ \
SCM_BOOL_F); \
@@ -363,10 +361,10 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));)
(scm_t_bits) 0, \
(scm_t_bits) sizeof (contents) - 1)
-#define SCM_IMMUTABLE_FOREIGN(c_name, loc) \
+#define SCM_IMMUTABLE_FOREIGN(c_name, ptr) \
SCM_IMMUTABLE_CELL (c_name, \
- scm_tc7_foreign | (SCM_FOREIGN_TYPE_POINTER << 8), \
- &loc)
+ scm_tc7_foreign | (SCM_FOREIGN_TYPE_VOID << 8), \
+ ptr)
/* for primitive-generics, add a foreign to the end */
#define SCM_STATIC_SUBR_OBJVECT(c_name, foreign) \
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 8297c5b0e..c9c743792 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -842,7 +842,7 @@ VM_DEFINE_INSTRUCTION (80, subr_call, "subr-call", 1, -1, -1)
nargs = FETCH ();
POP (foreign);
- subr = SCM_FOREIGN_OBJECT_REF (foreign, void*);
+ subr = SCM_FOREIGN_POINTER (foreign, void);
VM_HANDLE_INTERRUPTS;
SYNC_REGISTER ();