mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
Simplify the (system foreign) API.
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
parent
1af772303b
commit
d4149a510e
12 changed files with 176 additions and 307 deletions
|
|
@ -1900,9 +1900,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, 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);
|
||||
for (argc = 0; argv[argc]; argc++)
|
||||
|
|
|
|||
|
|
@ -235,13 +235,11 @@ SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0,
|
|||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_dynamic_pointer, "dynamic-pointer", 3, 1, 0,
|
||||
(SCM name, SCM type, SCM dobj, SCM len),
|
||||
SCM_DEFINE (scm_dynamic_pointer, "dynamic-pointer", 2, 0, 0,
|
||||
(SCM name, SCM dobj),
|
||||
"Return a ``handle'' for the pointer @var{name} in the\n"
|
||||
"shared object referred to by @var{dobj}. The handle\n"
|
||||
"aliases a C value, and is declared to be of type\n"
|
||||
"@var{type}. Valid types are defined in the\n"
|
||||
"@code{(system foreign)} module.\n\n"
|
||||
"aliases a C object.\n\n"
|
||||
"This facility works by asking the dynamic linker 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"
|
||||
|
|
@ -254,11 +252,9 @@ SCM_DEFINE (scm_dynamic_pointer, "dynamic-pointer", 3, 1, 0,
|
|||
#define FUNC_NAME s_scm_dynamic_pointer
|
||||
{
|
||||
void *val;
|
||||
scm_t_foreign_type t;
|
||||
|
||||
SCM_VALIDATE_STRING (1, name);
|
||||
t = scm_to_unsigned_integer (type, 0, SCM_FOREIGN_TYPE_LAST);
|
||||
SCM_VALIDATE_SMOB (SCM_ARG3, dobj, dynamic_obj);
|
||||
SCM_VALIDATE_SMOB (SCM_ARG2, dobj, dynamic_obj);
|
||||
|
||||
if (DYNL_HANDLE (dobj) == NULL)
|
||||
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);
|
||||
scm_dynwind_end ();
|
||||
|
||||
return scm_take_foreign_pointer (t, val,
|
||||
SCM_UNBNDP (len) ? 0 : scm_to_size_t (len),
|
||||
NULL);
|
||||
return scm_take_foreign_pointer (val, NULL);
|
||||
}
|
||||
}
|
||||
#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.")
|
||||
#define FUNC_NAME s_scm_dynamic_func
|
||||
{
|
||||
return scm_dynamic_pointer (name,
|
||||
scm_from_uint (SCM_FOREIGN_TYPE_VOID),
|
||||
dobj,
|
||||
SCM_UNDEFINED);
|
||||
return scm_dynamic_pointer (name, dobj);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
@ -324,9 +315,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, VOID);
|
||||
SCM_VALIDATE_FOREIGN (SCM_ARG1, func);
|
||||
|
||||
fptr = SCM_FOREIGN_POINTER (func, void);
|
||||
fptr = SCM_FOREIGN_POINTER (func);
|
||||
fptr ();
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -30,7 +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_pointer (SCM name, SCM dobj);
|
||||
SCM_API SCM scm_dynamic_func (SCM symb, SCM dobj);
|
||||
SCM_API SCM scm_dynamic_call (SCM symb, SCM dobj);
|
||||
|
||||
|
|
|
|||
|
|
@ -59,6 +59,17 @@ SCM_SYMBOL (sym_null_pointer_error, "null-pointer-error");
|
|||
/* The cell representing the 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. */
|
||||
static void
|
||||
null_pointer_error (const char *func_name)
|
||||
|
|
@ -83,20 +94,46 @@ static void
|
|||
foreign_finalizer_trampoline (GC_PTR ptr, GC_PTR 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_take_foreign_pointer (scm_t_foreign_type type, void *ptr, size_t len,
|
||||
scm_t_foreign_finalizer finalizer)
|
||||
scm_take_foreign_pointer (void *ptr, scm_t_foreign_finalizer finalizer)
|
||||
{
|
||||
SCM ret;
|
||||
scm_t_bits word0;
|
||||
|
||||
word0 = (scm_t_bits)(scm_tc7_foreign | (type<<8)
|
||||
| (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));
|
||||
word0 = scm_tc7_foreign | (finalizer ? (1 << 16UL) : 0UL);
|
||||
|
||||
ret = scm_cell (word0, (scm_t_bits) ptr);
|
||||
if (finalizer)
|
||||
|
|
@ -114,117 +151,19 @@ scm_take_foreign_pointer (scm_t_foreign_type type, void *ptr, size_t len,
|
|||
return ret;
|
||||
}
|
||||
|
||||
SCM_DEFINE (scm_foreign_ref, "foreign-ref", 1, 0, 0,
|
||||
SCM_DEFINE (scm_foreign_address, "foreign-address", 1, 0, 0,
|
||||
(SCM foreign),
|
||||
"Reference the foreign value pointed to by @var{foreign}.\n\n"
|
||||
"The value will be referenced according to its type.")
|
||||
#define FUNC_NAME s_scm_foreign_ref
|
||||
"Return the numerical value of @var{foreign}.")
|
||||
#define FUNC_NAME s_scm_foreign_address
|
||||
{
|
||||
scm_t_foreign_type ftype;
|
||||
scm_t_uint8 *ptr;
|
||||
|
||||
SCM_VALIDATE_FOREIGN (1, foreign);
|
||||
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: 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");
|
||||
}
|
||||
return scm_from_uintptr ((scm_t_uintptr) SCM_FOREIGN_POINTER (foreign));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_foreign_set_x, "foreign-set!", 2, 0, 0,
|
||||
(SCM foreign, SCM val),
|
||||
"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),
|
||||
SCM_DEFINE (scm_foreign_to_bytevector, "foreign->bytevector", 2, 2, 0,
|
||||
(SCM foreign, SCM len, SCM offset, SCM uvec_type),
|
||||
"Return a bytevector aliasing the memory pointed to by\n"
|
||||
"@var{foreign}.\n\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;
|
||||
scm_t_array_element_type btype;
|
||||
|
||||
SCM_VALIDATE_FOREIGN_TYPED (1, foreign, VOID);
|
||||
ptr = SCM_FOREIGN_POINTER (foreign, scm_t_int8);
|
||||
SCM_VALIDATE_FOREIGN (1, foreign);
|
||||
ptr = SCM_FOREIGN_POINTER (foreign);
|
||||
|
||||
if (SCM_UNLIKELY (ptr == NULL))
|
||||
null_pointer_error (FUNC_NAME);
|
||||
|
|
@ -286,29 +225,10 @@ SCM_DEFINE (scm_foreign_to_bytevector, "foreign->bytevector", 1, 3, 0,
|
|||
|
||||
if (SCM_UNBNDP (offset))
|
||||
boffset = 0;
|
||||
else if (SCM_FOREIGN_LEN (foreign))
|
||||
boffset = scm_to_unsigned_integer (offset, 0,
|
||||
SCM_FOREIGN_LEN (foreign) - 1);
|
||||
else
|
||||
boffset = scm_to_size_t (offset);
|
||||
|
||||
if (SCM_UNBNDP (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);
|
||||
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,
|
||||
SCM_BYTEVECTOR_LENGTH (bv) - boffset);
|
||||
|
||||
ret = scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID, ptr + boffset, blen,
|
||||
NULL);
|
||||
ret = scm_take_foreign_pointer (ptr + boffset, NULL);
|
||||
register_weak_reference (ret, bv);
|
||||
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_PTR prev_finalizer_data;
|
||||
|
||||
SCM_VALIDATE_FOREIGN_TYPED (1, foreign, VOID);
|
||||
SCM_VALIDATE_FOREIGN_TYPED (2, finalizer, VOID);
|
||||
SCM_VALIDATE_FOREIGN (1, foreign);
|
||||
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));
|
||||
|
||||
|
|
@ -389,45 +308,7 @@ void
|
|||
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_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_display (scm_foreign_address (foreign), 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 *types;
|
||||
|
||||
SCM_VALIDATE_FOREIGN_TYPED (2, func_ptr, VOID);
|
||||
SCM_VALIDATE_FOREIGN (2, func_ptr);
|
||||
|
||||
nargs = scm_ilength (arg_types);
|
||||
SCM_ASSERT (nargs >= 0, arg_types, 3, FUNC_NAME);
|
||||
/* 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));
|
||||
|
||||
mem = scm_gc_malloc_pointerless (cif_len, "foreign");
|
||||
scm_cif = scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID, mem,
|
||||
cif_len, NULL);
|
||||
scm_cif = scm_take_foreign_pointer (mem, NULL);
|
||||
cif = (ffi_cif *) mem;
|
||||
|
||||
/* reuse cif_len to walk through the mem */
|
||||
|
|
@ -852,9 +733,13 @@ static const SCM objcode_trampolines[10] = {
|
|||
static SCM
|
||||
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;
|
||||
|
||||
c_cif = (ffi_cif *) SCM_FOREIGN_POINTER (cif);
|
||||
nargs = c_cif->nargs;
|
||||
|
||||
if (nargs < 10)
|
||||
objcode = objcode_trampolines[nargs];
|
||||
else
|
||||
|
|
@ -906,17 +791,10 @@ unpack (const ffi_type *type, void *loc, SCM x)
|
|||
*(scm_t_int64 *) loc = scm_to_int64 (x);
|
||||
break;
|
||||
case FFI_TYPE_STRUCT:
|
||||
if (!SCM_FOREIGN_TYPED_P (x, VOID))
|
||||
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);
|
||||
memcpy (loc, SCM_FOREIGN_POINTER (x), type->size);
|
||||
break;
|
||||
case FFI_TYPE_POINTER:
|
||||
if (!SCM_FOREIGN_TYPED_P (x, VOID))
|
||||
scm_wrong_type_arg_msg ("foreign-call", 0, x, "foreign void pointer");
|
||||
*(void **) loc = SCM_FOREIGN_POINTER (x, void);
|
||||
*(void **) loc = SCM_FOREIGN_POINTER (x);
|
||||
break;
|
||||
default:
|
||||
abort ();
|
||||
|
|
@ -955,12 +833,10 @@ pack (const ffi_type * type, const void *loc)
|
|||
{
|
||||
void *mem = scm_gc_malloc_pointerless (type->size, "foreign");
|
||||
memcpy (mem, loc, type->size);
|
||||
return scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID,
|
||||
mem, type->size, NULL);
|
||||
return scm_take_foreign_pointer (mem, NULL);
|
||||
}
|
||||
case FFI_TYPE_POINTER:
|
||||
return scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID,
|
||||
*(void **) loc, 0, NULL);
|
||||
return scm_take_foreign_pointer (*(void **) loc, NULL);
|
||||
default:
|
||||
abort ();
|
||||
}
|
||||
|
|
@ -981,8 +857,8 @@ scm_i_foreign_call (SCM foreign, const SCM *argv)
|
|||
size_t arg_size;
|
||||
scm_t_ptrdiff off;
|
||||
|
||||
cif = SCM_FOREIGN_POINTER (SCM_CAR (foreign), ffi_cif);
|
||||
func = SCM_FOREIGN_POINTER (SCM_CDR (foreign), void);
|
||||
cif = SCM_FOREIGN_POINTER (SCM_CAR (foreign));
|
||||
func = SCM_FOREIGN_POINTER (SCM_CDR (foreign));
|
||||
|
||||
/* Argument pointers. */
|
||||
args = alloca (sizeof (void *) * cif->nargs);
|
||||
|
|
@ -1093,8 +969,7 @@ scm_init_foreign (void)
|
|||
#endif
|
||||
);
|
||||
|
||||
null_pointer = scm_cell (scm_tc7_foreign | (SCM_FOREIGN_TYPE_VOID << 8UL),
|
||||
0);
|
||||
null_pointer = scm_cell (scm_tc7_foreign, 0);
|
||||
scm_define (sym_null, null_pointer);
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -26,19 +26,12 @@
|
|||
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
|
||||
but we won't take away her knives. */
|
||||
|
||||
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_DOUBLE,
|
||||
SCM_FOREIGN_TYPE_UINT8,
|
||||
|
|
@ -50,8 +43,9 @@ typedef enum
|
|||
SCM_FOREIGN_TYPE_UINT64,
|
||||
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 *);
|
||||
|
||||
|
|
@ -59,46 +53,22 @@ typedef void (*scm_t_foreign_finalizer) (void *);
|
|||
(!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_foreign)
|
||||
#define SCM_VALIDATE_FOREIGN(pos, x) \
|
||||
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_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_POINTER(x) \
|
||||
((void *) SCM_CELL_WORD_1 (x))
|
||||
#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)
|
||||
#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_take_foreign_pointer (void *, scm_t_foreign_finalizer);
|
||||
|
||||
SCM_API SCM scm_alignof (SCM type);
|
||||
SCM_API SCM scm_sizeof (SCM type);
|
||||
SCM_API SCM scm_foreign_type (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_address (SCM foreign);
|
||||
SCM_API SCM scm_foreign_to_bytevector (SCM foreign, SCM type,
|
||||
SCM offset, SCM len);
|
||||
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_INTERNAL SCM scm_make_pointer (SCM address, SCM finalizer);
|
||||
SCM_INTERNAL void scm_i_foreign_print (SCM foreign, SCM port,
|
||||
scm_print_state *pstate);
|
||||
|
||||
|
|
|
|||
|
|
@ -794,13 +794,11 @@ 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_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID,
|
||||
fcn, 0, NULL));
|
||||
scm_take_foreign_pointer (fcn, NULL));
|
||||
SCM_SIMPLE_VECTOR_SET (table, 1, sname);
|
||||
if (generic_loc)
|
||||
SCM_SIMPLE_VECTOR_SET (table, 2,
|
||||
scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID,
|
||||
generic_loc, 0, NULL));
|
||||
scm_take_foreign_pointer (generic_loc, NULL));
|
||||
|
||||
/* make program */
|
||||
ret = scm_make_program (scm_subr_objcode_trampoline (nreq, nopt, rest),
|
||||
|
|
|
|||
|
|
@ -41,12 +41,19 @@ SCM_API SCM scm_subr_objcode_trampoline (unsigned int nreq,
|
|||
#define SCM_GSUBR_MAX 10
|
||||
|
||||
#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_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_GENERIC(x) \
|
||||
(SCM_FOREIGN_POINTER (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 2), SCM))
|
||||
((SCM *) \
|
||||
SCM_FOREIGN_POINTER (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 2)))
|
||||
|
||||
#define SCM_SET_SUBR_GENERIC(x, g) \
|
||||
(*SCM_SUBR_GENERIC (x) = (g))
|
||||
|
||||
|
|
|
|||
|
|
@ -362,9 +362,7 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));)
|
|||
(scm_t_bits) sizeof (contents) - 1)
|
||||
|
||||
#define SCM_IMMUTABLE_FOREIGN(c_name, ptr) \
|
||||
SCM_IMMUTABLE_CELL (c_name, \
|
||||
scm_tc7_foreign | (SCM_FOREIGN_TYPE_VOID << 8), \
|
||||
ptr)
|
||||
SCM_IMMUTABLE_CELL (c_name, scm_tc7_foreign, ptr)
|
||||
|
||||
/* for primitive-generics, add a foreign to the end */
|
||||
#define SCM_STATIC_SUBR_OBJVECT(c_name, foreign) \
|
||||
|
|
|
|||
|
|
@ -845,7 +845,7 @@ VM_DEFINE_INSTRUCTION (56, subr_call, "subr-call", 1, -1, -1)
|
|||
nargs = FETCH ();
|
||||
POP (foreign);
|
||||
|
||||
subr = SCM_FOREIGN_POINTER (foreign, void);
|
||||
subr = SCM_FOREIGN_POINTER (foreign);
|
||||
|
||||
VM_HANDLE_INTERRUPTS;
|
||||
SYNC_REGISTER ();
|
||||
|
|
|
|||
|
|
@ -25,11 +25,14 @@
|
|||
uint16 int16
|
||||
uint32 int32
|
||||
uint64 int64
|
||||
%null-pointer
|
||||
|
||||
sizeof alignof
|
||||
|
||||
foreign-ref foreign-set!
|
||||
%null-pointer
|
||||
null-pointer?
|
||||
make-pointer
|
||||
foreign-address
|
||||
|
||||
foreign->bytevector bytevector->foreign
|
||||
foreign-set-finalizer!
|
||||
make-foreign-function
|
||||
|
|
@ -38,6 +41,20 @@
|
|||
(load-extension (string-append "libguile-" (effective-version))
|
||||
"scm_init_foreign")
|
||||
|
||||
|
||||
;;;
|
||||
;;; Pointers.
|
||||
;;;
|
||||
|
||||
(define (null-pointer? pointer)
|
||||
(= (foreign-address pointer) 0))
|
||||
|
||||
|
||||
|
||||
;;;
|
||||
;;; Structures.
|
||||
;;;
|
||||
|
||||
(define *writers*
|
||||
`((,float . ,bytevector-ieee-single-native-set!)
|
||||
(,double . ,bytevector-ieee-double-native-set!)
|
||||
|
|
|
|||
|
|
@ -165,12 +165,13 @@ exec guile -q -s "$0" "$@"
|
|||
(define f-memcpy
|
||||
(make-foreign-function '* (dynamic-func "test_ffi_memcpy" lib)
|
||||
(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)))
|
||||
(res (f-memcpy dest src (bytevector-length (foreign->bytevector src)))))
|
||||
(or (= (foreign-ref dest) (foreign-ref res))
|
||||
(res (f-memcpy dest src (length src*))))
|
||||
(or (= (foreign-address dest) (foreign-address res))
|
||||
(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))
|
||||
(error "unexpected dest")))
|
||||
|
||||
|
|
@ -196,7 +197,7 @@ exec guile -q -s "$0" "$@"
|
|||
|
||||
(let* ((ptr (strerror ENOENT))
|
||||
(len (strlen ptr))
|
||||
(bv (foreign->bytevector ptr 'u8 0 len))
|
||||
(bv (foreign->bytevector ptr len 0 'u8))
|
||||
(str (utf8->string bv)))
|
||||
(test #t (not (not (string-contains str "file")))))
|
||||
|
||||
|
|
|
|||
|
|
@ -23,35 +23,47 @@
|
|||
(define-module (test-foreign)
|
||||
#:use-module (system foreign)
|
||||
#:use-module (rnrs bytevectors)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (test-suite lib))
|
||||
|
||||
|
||||
(with-test-prefix "null pointer"
|
||||
|
||||
(pass-if "zero"
|
||||
(= 0 (foreign-ref %null-pointer)))
|
||||
(= 0 (foreign-address %null-pointer)))
|
||||
|
||||
(pass-if-exception "foreign-set! %null-pointer"
|
||||
exception:null-pointer-error
|
||||
(foreign-set! %null-pointer 2))
|
||||
(pass-if "null pointer identity"
|
||||
(eq? %null-pointer (make-pointer 0)))
|
||||
|
||||
(pass-if "foreign-set! other-null-pointer"
|
||||
(let ((f (bytevector->foreign (make-bytevector 2))))
|
||||
(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 "null-pointer? %null-pointer"
|
||||
(null-pointer? %null-pointer))
|
||||
|
||||
(pass-if-exception "foreign->bytevector %null-pointer"
|
||||
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
|
||||
(let ((f (bytevector->foreign (make-bytevector 2))))
|
||||
(foreign-set! f 0)
|
||||
(foreign->bytevector f))))
|
||||
|
||||
(with-test-prefix "make-pointer"
|
||||
|
||||
(pass-if "address preserved"
|
||||
(= 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)))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue