mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Simplify the (system foreign) API.

Browse source 
Suggested by Neil Jerram.

* libguile/foreign.h (SCM_FOREIGN_TYPE, SCM_FOREIGN_VALUE_REF,
  SCM_FOREIGN_VALUE_SET, SCM_FOREIGN_LEN, SCM_FOREIGN_TYPED_P,
  SCM_FOREIGN_VALUE_P, SCM_VALIDATE_FOREIGN_VALUE, scm_foreign_set_x,
  scm_foreign_type): Remove.
  (scm_foreign_ref): Rename to...
  (scm_foreign_address): ... this.
  (scm_take_foreign_pointer): Update.
  (SCM_FOREIGN_POINTER): Remove CTYPE argument.  Update callers.
  (scm_make_pointer): New declaration.

* libguile/foreign.c (scm_to_uintptr, scm_from_uintptr): New macros.
  (scm_make_pointer): New function.
  (scm_take_foreign_pointer): Remove TYPE and LEN arguments.  Update
  callers.
  (scm_foreign_ref): Remove to...
  (scm_foreign_address): ... this.  Remove type-related code.
  (scm_foreign_set_x): Remove.
  (scm_foreign_to_bytevector): Change argument order; make LEN argument
  compulsory.
  (scm_i_foreign_print): Remove type printing.
  (unpack): Remove foreign-type checking.

* libguile/deprecated.c (scm_dynamic_args_call): Update accordingly.

* libguile/dynl.c (scm_dynamic_pointer): Remove the TYPE and LEN
  arguments; update callers.  Update to the new foreign API.

* libguile/dynl.h (scm_dynamic_pointer): Update.

* libguile/gsubr.c (create_gsubr): Update to the new foreign API.

* libguile/gsubr.h (SCM_SUBRF, SCM_SUBR_GENERIC): Ditto.

* libguile/snarf.h (SCM_IMMUTABLE_FOREIGN): Ditto.

* libguile/vm-i-system.c (subr_call): Ditto.

* module/system/foreign.scm (null-pointer?): New procedure.

