mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 01:00:20 +02:00
Code Activity

Use "pointer" instead of "foreign" when dealing with wrapped pointers.

Browse source 
* libguile/foreign.h (scm_t_foreign_finalizer): Rename to...
  (scm_t_pointer_finalizer): ... this.
  (SCM_FOREIGN_P): Rename to...
  (SCM_POINTER_P): this.
  (SCM_VALIDATE_FOREIGN): Rename to...
  (SCM_VALIDATE_POINTER): ... this.
  (SCM_FOREIGN_HAS_FINALIZER): Rename to...
  (SCM_POINTER_HAS_FINALIZER): ... this.
  (scm_take_foreign_pointer): Rename to...
  (scm_from_pointer): ... this.
  (scm_foreign_address): Rename to...
  (scm_pointer_address): ... this.
  (scm_foreign_to_bytevector): Rename to...
  (scm_pointer_to_bytevector): ... this.
  (scm_foreign_set_finalizer_x): Rename to...
  (scm_set_pointer_finalizer_x): ... this.
  (scm_bytevector_to_foreign): Rename to...
  (scm_bytevector_to_pointer): ... this.
  (scm_i_foreign_print): Rename to...
  (scm_i_pointer_print): ... this.

* libguile/foreign.c: Update accordingly.

* libguile/tags.h (scm_tc7_foreign): Rename to...
  (scm_tc7_pointer): ... this.

* libguile/foreign.c, libguile/deprecated.c, libguile/dynl.c,
  libguile/evalext.c, libguile/gc.c, libguile/goops.c, libguile/gsubr.c,
  libguile/gsubr.h, libguile/print.c, libguile/snarf.h,
  libguile/vm-i-system.c, module/system/foreign.scm,
  test-suite/standalone/test-ffi, test-suite/tests/foreign.test: Update
  accordingly.
This commit is contained in:
Ludovic Courtès 2010-07-27 14:54:53 +02:00
parent 9defb64118
commit 5b46a8c2c8
16 changed files with 127 additions and 126 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 (SCM_ARG1, func); SCM_VALIDATE_POINTER (SCM_ARG1, func);
fptr = SCM_FOREIGN_POINTER (func); fptr = SCM_POINTER_VALUE (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++)

8
libguile/dynl.c
View file

