diff options
author | Ludovic Courtès <ludo@gnu.org> | 2010-07-26 17:44:43 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2010-07-26 19:38:52 +0200 |
commit | d4149a510e4a87915b625255f4de3301510d810c (patch) | |
tree | 8145892f76b6eda3ec86f0be752e391913b9a656 | |
parent | 1af772303bf4eafb632a95bf4015a7736275e9e7 (diff) | |
download | guile-d4149a510e4a87915b625255f4de3301510d810c.tar.gz |
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.
-rw-r--r-- | libguile/deprecated.c | 4 | ||||
-rw-r--r-- | libguile/dynl.c | 25 | ||||
-rw-r--r-- | libguile/dynl.h | 2 | ||||
-rw-r--r-- | libguile/foreign.c | 281 | ||||
-rw-r--r-- | libguile/foreign.h | 60 | ||||
-rw-r--r-- | libguile/gsubr.c | 6 | ||||
-rw-r--r-- | libguile/gsubr.h | 13 | ||||
-rw-r--r-- | libguile/snarf.h | 6 | ||||
-rw-r--r-- | libguile/vm-i-system.c | 2 | ||||
-rw-r--r-- | module/system/foreign.scm | 21 | ||||
-rwxr-xr-x | test-suite/standalone/test-ffi | 11 | ||||
-rw-r--r-- | test-suite/tests/foreign.test | 54 |
12 files changed, 177 insertions, 308 deletions
diff --git a/libguile/deprecated.c b/libguile/deprecated.c index a35e21af2..de5ac5b08 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -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++) diff --git a/libguile/dynl.c b/libguile/dynl.c index b76e85c79..9ee4e2c4d 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -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; } diff --git a/libguile/dynl.h b/libguile/dynl.h index 3239d639e..e735bccfa 100644 --- a/libguile/dynl.h +++ b/libguile/dynl.h @@ -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); diff --git a/libguile/foreign.c b/libguile/foreign.c index aae4c670e..dc9367614 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -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) @@ -78,25 +89,51 @@ register_weak_reference (SCM from, SCM to) { scm_hashq_set_x (foreign_weak_refs, from, to); } - + 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 -{ - 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"); - } -} -#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 + "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); - 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; + return scm_from_uintptr ((scm_t_uintptr) SCM_FOREIGN_POINTER (foreign)); } #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); @@ -283,32 +222,13 @@ SCM_DEFINE (scm_foreign_to_bytevector, "foreign->bytevector", 1, 3, 0, "uniform vector type"); } } - + 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); - } + 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); - - c_finalizer = SCM_FOREIGN_POINTER (finalizer, void); + SCM_VALIDATE_FOREIGN (1, foreign); + SCM_VALIDATE_FOREIGN (2, finalizer); + + 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); } diff --git a/libguile/foreign.h b/libguile/foreign.h index a162d5d76..4712d761a 100644 --- a/libguile/foreign.h +++ b/libguile/foreign.h @@ -26,20 +26,13 @@ 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_FLOAT, + SCM_FOREIGN_TYPE_VOID, + SCM_FOREIGN_TYPE_FLOAT, SCM_FOREIGN_TYPE_DOUBLE, SCM_FOREIGN_TYPE_UINT8, SCM_FOREIGN_TYPE_INT8, @@ -50,55 +43,32 @@ 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 *); #define SCM_FOREIGN_P(x) \ (!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) -#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_HAS_FINALIZER(x) \ +#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); diff --git a/libguile/gsubr.c b/libguile/gsubr.c index de4bff69f..ed8febd7b 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -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), diff --git a/libguile/gsubr.h b/libguile/gsubr.h index e94d0d0ad..690725221 100644 --- a/libguile/gsubr.h +++ b/libguile/gsubr.h @@ -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)) + +#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) \ (*SCM_SUBR_GENERIC (x) = (g)) diff --git a/libguile/snarf.h b/libguile/snarf.h index 360cb9483..9aa99d0ba 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -361,10 +361,8 @@ 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, ptr) \ - SCM_IMMUTABLE_CELL (c_name, \ - scm_tc7_foreign | (SCM_FOREIGN_TYPE_VOID << 8), \ - ptr) +#define SCM_IMMUTABLE_FOREIGN(c_name, 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) \ diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 958f8b9c3..8944c8415 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -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 (); diff --git a/module/system/foreign.scm b/module/system/foreign.scm index 692dd92e6..9966c640b 100644 --- a/module/system/foreign.scm +++ b/module/system/foreign.scm @@ -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!) diff --git a/test-suite/standalone/test-ffi b/test-suite/standalone/test-ffi index 7c859f2d3..0466b2ff3 100755 --- a/test-suite/standalone/test-ffi +++ b/test-suite/standalone/test-ffi @@ -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"))))) diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test index 10fdf4626..7ff14ccff 100644 --- a/test-suite/tests/foreign.test +++ b/test-suite/tests/foreign.test @@ -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 "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 identity" + (eq? %null-pointer (make-pointer 0))) + + (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))))) |