* test-suite/standalone/test-ffi: Update to the new
  `bytevector->foreign' signature.

* test-suite/tests/foreign.test ("null pointer")["null pointer
  identity", "null-pointer? %null-pointer"]: New tests.
  ["foreign-set! other-null-pointer", "foreign->bytevector
  other-null-pointer"]: Remove.
  ("make-pointer", "foreign<->bytevector"): New test prefixes.
This commit is contained in:
Ludovic Courtès 2010-07-26 17:44:43 +02:00
parent 1af772303b
commit d4149a510e
12 changed files with 176 additions and 307 deletions
Download patch file Download diff file Expand all files Collapse all files

4
libguile/deprecated.c
View file

@ -1900,9 +1900,9 @@ SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0,
if (scm_is_string (func)) if (scm_is_string (func))
func = scm_dynamic_func (func, dobj); func = scm_dynamic_func (func, dobj);
SCM_VALIDATE_FOREIGN_TYPED (SCM_ARG1, func, VOID); SCM_VALIDATE_FOREIGN (SCM_ARG1, func);
fptr = SCM_FOREIGN_POINTER (func, void); fptr = SCM_FOREIGN_POINTER (func);
argv = scm_i_allocate_string_pointers (args); argv = scm_i_allocate_string_pointers (args);
for (argc = 0; argv[argc]; argc++) for (argc = 0; argv[argc]; argc++)

25
libguile/dynl.c
View file

@ -235,13 +235,11 @@ SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0,
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE (scm_dynamic_pointer, "dynamic-pointer", 3, 1, 0, SCM_DEFINE (scm_dynamic_pointer, "dynamic-pointer", 2, 0, 0,
(SCM name, SCM type, SCM dobj, SCM len), (SCM name, SCM dobj),
"Return a ``handle'' for the pointer @var{name} in the\n" "Return a ``handle'' for the pointer @var{name} in the\n"
"shared object referred to by @var{dobj}. The handle\n" "shared object referred to by @var{dobj}. The handle\n"
"aliases a C value, and is declared to be of type\n" "aliases a C object.\n\n"
"@var{type}. Valid types are defined in the\n"
"@code{(system foreign)} module.\n\n"
"This facility works by asking the dynamic linker for\n" "This facility works by asking the dynamic linker for\n"
"the address of a symbol, then assuming that it aliases a\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" "value of a given type. Obviously, the user must be very\n"
@ -254,11 +252,9 @@ SCM_DEFINE (scm_dynamic_pointer, "dynamic-pointer", 3, 1, 0,
#define FUNC_NAME s_scm_dynamic_pointer #define FUNC_NAME s_scm_dynamic_pointer
{ {
void *val; void *val;
scm_t_foreign_type t;
SCM_VALIDATE_STRING (1, name); SCM_VALIDATE_STRING (1, name);
t = scm_to_unsigned_integer (type, 0, SCM_FOREIGN_TYPE_LAST); SCM_VALIDATE_SMOB (SCM_ARG2, dobj, dynamic_obj);
SCM_VALIDATE_SMOB (SCM_ARG3, dobj, dynamic_obj);
if (DYNL_HANDLE (dobj) == NULL) if (DYNL_HANDLE (dobj) == NULL)
SCM_MISC_ERROR ("Already unlinked: ~S", dobj); SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
@ -272,9 +268,7 @@ SCM_DEFINE (scm_dynamic_pointer, "dynamic-pointer", 3, 1, 0,
val = sysdep_dynl_value (chars, DYNL_HANDLE (dobj), FUNC_NAME); val = sysdep_dynl_value (chars, DYNL_HANDLE (dobj), FUNC_NAME);
scm_dynwind_end (); scm_dynwind_end ();
return scm_take_foreign_pointer (t, val, return scm_take_foreign_pointer (val, NULL);
SCM_UNBNDP (len) ? 0 : scm_to_size_t (len),
NULL);
} }
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -292,10 +286,7 @@ SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
"since it will be added automatically when necessary.") "since it will be added automatically when necessary.")
#define FUNC_NAME s_scm_dynamic_func #define FUNC_NAME s_scm_dynamic_func
{ {
return scm_dynamic_pointer (name, return scm_dynamic_pointer (name, dobj);
scm_from_uint (SCM_FOREIGN_TYPE_VOID),
dobj,
SCM_UNDEFINED);
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -324,9 +315,9 @@ SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0,
if (scm_is_string (func)) if (scm_is_string (func))
func = scm_dynamic_func (func, dobj); func = scm_dynamic_func (func, dobj);
SCM_VALIDATE_FOREIGN_TYPED (SCM_ARG1, func, VOID); SCM_VALIDATE_FOREIGN (SCM_ARG1, func);
fptr = SCM_FOREIGN_POINTER (func, void); fptr = SCM_FOREIGN_POINTER (func);
fptr (); fptr ();
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }

2
libguile/dynl.h
View file

@ -30,7 +30,7 @@
SCM_API SCM scm_dynamic_link (SCM fname); SCM_API SCM scm_dynamic_link (SCM fname);
SCM_API SCM scm_dynamic_unlink (SCM dobj); SCM_API SCM scm_dynamic_unlink (SCM dobj);
SCM_API SCM scm_dynamic_object_p (SCM obj); 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_pointer (SCM name, SCM dobj);
SCM_API SCM scm_dynamic_func (SCM symb, SCM dobj); 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_call (SCM symb, SCM dobj);

283
libguile/foreign.c
View file

@ -59,6 +59,17 @@ SCM_SYMBOL (sym_null_pointer_error, "null-pointer-error");
/* The cell representing the null pointer. */ /* The cell representing the null pointer. */
static SCM null_pointer; static SCM null_pointer;
#if SIZEOF_VOID_P == 4
# define scm_to_uintptr scm_to_uint32
# define scm_from_uintptr scm_from_uint32
#elif SIZEOF_VOID_P == 8
# define scm_to_uintptr scm_to_uint64
# define scm_from_uintptr scm_from_uint64
#else
# error unsupported pointer size
#endif
/* Raise a null pointer dereference error. */ /* Raise a null pointer dereference error. */
static void static void
null_pointer_error (const char *func_name) null_pointer_error (const char *func_name)
@ -78,25 +89,51 @@ register_weak_reference (SCM from, SCM to)
{ {
scm_hashq_set_x (foreign_weak_refs, from, to); scm_hashq_set_x (foreign_weak_refs, from, to);
} }
static void static void
foreign_finalizer_trampoline (GC_PTR ptr, GC_PTR data) foreign_finalizer_trampoline (GC_PTR ptr, GC_PTR data)
{ {
scm_t_foreign_finalizer finalizer = data; scm_t_foreign_finalizer finalizer = data;
finalizer (SCM_FOREIGN_POINTER (PTR2SCM (ptr), void)); finalizer (SCM_FOREIGN_POINTER (PTR2SCM (ptr)));
} }
SCM_DEFINE (scm_make_pointer, "make-pointer", 1, 1, 0,
(SCM address, SCM finalizer),
"Return a foreign pointer object pointing to @var{address}. "
"If @var{finalizer} is passed, it should be a pointer to a "
"one-argument C function that will be called when the pointer "
"object becomes unreachable.")
#define FUNC_NAME s_scm_make_pointer
{
void *c_finalizer;
scm_t_uintptr c_address;
SCM result;
c_address = scm_to_uintptr (address);
if (SCM_UNBNDP (finalizer))
c_finalizer = NULL;
else
{
SCM_VALIDATE_FOREIGN (2, finalizer);
c_finalizer = SCM_FOREIGN_POINTER (finalizer);
}
if (c_address == 0 && c_finalizer == NULL)
result = null_pointer;
else
result = scm_take_foreign_pointer ((void *) c_address, c_finalizer);
return result;
}
#undef FUNC_NAME
SCM SCM
scm_take_foreign_pointer (scm_t_foreign_type type, void *ptr, size_t len, scm_take_foreign_pointer (void *ptr, scm_t_foreign_finalizer finalizer)
scm_t_foreign_finalizer finalizer)
{ {
SCM ret; SCM ret;
scm_t_bits word0; scm_t_bits word0;
word0 = (scm_t_bits)(scm_tc7_foreign | (type<<8) word0 = scm_tc7_foreign | (finalizer ? (1 << 16UL) : 0UL);
| (finalizer ? (1<<16) : 0) | (len<<17));
if (SCM_UNLIKELY ((word0 >> 17) != len))
scm_out_of_range ("scm_take_foreign_pointer", scm_from_size_t (len));
ret = scm_cell (word0, (scm_t_bits) ptr); ret = scm_cell (word0, (scm_t_bits) ptr);
if (finalizer) if (finalizer)
@ -114,117 +151,19 @@ scm_take_foreign_pointer (scm_t_foreign_type type, void *ptr, size_t len,
return ret; return ret;
} }
SCM_DEFINE (scm_foreign_ref, "foreign-ref", 1, 0, 0, SCM_DEFINE (scm_foreign_address, "foreign-address", 1, 0, 0,
(SCM foreign), (SCM foreign),
"Reference the foreign value pointed to by @var{foreign}.\n\n" "Return the numerical value of @var{foreign}.")
"The value will be referenced according to its type.") #define FUNC_NAME s_scm_foreign_address
#define FUNC_NAME s_scm_foreign_ref
{ {
scm_t_foreign_type ftype;
scm_t_uint8 *ptr;
SCM_VALIDATE_FOREIGN (1, foreign); SCM_VALIDATE_FOREIGN (1, foreign);
ptr = SCM_FOREIGN_POINTER (foreign, scm_t_uint8);
ftype = SCM_FOREIGN_TYPE (foreign); return scm_from_uintptr ((scm_t_uintptr) SCM_FOREIGN_POINTER (foreign));
/* FIXME: is there a window in which we can see ptr but not foreign? */
/* FIXME: accessing unaligned pointers */
switch (ftype)
{
case SCM_FOREIGN_TYPE_VOID:
return scm_from_ulong ((unsigned long)ptr);
case SCM_FOREIGN_TYPE_FLOAT:
return scm_from_double (*(float*)ptr);
case SCM_FOREIGN_TYPE_DOUBLE:
return scm_from_double (*(double*)ptr);
case SCM_FOREIGN_TYPE_UINT8:
return scm_from_uint8 (*(scm_t_uint8*)ptr);
case SCM_FOREIGN_TYPE_INT8:
return scm_from_int8 (*(scm_t_int8*)ptr);
case SCM_FOREIGN_TYPE_UINT16:
return scm_from_uint16 (*(scm_t_uint16*)ptr);
case SCM_FOREIGN_TYPE_INT16:
return scm_from_int16 (*(scm_t_int16*)ptr);
case SCM_FOREIGN_TYPE_UINT32:
return scm_from_uint32 (*(scm_t_uint32*)ptr);
case SCM_FOREIGN_TYPE_INT32:
return scm_from_int32 (*(scm_t_int32*)ptr);
case SCM_FOREIGN_TYPE_UINT64:
return scm_from_uint64 (*(scm_t_uint64*)ptr);
case SCM_FOREIGN_TYPE_INT64:
return scm_from_int64 (*(scm_t_int64*)ptr);
default:
scm_wrong_type_arg_msg (FUNC_NAME, 1, foreign, "foreign");
}
} }
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE (scm_foreign_set_x, "foreign-set!", 2, 0, 0, SCM_DEFINE (scm_foreign_to_bytevector, "foreign->bytevector", 2, 2, 0,
(SCM foreign, SCM val), (SCM foreign, SCM len, SCM offset, SCM uvec_type),
"Set the foreign value pointed to by @var{foreign}.\n\n"
"The value will be set according to its type.")
#define FUNC_NAME s_scm_foreign_set_x
{
scm_t_foreign_type ftype;
scm_t_uint8 *ptr;
SCM_VALIDATE_FOREIGN (1, foreign);
if (SCM_UNLIKELY (scm_is_eq (foreign, null_pointer)))
/* Attempting to modify the pointer value of NULL_POINTER (which is
read-only anyway), so raise an error. */
null_pointer_error (FUNC_NAME);
ptr = SCM_FOREIGN_POINTER (foreign, scm_t_uint8);
ftype = SCM_FOREIGN_TYPE (foreign);
/* FIXME: is there a window in which we can see ptr but not foreign? */
/* FIXME: unaligned access */
switch (ftype)
{
case SCM_FOREIGN_TYPE_VOID:
SCM_SET_CELL_WORD_1 (foreign, scm_to_ulong (val));
break;
case SCM_FOREIGN_TYPE_FLOAT:
*(float*)ptr = scm_to_double (val);
break;
case SCM_FOREIGN_TYPE_DOUBLE:
*(double*)ptr = scm_to_double (val);
break;
case SCM_FOREIGN_TYPE_UINT8:
*(scm_t_uint8*)ptr = scm_to_uint8 (val);
break;
case SCM_FOREIGN_TYPE_INT8:
*(scm_t_int8*)ptr = scm_to_int8 (val);
break;
case SCM_FOREIGN_TYPE_UINT16:
*(scm_t_uint16*)ptr = scm_to_uint16 (val);
break;
case SCM_FOREIGN_TYPE_INT16:
*(scm_t_int16*)ptr = scm_to_int16 (val);
break;
case SCM_FOREIGN_TYPE_UINT32:
*(scm_t_uint32*)ptr = scm_to_uint32 (val);
break;
case SCM_FOREIGN_TYPE_INT32:
*(scm_t_int32*)ptr = scm_to_int32 (val);
break;
case SCM_FOREIGN_TYPE_UINT64:
*(scm_t_uint64*)ptr = scm_to_uint64 (val);
break;
case SCM_FOREIGN_TYPE_INT64:
*(scm_t_int64*)ptr = scm_to_int64 (val);
break;
default:
scm_wrong_type_arg_msg (FUNC_NAME, 1, val, "foreign");
}
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_foreign_to_bytevector, "foreign->bytevector", 1, 3, 0,
(SCM foreign, SCM uvec_type, SCM offset, SCM len),
"Return a bytevector aliasing the memory pointed to by\n" "Return a bytevector aliasing the memory pointed to by\n"
"@var{foreign}.\n\n" "@var{foreign}.\n\n"
"@var{foreign} must be a void pointer, a foreign whose type is\n" "@var{foreign} must be a void pointer, a foreign whose type is\n"
@ -247,8 +186,8 @@ SCM_DEFINE (scm_foreign_to_bytevector, "foreign->bytevector", 1, 3, 0,
size_t boffset, blen; size_t boffset, blen;
scm_t_array_element_type btype; scm_t_array_element_type btype;
SCM_VALIDATE_FOREIGN_TYPED (1, foreign, VOID); SCM_VALIDATE_FOREIGN (1, foreign);
ptr = SCM_FOREIGN_POINTER (foreign, scm_t_int8); ptr = SCM_FOREIGN_POINTER (foreign);
if (SCM_UNLIKELY (ptr == NULL)) if (SCM_UNLIKELY (ptr == NULL))
null_pointer_error (FUNC_NAME); null_pointer_error (FUNC_NAME);
@ -283,32 +222,13 @@ SCM_DEFINE (scm_foreign_to_bytevector, "foreign->bytevector", 1, 3, 0,
"uniform vector type"); "uniform vector type");
} }
} }
if (SCM_UNBNDP (offset)) if (SCM_UNBNDP (offset))
boffset = 0; boffset = 0;
else if (SCM_FOREIGN_LEN (foreign))
boffset = scm_to_unsigned_integer (offset, 0,
SCM_FOREIGN_LEN (foreign) - 1);
else else
boffset = scm_to_size_t (offset); boffset = scm_to_size_t (offset);
if (SCM_UNBNDP (len)) blen = scm_to_size_t (len);
{
if (SCM_FOREIGN_LEN (foreign))
blen = SCM_FOREIGN_LEN (foreign) - boffset;
else
scm_misc_error (FUNC_NAME,
"length needed to convert foreign pointer to bytevector",
SCM_EOL);
}
else
{
if (SCM_FOREIGN_LEN (foreign))
blen = scm_to_unsigned_integer (len, 0,
SCM_FOREIGN_LEN (foreign) - boffset);
else
blen = scm_to_size_t (len);
}
ret = scm_c_take_typed_bytevector (ptr + boffset, blen, btype); ret = scm_c_take_typed_bytevector (ptr + boffset, blen, btype);
register_weak_reference (ret, foreign); register_weak_reference (ret, foreign);
@ -347,8 +267,7 @@ SCM_DEFINE (scm_bytevector_to_foreign, "bytevector->foreign", 1, 2, 0,
blen = scm_to_unsigned_integer (len, 0, blen = scm_to_unsigned_integer (len, 0,
SCM_BYTEVECTOR_LENGTH (bv) - boffset); SCM_BYTEVECTOR_LENGTH (bv) - boffset);
ret = scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID, ptr + boffset, blen, ret = scm_take_foreign_pointer (ptr + boffset, NULL);
NULL);
register_weak_reference (ret, bv); register_weak_reference (ret, bv);
return ret; return ret;
} }
@ -366,10 +285,10 @@ SCM_DEFINE (scm_foreign_set_finalizer_x, "foreign-set-finalizer!", 2, 0, 0,
GC_finalization_proc prev_finalizer; GC_finalization_proc prev_finalizer;
GC_PTR prev_finalizer_data; GC_PTR prev_finalizer_data;
SCM_VALIDATE_FOREIGN_TYPED (1, foreign, VOID); SCM_VALIDATE_FOREIGN (1, foreign);
SCM_VALIDATE_FOREIGN_TYPED (2, finalizer, VOID); SCM_VALIDATE_FOREIGN (2, finalizer);
c_finalizer = SCM_FOREIGN_POINTER (finalizer, void); c_finalizer = SCM_FOREIGN_POINTER (finalizer);
SCM_SET_CELL_WORD_0 (foreign, SCM_CELL_WORD_0 (foreign) | (1<<16)); SCM_SET_CELL_WORD_0 (foreign, SCM_CELL_WORD_0 (foreign) | (1<<16));
@ -389,45 +308,7 @@ void
scm_i_foreign_print (SCM foreign, SCM port, scm_print_state *pstate) scm_i_foreign_print (SCM foreign, SCM port, scm_print_state *pstate)
{ {
scm_puts ("#<foreign ", port); scm_puts ("#<foreign ", port);
switch (SCM_FOREIGN_TYPE (foreign)) scm_display (scm_foreign_address (foreign), port);
{
case SCM_FOREIGN_TYPE_FLOAT:
scm_puts ("float ", port);
break;
case SCM_FOREIGN_TYPE_DOUBLE:
scm_puts ("double ", port);
break;
case SCM_FOREIGN_TYPE_UINT8:
scm_puts ("uint8 ", port);
break;
case SCM_FOREIGN_TYPE_INT8:
scm_puts ("int8 ", port);
break;
case SCM_FOREIGN_TYPE_UINT16:
scm_puts ("uint16 ", port);
break;
case SCM_FOREIGN_TYPE_INT16:
scm_puts ("int16 ", port);
break;
case SCM_FOREIGN_TYPE_UINT32:
scm_puts ("uint32 ", port);
break;
case SCM_FOREIGN_TYPE_INT32:
scm_puts ("int32 ", port);
break;
case SCM_FOREIGN_TYPE_UINT64:
scm_puts ("uint64 ", port);
break;
case SCM_FOREIGN_TYPE_INT64:
scm_puts ("int64 ", port);
break;
case SCM_FOREIGN_TYPE_VOID:
scm_puts ("pointer ", port);
break;
default:
scm_wrong_type_arg_msg ("%print-foreign", 1, foreign, "foreign");
}
scm_display (scm_foreign_ref (foreign), port);
scm_putc ('>', port); scm_putc ('>', port);
} }
@ -670,7 +551,8 @@ SCM_DEFINE (scm_make_foreign_function, "make-foreign-function", 3, 0, 0,
ffi_type **type_ptrs; ffi_type **type_ptrs;
ffi_type *types; ffi_type *types;
SCM_VALIDATE_FOREIGN_TYPED (2, func_ptr, VOID); SCM_VALIDATE_FOREIGN (2, func_ptr);
nargs = scm_ilength (arg_types); nargs = scm_ilength (arg_types);
SCM_ASSERT (nargs >= 0, arg_types, 3, FUNC_NAME); SCM_ASSERT (nargs >= 0, arg_types, 3, FUNC_NAME);
/* fixme: assert nargs < 1<<32 */ /* fixme: assert nargs < 1<<32 */
@ -699,8 +581,7 @@ SCM_DEFINE (scm_make_foreign_function, "make-foreign-function", 3, 0, 0,
+ (nargs + n_struct_elts + 1)*sizeof(ffi_type)); + (nargs + n_struct_elts + 1)*sizeof(ffi_type));
mem = scm_gc_malloc_pointerless (cif_len, "foreign"); mem = scm_gc_malloc_pointerless (cif_len, "foreign");
scm_cif = scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID, mem, scm_cif = scm_take_foreign_pointer (mem, NULL);
cif_len, NULL);
cif = (ffi_cif *) mem; cif = (ffi_cif *) mem;
/* reuse cif_len to walk through the mem */ /* reuse cif_len to walk through the mem */
@ -852,9 +733,13 @@ static const SCM objcode_trampolines[10] = {
static SCM static SCM
cif_to_procedure (SCM cif, SCM func_ptr) cif_to_procedure (SCM cif, SCM func_ptr)
{ {
unsigned nargs = SCM_FOREIGN_POINTER (cif, ffi_cif)->nargs; ffi_cif *c_cif;
unsigned int nargs;
SCM objcode, table, ret; SCM objcode, table, ret;
c_cif = (ffi_cif *) SCM_FOREIGN_POINTER (cif);
nargs = c_cif->nargs;
if (nargs < 10) if (nargs < 10)
objcode = objcode_trampolines[nargs]; objcode = objcode_trampolines[nargs];
else else
@ -906,17 +791,10 @@ unpack (const ffi_type *type, void *loc, SCM x)
*(scm_t_int64 *) loc = scm_to_int64 (x); *(scm_t_int64 *) loc = scm_to_int64 (x);
break; break;
case FFI_TYPE_STRUCT: case FFI_TYPE_STRUCT:
if (!SCM_FOREIGN_TYPED_P (x, VOID)) memcpy (loc, SCM_FOREIGN_POINTER (x), type->size);
scm_wrong_type_arg_msg ("foreign-call", 0, x, "foreign void pointer");
if (SCM_FOREIGN_LEN (x) && SCM_FOREIGN_LEN (x) != type->size)
scm_wrong_type_arg_msg ("foreign-call", 0, x,
"foreign void pointer of correct length");
memcpy (loc, SCM_FOREIGN_POINTER (x, void), type->size);
break; break;
case FFI_TYPE_POINTER: case FFI_TYPE_POINTER:
if (!SCM_FOREIGN_TYPED_P (x, VOID)) *(void **) loc = SCM_FOREIGN_POINTER (x);
scm_wrong_type_arg_msg ("foreign-call", 0, x, "foreign void pointer");
*(void **) loc = SCM_FOREIGN_POINTER (x, void);
break; break;
default: default:
abort (); abort ();
@ -955,12 +833,10 @@ pack (const ffi_type * type, const void *loc)
{ {
void *mem = scm_gc_malloc_pointerless (type->size, "foreign"); void *mem = scm_gc_malloc_pointerless (type->size, "foreign");
memcpy (mem, loc, type->size); memcpy (mem, loc, type->size);
return scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID, return scm_take_foreign_pointer (mem, NULL);
mem, type->size, NULL);
} }
case FFI_TYPE_POINTER: case FFI_TYPE_POINTER:
return scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID, return scm_take_foreign_pointer (*(void **) loc, NULL);
*(void **) loc, 0, NULL);
default: default:
abort (); abort ();
} }
@ -981,8 +857,8 @@ scm_i_foreign_call (SCM foreign, const SCM *argv)
size_t arg_size; size_t arg_size;
scm_t_ptrdiff off; scm_t_ptrdiff off;
cif = SCM_FOREIGN_POINTER (SCM_CAR (foreign), ffi_cif); cif = SCM_FOREIGN_POINTER (SCM_CAR (foreign));
func = SCM_FOREIGN_POINTER (SCM_CDR (foreign), void); func = SCM_FOREIGN_POINTER (SCM_CDR (foreign));
/* Argument pointers. */ /* Argument pointers. */
args = alloca (sizeof (void *) * cif->nargs); args = alloca (sizeof (void *) * cif->nargs);
@ -1093,8 +969,7 @@ scm_init_foreign (void)
#endif #endif
); );
null_pointer = scm_cell (scm_tc7_foreign | (SCM_FOREIGN_TYPE_VOID << 8UL), null_pointer = scm_cell (scm_tc7_foreign, 0);
0);
scm_define (sym_null, null_pointer); scm_define (sym_null, null_pointer);
} }

58
libguile/foreign.h
View file

@ -26,20 +26,13 @@
scm_tc7_foreign typecode and type of the aliased (pointed-to) value in its scm_tc7_foreign typecode and type of the aliased (pointed-to) value in its
lower 16 bits. 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, The basic idea is that we can help the programmer to avoid cutting herself,
but we won't take away her knives. but we won't take away her knives. */
*/
typedef enum enum scm_t_foreign_type
{ {
SCM_FOREIGN_TYPE_VOID, /* a pointer out into the wilderness */ SCM_FOREIGN_TYPE_VOID,
SCM_FOREIGN_TYPE_FLOAT, SCM_FOREIGN_TYPE_FLOAT,
SCM_FOREIGN_TYPE_DOUBLE, SCM_FOREIGN_TYPE_DOUBLE,
SCM_FOREIGN_TYPE_UINT8, SCM_FOREIGN_TYPE_UINT8,
SCM_FOREIGN_TYPE_INT8, SCM_FOREIGN_TYPE_INT8,
@ -50,55 +43,32 @@ typedef enum
SCM_FOREIGN_TYPE_UINT64, SCM_FOREIGN_TYPE_UINT64,
SCM_FOREIGN_TYPE_INT64, SCM_FOREIGN_TYPE_INT64,
SCM_FOREIGN_TYPE_LAST = SCM_FOREIGN_TYPE_INT64 SCM_FOREIGN_TYPE_LAST = SCM_FOREIGN_TYPE_INT64
} scm_t_foreign_type; };
typedef enum scm_t_foreign_type scm_t_foreign_type;
typedef void (*scm_t_foreign_finalizer) (void *); typedef void (*scm_t_foreign_finalizer) (void *);
#define SCM_FOREIGN_P(x) \ #define SCM_FOREIGN_P(x) \
(!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_foreign) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_foreign)
#define SCM_VALIDATE_FOREIGN(pos, x) \ #define SCM_VALIDATE_FOREIGN(pos, x) \
SCM_MAKE_VALIDATE (pos, x, FOREIGN_P) SCM_MAKE_VALIDATE (pos, x, FOREIGN_P)
#define SCM_FOREIGN_TYPE(x) \ #define SCM_FOREIGN_POINTER(x) \
((scm_t_foreign_type)((SCM_CELL_WORD_0 (x) >> 8)&0xff)) ((void *) SCM_CELL_WORD_1 (x))
#define SCM_FOREIGN_POINTER(x, ctype) \ #define SCM_FOREIGN_HAS_FINALIZER(x) \
((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) ((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_API SCM scm_take_foreign_pointer (void *, scm_t_foreign_finalizer);
(SCM_FOREIGN_P (x) && SCM_FOREIGN_TYPE (x) == SCM_FOREIGN_TYPE_##type)
#define SCM_VALIDATE_FOREIGN_TYPED(pos, x, type) \
do { \
SCM_ASSERT_TYPE (SCM_FOREIGN_TYPED_P (x, type), x, pos, FUNC_NAME, \
"FOREIGN_"#type"_P"); \
} while (0)
#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_alignof (SCM type); SCM_API SCM scm_alignof (SCM type);
SCM_API SCM scm_sizeof (SCM type); SCM_API SCM scm_sizeof (SCM type);
SCM_API SCM scm_foreign_type (SCM foreign); SCM_API SCM scm_foreign_address (SCM foreign);
SCM_API SCM scm_foreign_ref (SCM foreign);
SCM_API SCM scm_foreign_set_x (SCM foreign, SCM val);
SCM_API SCM scm_foreign_to_bytevector (SCM foreign, SCM type, SCM_API SCM scm_foreign_to_bytevector (SCM foreign, SCM type,
SCM offset, SCM len); SCM offset, SCM len);
SCM_API SCM scm_foreign_set_finalizer_x (SCM foreign, SCM finalizer); SCM_API SCM scm_foreign_set_finalizer_x (SCM foreign, SCM finalizer);
SCM_API SCM scm_bytevector_to_foreign (SCM bv, SCM offset, SCM len); SCM_API SCM scm_bytevector_to_foreign (SCM bv, SCM offset, SCM len);
SCM_INTERNAL SCM scm_make_pointer (SCM address, SCM finalizer);
SCM_INTERNAL void scm_i_foreign_print (SCM foreign, SCM port, SCM_INTERNAL void scm_i_foreign_print (SCM foreign, SCM port,
scm_print_state *pstate); scm_print_state *pstate);

6
libguile/gsubr.c
View file

@ -794,13 +794,11 @@ create_gsubr (int define, const char *name,
sname = scm_from_locale_symbol (name); sname = scm_from_locale_symbol (name);
table = scm_c_make_vector (generic_loc ? 3 : 2, SCM_UNDEFINED); table = scm_c_make_vector (generic_loc ? 3 : 2, SCM_UNDEFINED);
SCM_SIMPLE_VECTOR_SET (table, 0, SCM_SIMPLE_VECTOR_SET (table, 0,
scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID, scm_take_foreign_pointer (fcn, NULL));
fcn, 0, NULL));
SCM_SIMPLE_VECTOR_SET (table, 1, sname); SCM_SIMPLE_VECTOR_SET (table, 1, sname);
if (generic_loc) if (generic_loc)
SCM_SIMPLE_VECTOR_SET (table, 2, SCM_SIMPLE_VECTOR_SET (table, 2,
scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID, scm_take_foreign_pointer (generic_loc, NULL));
generic_loc, 0, NULL));
/* make program */ /* make program */
ret = scm_make_program (scm_subr_objcode_trampoline (nreq, nopt, rest), ret = scm_make_program (scm_subr_objcode_trampoline (nreq, nopt, rest),

13
libguile/gsubr.h
View file

@ -41,12 +41,19 @@ SCM_API SCM scm_subr_objcode_trampoline (unsigned int nreq,
#define SCM_GSUBR_MAX 10 #define SCM_GSUBR_MAX 10
#define SCM_PRIMITIVE_P(x) (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE (x)) #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_PRIMITIVE_GENERIC_P(x) (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x))
#define SCM_SUBRF(x) ((SCM (*)()) (SCM_FOREIGN_POINTER (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 0), void))) #define SCM_SUBRF(x) \
((SCM (*) (void)) \
SCM_FOREIGN_POINTER (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 0)))
#define SCM_SUBR_NAME(x) (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 1)) #define SCM_SUBR_NAME(x) (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 1))
#define SCM_SUBR_GENERIC(x) \
(SCM_FOREIGN_POINTER (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 2), SCM)) #define SCM_SUBR_GENERIC(x) \
((SCM *) \
SCM_FOREIGN_POINTER (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 2)))
#define SCM_SET_SUBR_GENERIC(x, g) \ #define SCM_SET_SUBR_GENERIC(x, g) \
(*SCM_SUBR_GENERIC (x) = (g)) (*SCM_SUBR_GENERIC (x) = (g))

6
libguile/snarf.h
View file

@ -361,10 +361,8 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));)
(scm_t_bits) 0, \ (scm_t_bits) 0, \
(scm_t_bits) sizeof (contents) - 1) (scm_t_bits) sizeof (contents) - 1)
#define SCM_IMMUTABLE_FOREIGN(c_name, ptr) \ #define SCM_IMMUTABLE_FOREIGN(c_name, ptr) \
SCM_IMMUTABLE_CELL (c_name, \ SCM_IMMUTABLE_CELL (c_name, scm_tc7_foreign, ptr)
scm_tc7_foreign | (SCM_FOREIGN_TYPE_VOID << 8), \
ptr)
/* for primitive-generics, add a foreign to the end */ /* for primitive-generics, add a foreign to the end */
#define SCM_STATIC_SUBR_OBJVECT(c_name, foreign) \ #define SCM_STATIC_SUBR_OBJVECT(c_name, foreign) \

2
libguile/vm-i-system.c
View file

@ -845,7 +845,7 @@ VM_DEFINE_INSTRUCTION (56, subr_call, "subr-call", 1, -1, -1)
nargs = FETCH (); nargs = FETCH ();
POP (foreign); POP (foreign);
subr = SCM_FOREIGN_POINTER (foreign, void); subr = SCM_FOREIGN_POINTER (foreign);
VM_HANDLE_INTERRUPTS; VM_HANDLE_INTERRUPTS;
SYNC_REGISTER (); SYNC_REGISTER ();

21
module/system/foreign.scm
View file

@ -25,11 +25,14 @@
uint16 int16 uint16 int16
uint32 int32 uint32 int32
uint64 int64 uint64 int64
%null-pointer
sizeof alignof sizeof alignof
foreign-ref foreign-set! %null-pointer
null-pointer?
make-pointer
foreign-address
foreign->bytevector bytevector->foreign foreign->bytevector bytevector->foreign
foreign-set-finalizer! foreign-set-finalizer!
make-foreign-function make-foreign-function
@ -38,6 +41,20 @@
(load-extension (string-append "libguile-" (effective-version)) (load-extension (string-append "libguile-" (effective-version))
"scm_init_foreign") "scm_init_foreign")
;;;
;;; Pointers.
;;;
(define (null-pointer? pointer)
(= (foreign-address pointer) 0))
;;;
;;; Structures.
;;;
(define *writers* (define *writers*
`((,float . ,bytevector-ieee-single-native-set!) `((,float . ,bytevector-ieee-single-native-set!)
(,double . ,bytevector-ieee-double-native-set!) (,double . ,bytevector-ieee-double-native-set!)

11
test-suite/standalone/test-ffi
View file

@ -165,12 +165,13 @@ exec guile -q -s "$0" "$@"
(define f-memcpy (define f-memcpy
(make-foreign-function '* (dynamic-func "test_ffi_memcpy" lib) (make-foreign-function '* (dynamic-func "test_ffi_memcpy" lib)
(list '* '* int32))) (list '* '* int32)))
(let* ((src (bytevector->foreign (u8-list->bytevector '(0 1 2 3 4 5 6 7)))) (let* ((src* '(0 1 2 3 4 5 6 7))
(src (bytevector->foreign (u8-list->bytevector src*)))
(dest (bytevector->foreign (make-bytevector 16 0))) (dest (bytevector->foreign (make-bytevector 16 0)))
(res (f-memcpy dest src (bytevector-length (foreign->bytevector src))))) (res (f-memcpy dest src (length src*))))
(or (= (foreign-ref dest) (foreign-ref res)) (or (= (foreign-address dest) (foreign-address res))
(error "memcpy res not equal to dest")) (error "memcpy res not equal to dest"))
(or (equal? (bytevector->u8-list (foreign->bytevector dest)) (or (equal? (bytevector->u8-list (foreign->bytevector dest 16))
'(0 1 2 3 4 5 6 7 0 0 0 0 0 0 0 0)) '(0 1 2 3 4 5 6 7 0 0 0 0 0 0 0 0))
(error "unexpected dest"))) (error "unexpected dest")))
@ -196,7 +197,7 @@ exec guile -q -s "$0" "$@"
(let* ((ptr (strerror ENOENT)) (let* ((ptr (strerror ENOENT))
(len (strlen ptr)) (len (strlen ptr))
(bv (foreign->bytevector ptr 'u8 0 len)) (bv (foreign->bytevector ptr len 0 'u8))
(str (utf8->string bv))) (str (utf8->string bv)))
(test #t (not (not (string-contains str "file"))))) (test #t (not (not (string-contains str "file")))))

52
test-suite/tests/foreign.test
View file

@ -23,35 +23,47 @@
(define-module (test-foreign) (define-module (test-foreign)
#:use-module (system foreign) #:use-module (system foreign)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (test-suite lib)) #:use-module (test-suite lib))
(with-test-prefix "null pointer" (with-test-prefix "null pointer"
(pass-if "zero" (pass-if "zero"
(= 0 (foreign-ref %null-pointer))) (= 0 (foreign-address %null-pointer)))
(pass-if-exception "foreign-set! %null-pointer" (pass-if "null pointer identity"
exception:null-pointer-error (eq? %null-pointer (make-pointer 0)))
(foreign-set! %null-pointer 2))
(pass-if "foreign-set! other-null-pointer" (pass-if "null-pointer? %null-pointer"
(let ((f (bytevector->foreign (make-bytevector 2)))) (null-pointer? %null-pointer))
(and (not (= 0 (foreign-ref f)))
(begin
(foreign-set! f 0)
(= 0 (foreign-ref f)))
(begin
;; Here changing the pointer value of F is perfectly valid.
(foreign-set! f 777)
(= 777 (foreign-ref f))))))
(pass-if-exception "foreign->bytevector %null-pointer" (pass-if-exception "foreign->bytevector %null-pointer"
exception:null-pointer-error exception:null-pointer-error
(foreign->bytevector %null-pointer)) (foreign->bytevector %null-pointer 7)))
(pass-if-exception "foreign->bytevector other-null-pointer"
exception:null-pointer-error (with-test-prefix "make-pointer"
(let ((f (bytevector->foreign (make-bytevector 2))))
(foreign-set! f 0) (pass-if "address preserved"
(foreign->bytevector f)))) (= 123 (foreign-address (make-pointer 123)))))
(with-test-prefix "foreign<->bytevector"
(pass-if "bijection"
(let ((bv #vu8(0 1 2 3 4 5 6 7)))
(equal? (foreign->bytevector (bytevector->foreign bv)
(bytevector-length bv))
bv)))
(pass-if "pointer from bits"
(let* ((bytes (iota (sizeof '*)))
(bv (u8-list->bytevector bytes)))
(= (foreign-address
(make-pointer (bytevector-uint-ref bv 0 (native-endianness)
(sizeof '*))))
(fold-right (lambda (byte address)
(+ byte (* 256 address)))
0
bytes)))))