@ -268,7 +268,7 @@ SCM_DEFINE (scm_dynamic_pointer, "dynamic-pointer", 2, 0, 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 (val, NULL); return scm_from_pointer (val, NULL);
} }
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -311,13 +311,13 @@ SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0,
"and its return value is ignored.") "and its return value is ignored.")
#define FUNC_NAME s_scm_dynamic_call #define FUNC_NAME s_scm_dynamic_call
{ {
void (*fptr) (); void (*fptr) (void);
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 (SCM_ARG1, func); SCM_VALIDATE_POINTER (SCM_ARG1, func);
fptr = SCM_FOREIGN_POINTER (func); fptr = SCM_POINTER_VALUE (func);
fptr (); fptr ();
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }

2
libguile/evalext.c
View file

@ -77,7 +77,7 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0,
{ {
case scm_tc7_vector: case scm_tc7_vector:
case scm_tc7_wvect: case scm_tc7_wvect:
case scm_tc7_foreign: case scm_tc7_pointer:
case scm_tc7_hashtable: case scm_tc7_hashtable:
case scm_tc7_fluid: case scm_tc7_fluid:
case scm_tc7_dynamic_state: case scm_tc7_dynamic_state:

123
libguile/foreign.c
View file

@ -82,19 +82,19 @@ null_pointer_error (const char *func_name)
static SCM cif_to_procedure (SCM cif, SCM func_ptr); static SCM cif_to_procedure (SCM cif, SCM func_ptr);
static SCM foreign_weak_refs = SCM_BOOL_F; static SCM pointer_weak_refs = SCM_BOOL_F;
static void static void
register_weak_reference (SCM from, SCM to) register_weak_reference (SCM from, SCM to)
{ {
scm_hashq_set_x (foreign_weak_refs, from, to); scm_hashq_set_x (pointer_weak_refs, from, to);
} }
static void static void
foreign_finalizer_trampoline (GC_PTR ptr, GC_PTR data) pointer_finalizer_trampoline (GC_PTR ptr, GC_PTR data)
{ {
scm_t_foreign_finalizer finalizer = data; scm_t_pointer_finalizer finalizer = data;
finalizer (SCM_FOREIGN_POINTER (PTR2SCM (ptr))); finalizer (SCM_POINTER_VALUE (PTR2SCM (ptr)));
} }
SCM_DEFINE (scm_make_pointer, "make-pointer", 1, 1, 0, SCM_DEFINE (scm_make_pointer, "make-pointer", 1, 1, 0,
@ -114,26 +114,26 @@ SCM_DEFINE (scm_make_pointer, "make-pointer", 1, 1, 0,
c_finalizer = NULL; c_finalizer = NULL;
else else
{ {
SCM_VALIDATE_FOREIGN (2, finalizer); SCM_VALIDATE_POINTER (2, finalizer);
c_finalizer = SCM_FOREIGN_POINTER (finalizer); c_finalizer = SCM_POINTER_VALUE (finalizer);
} }
if (c_address == 0 && c_finalizer == NULL) if (c_address == 0 && c_finalizer == NULL)
result = null_pointer; result = null_pointer;
else else
result = scm_take_foreign_pointer ((void *) c_address, c_finalizer); result = scm_from_pointer ((void *) c_address, c_finalizer);
return result; return result;
} }
#undef FUNC_NAME #undef FUNC_NAME
SCM SCM
scm_take_foreign_pointer (void *ptr, scm_t_foreign_finalizer finalizer) scm_from_pointer (void *ptr, scm_t_pointer_finalizer finalizer)
{ {
SCM ret; SCM ret;
scm_t_bits word0; scm_t_bits word0;
word0 = scm_tc7_foreign | (finalizer ? (1 << 16UL) : 0UL); word0 = scm_tc7_pointer | (finalizer ? (1 << 16UL) : 0UL);
ret = scm_cell (word0, (scm_t_bits) ptr); ret = scm_cell (word0, (scm_t_bits) ptr);
if (finalizer) if (finalizer)
@ -142,7 +142,7 @@ scm_take_foreign_pointer (void *ptr, scm_t_foreign_finalizer finalizer)
GC_finalization_proc prev_finalizer; GC_finalization_proc prev_finalizer;
GC_PTR prev_finalizer_data; GC_PTR prev_finalizer_data;
GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret), GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret),
foreign_finalizer_trampoline, pointer_finalizer_trampoline,
finalizer, finalizer,
&prev_finalizer, &prev_finalizer,
&prev_finalizer_data); &prev_finalizer_data);
@ -151,37 +151,36 @@ scm_take_foreign_pointer (void *ptr, scm_t_foreign_finalizer finalizer)
return ret; return ret;
} }
SCM_DEFINE (scm_foreign_address, "foreign-address", 1, 0, 0, SCM_DEFINE (scm_pointer_address, "pointer-address", 1, 0, 0,
(SCM foreign), (SCM pointer),
"Return the numerical value of @var{foreign}.") "Return the numerical value of @var{pointer}.")
#define FUNC_NAME s_scm_foreign_address #define FUNC_NAME s_scm_pointer_address
{ {
SCM_VALIDATE_FOREIGN (1, foreign); SCM_VALIDATE_POINTER (1, pointer);
return scm_from_uintptr ((scm_t_uintptr) SCM_FOREIGN_POINTER (foreign)); return scm_from_uintptr ((scm_t_uintptr) SCM_POINTER_VALUE (pointer));
} }
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE (scm_dereference_pointer, "dereference-pointer", 1, 0, 0, SCM_DEFINE (scm_dereference_pointer, "dereference-pointer", 1, 0, 0,
(SCM foreign), (SCM pointer),
"Return the a foreign object representing the pointer " "Return the a pointer object representing the pointer "
"pointed to by @var{foreign}.") "pointed to by @var{pointer}.")
#define FUNC_NAME s_scm_dereference_pointer #define FUNC_NAME s_scm_dereference_pointer
{ {
SCM_VALIDATE_FOREIGN (1, foreign); SCM_VALIDATE_POINTER (1, pointer);
return scm_take_foreign_pointer (* (void **) SCM_FOREIGN_POINTER (foreign), return scm_from_pointer (* (void **) SCM_POINTER_VALUE (pointer), NULL);
NULL);
} }
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE (scm_foreign_to_bytevector, "foreign->bytevector", 2, 2, 0, SCM_DEFINE (scm_pointer_to_bytevector, "pointer->bytevector", 2, 2, 0,
(SCM foreign, SCM len, SCM offset, SCM uvec_type), (SCM pointer, SCM len, SCM offset, SCM uvec_type),
"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{pointer}.\n\n"
"@var{foreign} must be a void pointer, a foreign whose type is\n" "@var{pointer} must be a void pointer, a pointer whose type is\n"
"@var{void}. By default, the resulting bytevector will alias\n" "@var{void}. By default, the resulting bytevector will alias\n"
"all of the memory pointed to by @var{foreign}, from beginning\n" "all of the memory pointed to by @var{pointer}, from beginning\n"
"to end, treated as a @code{vu8} array.\n\n" "to end, treated as a @code{vu8} array.\n\n"
"The user may specify an alternate default interpretation for\n" "The user may specify an alternate default interpretation for\n"
"the memory by passing the @var{uvec_type} argument, to indicate\n" "the memory by passing the @var{uvec_type} argument, to indicate\n"
@ -192,15 +191,15 @@ SCM_DEFINE (scm_foreign_to_bytevector, "foreign->bytevector", 2, 2, 0,
"Users may also specify that the bytevector should only alias a\n" "Users may also specify that the bytevector should only alias a\n"
"subset of the memory, by specifying @var{offset} and @var{len}\n" "subset of the memory, by specifying @var{offset} and @var{len}\n"
"arguments.") "arguments.")
#define FUNC_NAME s_scm_foreign_to_bytevector #define FUNC_NAME s_scm_pointer_to_bytevector
{ {
SCM ret; SCM ret;
scm_t_int8 *ptr; scm_t_int8 *ptr;
size_t boffset, blen; size_t boffset, blen;
scm_t_array_element_type btype; scm_t_array_element_type btype;
SCM_VALIDATE_FOREIGN (1, foreign); SCM_VALIDATE_POINTER (1, pointer);
ptr = SCM_FOREIGN_POINTER (foreign); ptr = SCM_POINTER_VALUE (pointer);
if (SCM_UNLIKELY (ptr == NULL)) if (SCM_UNLIKELY (ptr == NULL))
null_pointer_error (FUNC_NAME); null_pointer_error (FUNC_NAME);
@ -244,22 +243,22 @@ SCM_DEFINE (scm_foreign_to_bytevector, "foreign->bytevector", 2, 2, 0,
blen = scm_to_size_t (len); 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, pointer);
return ret; return ret;
} }
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE (scm_bytevector_to_foreign, "bytevector->foreign", 1, 2, 0, SCM_DEFINE (scm_bytevector_to_pointer, "bytevector->pointer", 1, 2, 0,
(SCM bv, SCM offset, SCM len), (SCM bv, SCM offset, SCM len),
"Return a foreign pointer aliasing the memory pointed to by\n" "Return a pointer pointer aliasing the memory pointed to by\n"
"@var{bv}.\n\n" "@var{bv}.\n\n"
"The resulting foreign will be a void pointer, a foreign whose\n" "The resulting pointer will be a void pointer, a pointer whose\n"
"type is @code{void}. By default it will alias all of the\n" "type is @code{void}. By default it will alias all of the\n"
"memory pointed to by @var{bv}, from beginning to end.\n\n" "memory pointed to by @var{bv}, from beginning to end.\n\n"
"Users may explicily specify that the foreign should only alias a\n" "Users may explicily specify that the pointer should only alias a\n"
"subset of the memory, by specifying @var{offset} and @var{len}\n" "subset of the memory, by specifying @var{offset} and @var{len}\n"
"arguments.") "arguments.")
#define FUNC_NAME s_scm_bytevector_to_foreign #define FUNC_NAME s_scm_bytevector_to_pointer
{ {
SCM ret; SCM ret;
scm_t_int8 *ptr; scm_t_int8 *ptr;
@ -280,33 +279,33 @@ 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 (ptr + boffset, NULL); ret = scm_from_pointer (ptr + boffset, NULL);
register_weak_reference (ret, bv); register_weak_reference (ret, bv);
return ret; return ret;
} }
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE (scm_foreign_set_finalizer_x, "foreign-set-finalizer!", 2, 0, 0, SCM_DEFINE (scm_set_pointer_finalizer_x, "set-pointer-finalizer!", 2, 0, 0,
(SCM foreign, SCM finalizer), (SCM pointer, SCM finalizer),
"Arrange for the C procedure wrapped by @var{finalizer} to be\n" "Arrange for the C procedure wrapped by @var{finalizer} to be\n"
"called on the pointer wrapped by @var{foreign} when @var{foreign}\n" "called on the pointer wrapped by @var{pointer} when @var{pointer}\n"
"becomes unreachable. Note: the C procedure should not call into\n" "becomes unreachable. Note: the C procedure should not call into\n"
"Scheme. If you need a Scheme finalizer, use guardians.") "Scheme. If you need a Scheme finalizer, use guardians.")
#define FUNC_NAME s_scm_foreign_set_finalizer_x #define FUNC_NAME s_scm_set_pointer_finalizer_x
{ {
void *c_finalizer; void *c_finalizer;
GC_finalization_proc prev_finalizer; GC_finalization_proc prev_finalizer;
GC_PTR prev_finalizer_data; GC_PTR prev_finalizer_data;
SCM_VALIDATE_FOREIGN (1, foreign); SCM_VALIDATE_POINTER (1, pointer);
SCM_VALIDATE_FOREIGN (2, finalizer); SCM_VALIDATE_POINTER (2, finalizer);
c_finalizer = SCM_FOREIGN_POINTER (finalizer); c_finalizer = SCM_POINTER_VALUE (finalizer);
SCM_SET_CELL_WORD_0 (foreign, SCM_CELL_WORD_0 (foreign) | (1<<16)); SCM_SET_CELL_WORD_0 (pointer, SCM_CELL_WORD_0 (pointer) | (1 << 16UL));
GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (foreign), GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (pointer),
foreign_finalizer_trampoline, pointer_finalizer_trampoline,
c_finalizer, c_finalizer,
&prev_finalizer, &prev_finalizer,
&prev_finalizer_data); &prev_finalizer_data);
@ -318,10 +317,10 @@ SCM_DEFINE (scm_foreign_set_finalizer_x, "foreign-set-finalizer!", 2, 0, 0,
void void
scm_i_foreign_print (SCM foreign, SCM port, scm_print_state *pstate) scm_i_pointer_print (SCM pointer, SCM port, scm_print_state *pstate)
{ {
scm_puts ("#<foreign ", port); scm_puts ("#<pointer ", port);
scm_display (scm_foreign_address (foreign), port); scm_display (scm_pointer_address (pointer), port);
scm_putc ('>', port); scm_putc ('>', port);
} }
@ -564,7 +563,7 @@ 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 (2, func_ptr); SCM_VALIDATE_POINTER (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);
@ -594,7 +593,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 (mem, NULL); scm_cif = scm_from_pointer (mem, 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 */
@ -750,7 +749,7 @@ cif_to_procedure (SCM cif, SCM func_ptr)
unsigned int nargs; unsigned int nargs;
SCM objcode, table, ret; SCM objcode, table, ret;
c_cif = (ffi_cif *) SCM_FOREIGN_POINTER (cif); c_cif = (ffi_cif *) SCM_POINTER_VALUE (cif);
nargs = c_cif->nargs; nargs = c_cif->nargs;
if (nargs < 10) if (nargs < 10)
@ -804,10 +803,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:
memcpy (loc, SCM_FOREIGN_POINTER (x), type->size); memcpy (loc, SCM_POINTER_VALUE (x), type->size);
break; break;
case FFI_TYPE_POINTER: case FFI_TYPE_POINTER:
*(void **) loc = SCM_FOREIGN_POINTER (x); *(void **) loc = SCM_POINTER_VALUE (x);
break; break;
default: default:
abort (); abort ();
@ -846,10 +845,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 (mem, NULL); return scm_from_pointer (mem, NULL);
} }
case FFI_TYPE_POINTER: case FFI_TYPE_POINTER:
return scm_take_foreign_pointer (*(void **) loc, NULL); return scm_from_pointer (*(void **) loc, NULL);
default: default:
abort (); abort ();
} }
@ -870,8 +869,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)); cif = SCM_POINTER_VALUE (SCM_CAR (foreign));
func = SCM_FOREIGN_POINTER (SCM_CDR (foreign)); func = SCM_POINTER_VALUE (SCM_CDR (foreign));
/* Argument pointers. */ /* Argument pointers. */
args = alloca (sizeof (void *) * cif->nargs); args = alloca (sizeof (void *) * cif->nargs);
@ -982,7 +981,7 @@ scm_init_foreign (void)
#endif #endif
); );
null_pointer = scm_cell (scm_tc7_foreign, 0); null_pointer = scm_cell (scm_tc7_pointer, 0);
scm_define (sym_null, null_pointer); scm_define (sym_null, null_pointer);
} }
@ -993,7 +992,7 @@ scm_register_foreign (void)
"scm_init_foreign", "scm_init_foreign",
(scm_t_extension_init_func)scm_init_foreign, (scm_t_extension_init_func)scm_init_foreign,
NULL); NULL);
foreign_weak_refs = scm_make_weak_key_hash_table (SCM_UNDEFINED); pointer_weak_refs = scm_make_weak_key_hash_table (SCM_UNDEFINED);
} }
/* /*

34
libguile/foreign.h
View file

@ -21,10 +21,10 @@
#include "libguile/__scm.h" #include "libguile/__scm.h"
/* A foreign value is some value that exists outside of Guile. It is represented /* A "foreign pointer" is a wrapped C pointer. It is represented by a
by a cell whose second word is a pointer. The first word has the cell whose second word is a pointer. The first word has the
scm_tc7_foreign typecode and type of the aliased (pointed-to) value in its `scm_tc7_pointer' type code and a bit saying whether it has an
lower 16 bits. associated finalizer or not.
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. */
@ -47,30 +47,30 @@ enum scm_t_foreign_type
typedef enum scm_t_foreign_type 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_pointer_finalizer) (void *);
#define SCM_FOREIGN_P(x) \ #define SCM_POINTER_P(x) \
(!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_foreign) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_pointer)
#define SCM_VALIDATE_FOREIGN(pos, x) \ #define SCM_VALIDATE_POINTER(pos, x) \
SCM_MAKE_VALIDATE (pos, x, FOREIGN_P) SCM_MAKE_VALIDATE (pos, x, POINTER_P)
#define SCM_FOREIGN_POINTER(x) \ #define SCM_POINTER_VALUE(x) \
((void *) SCM_CELL_WORD_1 (x)) ((void *) SCM_CELL_WORD_1 (x))
#define SCM_FOREIGN_HAS_FINALIZER(x) \ #define SCM_POINTER_HAS_FINALIZER(x) \
((SCM_CELL_WORD_0 (x) >> 16) & 0x1) ((SCM_CELL_WORD_0 (x) >> 16) & 0x1)
SCM_API SCM scm_take_foreign_pointer (void *, scm_t_foreign_finalizer); SCM_API SCM scm_from_pointer (void *, scm_t_pointer_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_address (SCM foreign); SCM_API SCM scm_pointer_address (SCM pointer);
SCM_API SCM scm_foreign_to_bytevector (SCM foreign, SCM type, SCM_API SCM scm_pointer_to_bytevector (SCM pointer, 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_set_pointer_finalizer_x (SCM pointer, SCM finalizer);
SCM_API SCM scm_bytevector_to_foreign (SCM bv, SCM offset, SCM len); SCM_API SCM scm_bytevector_to_pointer (SCM bv, SCM offset, SCM len);
SCM_INTERNAL SCM scm_make_pointer (SCM address, SCM finalizer); SCM_INTERNAL SCM scm_make_pointer (SCM address, SCM finalizer);
SCM_INTERNAL SCM scm_dereference_pointer (SCM pointer); SCM_INTERNAL SCM scm_dereference_pointer (SCM pointer);
SCM_INTERNAL void scm_i_foreign_print (SCM foreign, SCM port, SCM_INTERNAL void scm_i_pointer_print (SCM pointer, SCM port,
scm_print_state *pstate); scm_print_state *pstate);

2
libguile/gc.c
View file

@ -746,7 +746,7 @@ scm_i_tag_name (scm_t_bits tag)
return "cons (immediate car)"; return "cons (immediate car)";
case scm_tcs_cons_nimcar: case scm_tcs_cons_nimcar:
return "cons (non-immediate car)"; return "cons (non-immediate car)";
case scm_tc7_foreign: case scm_tc7_pointer:
return "foreign"; return "foreign";
case scm_tc7_hashtable: case scm_tc7_hashtable:
return "hashtable"; return "hashtable";

2
libguile/goops.c
View file

@ -221,7 +221,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
case scm_tc7_vector: case scm_tc7_vector:
case scm_tc7_wvect: case scm_tc7_wvect:
return scm_class_vector; return scm_class_vector;
case scm_tc7_foreign: case scm_tc7_pointer:
return class_foreign; return class_foreign;
case scm_tc7_hashtable: case scm_tc7_hashtable:
return class_hashtable; return class_hashtable;

5
libguile/gsubr.c
View file

@ -793,12 +793,11 @@ create_gsubr (int define, const char *name,
/* make objtable */ /* make objtable */
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_from_pointer (fcn, NULL));
scm_take_foreign_pointer (fcn, 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 (generic_loc, NULL)); scm_from_pointer (generic_loc, 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),

4
libguile/gsubr.h
View file

@ -46,13 +46,13 @@ SCM_API SCM scm_subr_objcode_trampoline (unsigned int nreq,
#define SCM_SUBRF(x) \ #define SCM_SUBRF(x) \
((SCM (*) (void)) \ ((SCM (*) (void)) \
SCM_FOREIGN_POINTER (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 0))) SCM_POINTER_VALUE (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) \ #define SCM_SUBR_GENERIC(x) \
((SCM *) \ ((SCM *) \
SCM_FOREIGN_POINTER (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 2))) SCM_POINTER_VALUE (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))

4
libguile/print.c
View file

@ -751,8 +751,8 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
case scm_tc7_program: case scm_tc7_program:
scm_i_program_print (exp, port, pstate); scm_i_program_print (exp, port, pstate);
break; break;
case scm_tc7_foreign: case scm_tc7_pointer:
scm_i_foreign_print (exp, port, pstate); scm_i_pointer_print (exp, port, pstate);
break; break;
case scm_tc7_hashtable: case scm_tc7_hashtable:
scm_i_hashtable_print (exp, port, pstate); scm_i_hashtable_print (exp, port, pstate);

6
libguile/snarf.h
View file

@ -105,7 +105,7 @@ SCM_SYMBOL (scm_i_paste (FNAME, __name), PRIMNAME); \
SCM_SNARF_HERE( \ SCM_SNARF_HERE( \
static const char scm_i_paste (s_, FNAME) [] = PRIMNAME; \ static const char scm_i_paste (s_, FNAME) [] = PRIMNAME; \
SCM_API SCM FNAME ARGLIST; \ SCM_API SCM FNAME ARGLIST; \
SCM_IMMUTABLE_FOREIGN (scm_i_paste (FNAME, __subr_foreign), \ SCM_IMMUTABLE_POINTER (scm_i_paste (FNAME, __subr_foreign), \
(scm_t_bits) &FNAME); /* the subr */ \ (scm_t_bits) &FNAME); /* the subr */ \
SCM_STATIC_SUBR_OBJVECT (scm_i_paste (FNAME, __raw_objtable), \ SCM_STATIC_SUBR_OBJVECT (scm_i_paste (FNAME, __raw_objtable), \
/* FIXME: directly be the foreign */ \ /* FIXME: directly be the foreign */ \
@ -361,8 +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_POINTER(c_name, ptr) \
SCM_IMMUTABLE_CELL (c_name, scm_tc7_foreign, ptr) SCM_IMMUTABLE_CELL (c_name, scm_tc7_pointer, 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/tags.h
View file

@ -411,7 +411,7 @@ typedef scm_t_uintptr scm_t_bits;
#define scm_tc7_stringbuf 39 #define scm_tc7_stringbuf 39
#define scm_tc7_bytevector 77 #define scm_tc7_bytevector 77
#define scm_tc7_foreign 31 #define scm_tc7_pointer 31
#define scm_tc7_hashtable 29 #define scm_tc7_hashtable 29
#define scm_tc7_fluid 37 #define scm_tc7_fluid 37
#define scm_tc7_dynamic_state 45 #define scm_tc7_dynamic_state 45

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

@ -840,12 +840,13 @@ VM_DEFINE_INSTRUCTION (55, tail_call, "tail-call", 1, -1, 1)
VM_DEFINE_INSTRUCTION (56, subr_call, "subr-call", 1, -1, -1) VM_DEFINE_INSTRUCTION (56, subr_call, "subr-call", 1, -1, -1)
{ {
SCM foreign, ret; SCM pointer, ret;
SCM (*subr)(); SCM (*subr)();
nargs = FETCH ();
POP (foreign);
subr = SCM_FOREIGN_POINTER (foreign); nargs = FETCH ();
POP (pointer);
subr = SCM_POINTER_VALUE (pointer);
VM_HANDLE_INTERRUPTS; VM_HANDLE_INTERRUPTS;
SYNC_REGISTER (); SYNC_REGISTER ();

14
module/system/foreign.scm
View file

@ -31,11 +31,13 @@
%null-pointer %null-pointer
null-pointer? null-pointer?
make-pointer make-pointer
foreign-address pointer-address
dereference-pointer dereference-pointer
foreign->bytevector bytevector->foreign pointer->bytevector
foreign-set-finalizer! bytevector->pointer
set-pointer-finalizer!
make-foreign-function make-foreign-function
make-c-struct parse-c-struct)) make-c-struct parse-c-struct))
@ -48,7 +50,7 @@
;;; ;;;
(define (null-pointer? pointer) (define (null-pointer? pointer)
(= (foreign-address pointer) 0)) (= (pointer-address pointer) 0))
@ -118,7 +120,7 @@
(define (make-c-struct types vals) (define (make-c-struct types vals)
(let ((bv (make-bytevector (sizeof types) 0))) (let ((bv (make-bytevector (sizeof types) 0)))
(write-c-struct bv 0 types vals) (write-c-struct bv 0 types vals)
(bytevector->foreign bv))) (bytevector->pointer bv)))
(define (parse-c-struct foreign types) (define (parse-c-struct foreign types)
(read-c-struct (foreign->bytevector foreign) 0 types)) (read-c-struct (pointer->bytevector foreign) 0 types))

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

@ -166,12 +166,12 @@ exec guile -q -s "$0" "$@"
(make-foreign-function '* (dynamic-func "test_ffi_memcpy" lib) (make-foreign-function '* (dynamic-func "test_ffi_memcpy" lib)
(list '* '* int32))) (list '* '* int32)))
(let* ((src* '(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*))) (src (bytevector->pointer (u8-list->bytevector src*)))
(dest (bytevector->foreign (make-bytevector 16 0))) (dest (bytevector->pointer (make-bytevector 16 0)))
(res (f-memcpy dest src (length src*)))) (res (f-memcpy dest src (length src*))))
(or (= (foreign-address dest) (foreign-address res)) (or (= (pointer-address dest) (pointer-address res))
(error "memcpy res not equal to dest")) (error "memcpy res not equal to dest"))
(or (equal? (bytevector->u8-list (foreign->bytevector dest 16)) (or (equal? (bytevector->u8-list (pointer->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")))
@ -197,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 len 0 'u8)) (bv (pointer->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")))))

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

@ -30,7 +30,7 @@
(with-test-prefix "null pointer" (with-test-prefix "null pointer"
(pass-if "zero" (pass-if "zero"
(= 0 (foreign-address %null-pointer))) (= 0 (pointer-address %null-pointer)))
(pass-if "null pointer identity" (pass-if "null pointer identity"
(eq? %null-pointer (make-pointer 0))) (eq? %null-pointer (make-pointer 0)))
@ -38,29 +38,29 @@
(pass-if "null-pointer? %null-pointer" (pass-if "null-pointer? %null-pointer"
(null-pointer? %null-pointer)) (null-pointer? %null-pointer))
(pass-if-exception "foreign->bytevector %null-pointer" (pass-if-exception "pointer->bytevector %null-pointer"
exception:null-pointer-error exception:null-pointer-error
(foreign->bytevector %null-pointer 7))) (pointer->bytevector %null-pointer 7)))
(with-test-prefix "make-pointer" (with-test-prefix "make-pointer"
(pass-if "address preserved" (pass-if "address preserved"
(= 123 (foreign-address (make-pointer 123))))) (= 123 (pointer-address (make-pointer 123)))))
(with-test-prefix "foreign<->bytevector" (with-test-prefix "pointer<->bytevector"
(pass-if "bijection" (pass-if "bijection"
(let ((bv #vu8(0 1 2 3 4 5 6 7))) (let ((bv #vu8(0 1 2 3 4 5 6 7)))
(equal? (foreign->bytevector (bytevector->foreign bv) (equal? (pointer->bytevector (bytevector->pointer bv)
(bytevector-length bv)) (bytevector-length bv))
bv))) bv)))
(pass-if "pointer from bits" (pass-if "pointer from bits"
(let* ((bytes (iota (sizeof '*))) (let* ((bytes (iota (sizeof '*)))
(bv (u8-list->bytevector bytes))) (bv (u8-list->bytevector bytes)))
(= (foreign-address (= (pointer-address
(make-pointer (bytevector-uint-ref bv 0 (native-endianness) (make-pointer (bytevector-uint-ref bv 0 (native-endianness)
(sizeof '*)))) (sizeof '*))))
(fold-right (lambda (byte address) (fold-right (lambda (byte address)
@ -71,8 +71,8 @@
(pass-if "dereference-pointer" (pass-if "dereference-pointer"
(let* ((bytes (iota (sizeof '*))) (let* ((bytes (iota (sizeof '*)))
(bv (u8-list->bytevector bytes))) (bv (u8-list->bytevector bytes)))
(= (foreign-address (= (pointer-address
(dereference-pointer (bytevector->foreign bv))) (dereference-pointer (bytevector->pointer bv)))
(fold-right (lambda (byte address) (fold-right (lambda (byte address)
(+ byte (* 256 address))) (+ byte (* 256 address)))
0 0