mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-16 16:50:21 +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))
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);
for (argc = 0; argv[argc]; argc++)

10
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);
scm_dynwind_end ();
return scm_take_foreign_pointer (val, NULL);
return scm_from_pointer (val, NULL);
}
}
#undef FUNC_NAME
@ -311,13 +311,13 @@ SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0,
"and its return value is ignored.")
#define FUNC_NAME s_scm_dynamic_call
{
void (*fptr) ();
void (*fptr) (void);
if (scm_is_string (func))
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 ();
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_wvect:
case scm_tc7_foreign:
case scm_tc7_pointer:
case scm_tc7_hashtable:
case scm_tc7_fluid:
case scm_tc7_dynamic_state:

127
libguile/foreign.c
View file

@ -1,5 +1,5 @@
/* Copyright (C) 2010 Free Software Foundation, Inc.
*
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
@ -82,19 +82,19 @@ null_pointer_error (const char *func_name)
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
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
foreign_finalizer_trampoline (GC_PTR ptr, GC_PTR data)
pointer_finalizer_trampoline (GC_PTR ptr, GC_PTR data)
{
scm_t_foreign_finalizer finalizer = data;
finalizer (SCM_FOREIGN_POINTER (PTR2SCM (ptr)));
scm_t_pointer_finalizer finalizer = data;
finalizer (SCM_POINTER_VALUE (PTR2SCM (ptr)));
}
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;
else
{
SCM_VALIDATE_FOREIGN (2, finalizer);
c_finalizer = SCM_FOREIGN_POINTER (finalizer);
SCM_VALIDATE_POINTER (2, finalizer);
c_finalizer = SCM_POINTER_VALUE (finalizer);
}
if (c_address == 0 && c_finalizer == NULL)
result = null_pointer;
else
result = scm_take_foreign_pointer ((void *) c_address, c_finalizer);
result = scm_from_pointer ((void *) c_address, c_finalizer);
return result;
}
#undef FUNC_NAME
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_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);
if (finalizer)
@ -142,7 +142,7 @@ scm_take_foreign_pointer (void *ptr, scm_t_foreign_finalizer finalizer)
GC_finalization_proc prev_finalizer;
GC_PTR prev_finalizer_data;
GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret),
foreign_finalizer_trampoline,
pointer_finalizer_trampoline,
finalizer,
&prev_finalizer,
&prev_finalizer_data);
@ -151,37 +151,36 @@ scm_take_foreign_pointer (void *ptr, scm_t_foreign_finalizer finalizer)
return ret;
}
SCM_DEFINE (scm_foreign_address, "foreign-address", 1, 0, 0,
(SCM foreign),
"Return the numerical value of @var{foreign}.")
#define FUNC_NAME s_scm_foreign_address
SCM_DEFINE (scm_pointer_address, "pointer-address", 1, 0, 0,
(SCM pointer),
"Return the numerical value of @var{pointer}.")
#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
SCM_DEFINE (scm_dereference_pointer, "dereference-pointer", 1, 0, 0,
(SCM foreign),
"Return the a foreign object representing the pointer "
"pointed to by @var{foreign}.")
(SCM pointer),
"Return the a pointer object representing the pointer "
"pointed to by @var{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),
NULL);
return scm_from_pointer (* (void **) SCM_POINTER_VALUE (pointer), NULL);
}
#undef FUNC_NAME
SCM_DEFINE (scm_foreign_to_bytevector, "foreign->bytevector", 2, 2, 0,
(SCM foreign, SCM len, SCM offset, SCM uvec_type),
SCM_DEFINE (scm_pointer_to_bytevector, "pointer->bytevector", 2, 2, 0,
(SCM pointer, 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"
"@var{pointer}.\n\n"
"@var{pointer} must be a void pointer, a pointer whose type is\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"
"The user may specify an alternate default interpretation for\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"
"subset of the memory, by specifying @var{offset} and @var{len}\n"
"arguments.")
#define FUNC_NAME s_scm_foreign_to_bytevector
#define FUNC_NAME s_scm_pointer_to_bytevector
{
SCM ret;
scm_t_int8 *ptr;
size_t boffset, blen;
scm_t_array_element_type btype;
SCM_VALIDATE_FOREIGN (1, foreign);
ptr = SCM_FOREIGN_POINTER (foreign);
SCM_VALIDATE_POINTER (1, pointer);
ptr = SCM_POINTER_VALUE (pointer);
if (SCM_UNLIKELY (ptr == NULL))
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);
ret = scm_c_take_typed_bytevector (ptr + boffset, blen, btype);
register_weak_reference (ret, foreign);
register_weak_reference (ret, pointer);
return ret;
}
#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),
"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"
"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"
"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"
"arguments.")
#define FUNC_NAME s_scm_bytevector_to_foreign
#define FUNC_NAME s_scm_bytevector_to_pointer
{
SCM ret;
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,
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);
return ret;
}
#undef FUNC_NAME
SCM_DEFINE (scm_foreign_set_finalizer_x, "foreign-set-finalizer!", 2, 0, 0,
(SCM foreign, SCM finalizer),
SCM_DEFINE (scm_set_pointer_finalizer_x, "set-pointer-finalizer!", 2, 0, 0,
(SCM pointer, SCM finalizer),
"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"
"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;
GC_finalization_proc prev_finalizer;
GC_PTR prev_finalizer_data;
SCM_VALIDATE_FOREIGN (1, foreign);
SCM_VALIDATE_FOREIGN (2, finalizer);
SCM_VALIDATE_POINTER (1, pointer);
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),
foreign_finalizer_trampoline,
GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (pointer),
pointer_finalizer_trampoline,
c_finalizer,
&prev_finalizer,
&prev_finalizer_data);
@ -318,10 +317,10 @@ SCM_DEFINE (scm_foreign_set_finalizer_x, "foreign-set-finalizer!", 2, 0, 0,
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_display (scm_foreign_address (foreign), port);
scm_puts ("#<pointer ", port);
scm_display (scm_pointer_address (pointer), port);
scm_putc ('>', port);
}
@ -563,8 +562,8 @@ SCM_DEFINE (scm_make_foreign_function, "make-foreign-function", 3, 0, 0,
ffi_cif *cif;
ffi_type **type_ptrs;
ffi_type *types;
SCM_VALIDATE_FOREIGN (2, func_ptr);
SCM_VALIDATE_POINTER (2, func_ptr);
nargs = scm_ilength (arg_types);
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));
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;
/* reuse cif_len to walk through the mem */
@ -750,7 +749,7 @@ cif_to_procedure (SCM cif, SCM func_ptr)
unsigned int nargs;
SCM objcode, table, ret;
c_cif = (ffi_cif *) SCM_FOREIGN_POINTER (cif);
c_cif = (ffi_cif *) SCM_POINTER_VALUE (cif);
nargs = c_cif->nargs;
if (nargs < 10)
@ -804,10 +803,10 @@ unpack (const ffi_type *type, void *loc, SCM x)
*(scm_t_int64 *) loc = scm_to_int64 (x);
break;
case FFI_TYPE_STRUCT:
memcpy (loc, SCM_FOREIGN_POINTER (x), type->size);
memcpy (loc, SCM_POINTER_VALUE (x), type->size);
break;
case FFI_TYPE_POINTER:
*(void **) loc = SCM_FOREIGN_POINTER (x);
*(void **) loc = SCM_POINTER_VALUE (x);
break;
default:
abort ();
@ -846,10 +845,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 (mem, NULL);
return scm_from_pointer (mem, NULL);
}
case FFI_TYPE_POINTER:
return scm_take_foreign_pointer (*(void **) loc, NULL);
return scm_from_pointer (*(void **) loc, NULL);
default:
abort ();
}
@ -870,8 +869,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));
func = SCM_FOREIGN_POINTER (SCM_CDR (foreign));
cif = SCM_POINTER_VALUE (SCM_CAR (foreign));
func = SCM_POINTER_VALUE (SCM_CDR (foreign));
/* Argument pointers. */
args = alloca (sizeof (void *) * cif->nargs);
@ -982,7 +981,7 @@ scm_init_foreign (void)
#endif
);
null_pointer = scm_cell (scm_tc7_foreign, 0);
null_pointer = scm_cell (scm_tc7_pointer, 0);
scm_define (sym_null, null_pointer);
}
@ -993,7 +992,7 @@ scm_register_foreign (void)
"scm_init_foreign",
(scm_t_extension_init_func)scm_init_foreign,
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"
/* A foreign value is some value that exists outside of Guile. It is represented
by a cell whose second word is a pointer. The first word has the
scm_tc7_foreign typecode and type of the aliased (pointed-to) value in its
lower 16 bits.
/* A "foreign pointer" is a wrapped C pointer. It is represented by a
cell whose second word is a pointer. The first word has the
`scm_tc7_pointer' type code and a bit saying whether it has an
associated finalizer or not.
The basic idea is that we can help the programmer to avoid cutting herself,
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 void (*scm_t_foreign_finalizer) (void *);
typedef void (*scm_t_pointer_finalizer) (void *);
#define SCM_FOREIGN_P(x) \
(!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_POINTER(x) \
#define SCM_POINTER_P(x) \
(!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_pointer)
#define SCM_VALIDATE_POINTER(pos, x) \
SCM_MAKE_VALIDATE (pos, x, POINTER_P)
#define SCM_POINTER_VALUE(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_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_sizeof (SCM type);
SCM_API SCM scm_foreign_address (SCM foreign);
SCM_API SCM scm_foreign_to_bytevector (SCM foreign, SCM type,
SCM_API SCM scm_pointer_address (SCM pointer);
SCM_API SCM scm_pointer_to_bytevector (SCM pointer, 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_API SCM scm_set_pointer_finalizer_x (SCM pointer, SCM finalizer);
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_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);

2
libguile/gc.c
View file

@ -746,7 +746,7 @@ scm_i_tag_name (scm_t_bits tag)
return "cons (immediate car)";
case scm_tcs_cons_nimcar:
return "cons (non-immediate car)";
case scm_tc7_foreign:
case scm_tc7_pointer:
return "foreign";
case scm_tc7_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_wvect:
return scm_class_vector;
case scm_tc7_foreign:
case scm_tc7_pointer:
return class_foreign;
case scm_tc7_hashtable:
return class_hashtable;

5
libguile/gsubr.c
View file

@ -793,12 +793,11 @@ create_gsubr (int define, const char *name,
/* make objtable */
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 (fcn, NULL));
SCM_SIMPLE_VECTOR_SET (table, 0, scm_from_pointer (fcn, NULL));
SCM_SIMPLE_VECTOR_SET (table, 1, sname);
if (generic_loc)
SCM_SIMPLE_VECTOR_SET (table, 2,
scm_take_foreign_pointer (generic_loc, NULL));
scm_from_pointer (generic_loc, NULL));
/* make program */
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) \
((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_GENERIC(x) \
((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) \
(*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:
scm_i_program_print (exp, port, pstate);
break;
case scm_tc7_foreign:
scm_i_foreign_print (exp, port, pstate);
case scm_tc7_pointer:
scm_i_pointer_print (exp, port, pstate);
break;
case scm_tc7_hashtable:
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( \
static const char scm_i_paste (s_, FNAME) [] = PRIMNAME; \
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_STATIC_SUBR_OBJVECT (scm_i_paste (FNAME, __raw_objtable), \
/* 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) sizeof (contents) - 1)
#define SCM_IMMUTABLE_FOREIGN(c_name, ptr) \
SCM_IMMUTABLE_CELL (c_name, scm_tc7_foreign, ptr)
#define SCM_IMMUTABLE_POINTER(c_name, ptr) \
SCM_IMMUTABLE_CELL (c_name, scm_tc7_pointer, ptr)
/* for primitive-generics, add a foreign to the end */
#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_bytevector 77
#define scm_tc7_foreign 31
#define scm_tc7_pointer 31
#define scm_tc7_hashtable 29
#define scm_tc7_fluid 37
#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)
{
SCM foreign, ret;
SCM pointer, ret;
SCM (*subr)();
nargs = FETCH ();
POP (foreign);
subr = SCM_FOREIGN_POINTER (foreign);
nargs = FETCH ();
POP (pointer);
subr = SCM_POINTER_VALUE (pointer);
VM_HANDLE_INTERRUPTS;
SYNC_REGISTER ();

14
module/system/foreign.scm
View file

@ -31,11 +31,13 @@
%null-pointer
null-pointer?
make-pointer
foreign-address
pointer-address
dereference-pointer
foreign->bytevector bytevector->foreign
foreign-set-finalizer!
pointer->bytevector
bytevector->pointer
set-pointer-finalizer!
make-foreign-function
make-c-struct parse-c-struct))
@ -48,7 +50,7 @@
;;;
(define (null-pointer? pointer)
(= (foreign-address pointer) 0))
(= (pointer-address pointer) 0))
@ -118,7 +120,7 @@
(define (make-c-struct types vals)
(let ((bv (make-bytevector (sizeof types) 0)))
(write-c-struct bv 0 types vals)
(bytevector->foreign bv)))
(bytevector->pointer bv)))
(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)
(list '* '* int32)))
(let* ((src* '(0 1 2 3 4 5 6 7))
(src (bytevector->foreign (u8-list->bytevector src*)))
(dest (bytevector->foreign (make-bytevector 16 0)))
(src (bytevector->pointer (u8-list->bytevector src*)))
(dest (bytevector->pointer (make-bytevector 16 0)))
(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"))
(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))
(error "unexpected dest")))
@ -197,7 +197,7 @@ exec guile -q -s "$0" "$@"
(let* ((ptr (strerror ENOENT))
(len (strlen ptr))
(bv (foreign->bytevector ptr len 0 'u8))
(bv (pointer->bytevector ptr len 0 'u8))
(str (utf8->string bv)))
(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"
(pass-if "zero"
(= 0 (foreign-address %null-pointer)))
(= 0 (pointer-address %null-pointer)))
(pass-if "null pointer identity"
(eq? %null-pointer (make-pointer 0)))
@ -38,29 +38,29 @@
(pass-if "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
(foreign->bytevector %null-pointer 7)))
(pointer->bytevector %null-pointer 7)))
(with-test-prefix "make-pointer"
(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"
(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))
bv)))
(pass-if "pointer from bits"
(let* ((bytes (iota (sizeof '*)))
(bv (u8-list->bytevector bytes)))
(= (foreign-address
(= (pointer-address
(make-pointer (bytevector-uint-ref bv 0 (native-endianness)
(sizeof '*))))
(fold-right (lambda (byte address)
@ -71,8 +71,8 @@
(pass-if "dereference-pointer"
(let* ((bytes (iota (sizeof '*)))
(bv (u8-list->bytevector bytes)))
(= (foreign-address
(dereference-pointer (bytevector->foreign bv)))
(= (pointer-address
(dereference-pointer (bytevector->pointer bv)))
(fold-right (lambda (byte address)
(+ byte (* 256 address)))
0