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

foreign.h presents a more pointer-centric interface

Browse source 
* libguile/foreign.c:
* libguile/foreign.h: Rework interface to be more pointer-centric.
  Details are:
  (SCM_FOREIGN_TYPE_STRUCT, SCM_FOREIGN_TYPE_POINTER): Removed; now the
  pointer in a foreign is first-class. If it points to a native type
  like uint32, then it still has a tag; but if it points to something
  else, like a struct or a pointer or something, then its type is VOID
  (i.e., void*).
  (SCM_FOREIGN_POINTER): Rename from SCM_FOREIGN_OBJECT.
  (SCM_FOREIGN_VALUE_REF, SCM_FOREIGN_VALUE_SET): Rename from
  SCM_FOREIGN_OBJECT_REF and SCM_FOREIGN_OBJECT_SET, to indicate that
  they only work with value types.
  (SCM_FOREIGN_HAS_FINALIZER): Reserve a bit to indicate if the foreign
  pointer in question has a finalizer registered.
  (SCM_FOREIGN_LEN): For void* pointers, optionally store the length in
  bytes of the associated memory region.
  (SCM_FOREIGN_VALUE_P): Rename from SCM_FOREIGN_SIMPLE_P.
  (SCM_VALIDATE_FOREIGN_VALUE): Rename from SCM_VALIDATE_FOREIGN_SIMPLE.
  (scm_take_foreign_pointer): Rename from scm_c_take_foreign. Remove
  scm_c_from_foreign.
  (scm_foreign_type): New accessor.
  (scm_foreign_ref, scm_foreign_set_x): Take some optional args, used
  when dereferencing void pointers.

* libguile/dynl.h:
* libguile/dynl.c (scm_dynamic_pointer): New function, used by
  scm_dynamic_func. Adapt code to foreign.h changes.

* libguile/goops.c (scm_enable_primitive_generic_x)
  (scm_set_primitive_generic_x): Use the SCM_SET_SUBR_GENERIC macro.

* libguile/gsubr.c (create_gsubr): Adapt to API change.
* libguile/gsubr.h (SCM_SUBRF, SCM_SUBR_GENERIC): Store the pointer
  directly, not indirected.

* libguile/snarf.h (SCM_DEFINE, SCM_IMMUTABLE_FOREIGN): Store subr
  pointers directly. Adapt to SCM_FOREIGN_TYPE_VOID change.

* libguile/vm-i-system.c (subr-call): Access the void* directly.
This commit is contained in:
Andy Wingo 2010-01-18 11:42:35 +01:00
parent 75c242a256
commit 52fd9639fd
9 changed files with 259 additions and 183 deletions
Download patch file Download diff file Expand all files Collapse all files

75
libguile/dynl.c
View file

@ -100,7 +100,7 @@ sysdep_dynl_unlink (void *handle, const char *subr)
} }
static void * static void *
sysdep_dynl_func (const char *symb, void *handle, const char *subr) sysdep_dynl_value (const char *symb, void *handle, const char *subr)
{ {
void *fptr; void *fptr;
@ -214,6 +214,49 @@ SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0,
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE (scm_dynamic_pointer, "dynamic-pointer", 3, 1, 0,
(SCM name, SCM type, SCM dobj, SCM len),
"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 vm ffi)} module.\n\n"
"This facility works by asking the operating system 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"
"careful to ensure that the value actually is of the\n"
"declared type, or bad things will happen.\n\n"
"Regardless whether your C compiler prepends an underscore\n"
"@samp{_} to the global names in a program, you should\n"
"@strong{not} include this underscore in @var{name}\n"
"since it will be added automatically when necessary.")
#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);
/*fixme* GC-problem */
SCM_VALIDATE_SMOB (SCM_ARG3, dobj, dynamic_obj);
if (DYNL_HANDLE (dobj) == NULL) {
SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
} else {
char *chars;
scm_dynwind_begin (0);
chars = scm_to_locale_string (name);
scm_dynwind_free (chars);
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);
}
}
#undef FUNC_NAME
SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0, SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
(SCM name, SCM dobj), (SCM name, SCM dobj),
"Return a ``handle'' for the function @var{name} in the\n" "Return a ``handle'' for the function @var{name} in the\n"
@ -226,24 +269,10 @@ SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
"since it will be added automatically when necessary.") "since it will be added automatically when necessary.")
#define FUNC_NAME s_scm_dynamic_func #define FUNC_NAME s_scm_dynamic_func
{ {
void (*func) (); return scm_dynamic_pointer (name,
scm_from_uint (SCM_FOREIGN_TYPE_VOID),
SCM_VALIDATE_STRING (1, name); dobj,
/*fixme* GC-problem */ SCM_UNDEFINED);
SCM_VALIDATE_SMOB (SCM_ARG2, dobj, dynamic_obj);
if (DYNL_HANDLE (dobj) == NULL) {
SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
} else {
char *chars;
scm_dynwind_begin (0);
chars = scm_to_locale_string (name);
scm_dynwind_free (chars);
func = (void (*) ()) sysdep_dynl_func (chars, DYNL_HANDLE (dobj),
FUNC_NAME);
scm_dynwind_end ();
return scm_c_from_foreign (SCM_FOREIGN_TYPE_POINTER, &func, 0, NULL);
}
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -272,9 +301,9 @@ SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0,
if (scm_is_string (func)) if (scm_is_string (func))
func = scm_dynamic_func (func, dobj); func = scm_dynamic_func (func, dobj);
SCM_VALIDATE_FOREIGN_TYPED (SCM_ARG1, func, POINTER); SCM_VALIDATE_FOREIGN_TYPED (SCM_ARG1, func, VOID);
fptr = SCM_FOREIGN_OBJECT_REF (func, void*); fptr = SCM_FOREIGN_POINTER (func, void);
fptr (); fptr ();
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
@ -302,9 +331,9 @@ SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0,
if (scm_is_string (func)) if (scm_is_string (func))
func = scm_dynamic_func (func, dobj); func = scm_dynamic_func (func, dobj);
SCM_VALIDATE_FOREIGN_TYPED (SCM_ARG1, func, POINTER); SCM_VALIDATE_FOREIGN_TYPED (SCM_ARG1, func, VOID);
fptr = SCM_FOREIGN_OBJECT_REF (func, void*); fptr = SCM_FOREIGN_POINTER (func, void);
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++)

3
libguile/dynl.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_DYNL_H #ifndef SCM_DYNL_H
#define SCM_DYNL_H #define SCM_DYNL_H
/* Copyright (C) 1996,1998,2000,2001, 2006, 2008 Free Software Foundation, Inc. /* Copyright (C) 1996,1998,2000,2001, 2006, 2008, 2010 Free Software Foundation, Inc.
* *
* This library is free software; you can redistribute it and/or * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * modify it under the terms of the GNU Lesser General Public License
@ -30,6 +30,7 @@
SCM_API SCM scm_dynamic_link (SCM fname); SCM_API SCM scm_dynamic_link (SCM fname);
SCM_API SCM scm_dynamic_unlink (SCM dobj); SCM_API SCM scm_dynamic_unlink (SCM dobj);
SCM_API SCM scm_dynamic_object_p (SCM obj); SCM_API SCM scm_dynamic_object_p (SCM obj);
SCM_API SCM scm_dynamic_pointer (SCM name, SCM type, SCM dobj, SCM len);
SCM_API SCM scm_dynamic_func (SCM symb, SCM dobj); SCM_API SCM scm_dynamic_func (SCM symb, SCM dobj);
SCM_API SCM scm_dynamic_call (SCM symb, SCM dobj); SCM_API SCM scm_dynamic_call (SCM symb, SCM dobj);
SCM_API SCM scm_dynamic_args_call (SCM symb, SCM dobj, SCM args); SCM_API SCM scm_dynamic_args_call (SCM symb, SCM dobj, SCM args);

268
libguile/foreign.c
View file

@ -26,79 +26,29 @@
static size_t
sizeof_type (scm_t_foreign_type type)
{
switch (type)
{
case SCM_FOREIGN_TYPE_VOID: abort ();
case SCM_FOREIGN_TYPE_FLOAT: return sizeof(float);
case SCM_FOREIGN_TYPE_DOUBLE: return sizeof(double);
case SCM_FOREIGN_TYPE_UINT8: return sizeof(scm_t_uint8);
case SCM_FOREIGN_TYPE_INT8: return sizeof(scm_t_int8);
case SCM_FOREIGN_TYPE_UINT16: return sizeof(scm_t_uint16);
case SCM_FOREIGN_TYPE_INT16: return sizeof(scm_t_int16);
case SCM_FOREIGN_TYPE_UINT32: return sizeof(scm_t_uint32);
case SCM_FOREIGN_TYPE_INT32: return sizeof(scm_t_int32);
case SCM_FOREIGN_TYPE_UINT64: return sizeof(scm_t_uint64);
case SCM_FOREIGN_TYPE_INT64: return sizeof(scm_t_int64);
case SCM_FOREIGN_TYPE_STRUCT: abort ();
case SCM_FOREIGN_TYPE_POINTER: return sizeof(void*);
default: abort ();
}
}
static void static void
foreign_finalizer_trampoline (GC_PTR ptr, GC_PTR data) foreign_finalizer_trampoline (GC_PTR ptr, GC_PTR data)
{ {
scm_t_foreign_finalizer finalizer = data; scm_t_foreign_finalizer finalizer = data;
finalizer (SCM_FOREIGN_OBJECT (PTR2SCM (ptr), void*)); finalizer (SCM_FOREIGN_POINTER (PTR2SCM (ptr), void));
} }
SCM SCM
scm_c_from_foreign (scm_t_foreign_type type, void *val, size_t size, scm_take_foreign_pointer (scm_t_foreign_type type, void *ptr, size_t len,
scm_t_foreign_finalizer finalizer) scm_t_foreign_finalizer finalizer)
{ {
SCM ret; SCM ret;
if (!size) scm_t_bits word0;
size = sizeof_type (type);
ret = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_bits) * 2 + size, word0 = (scm_t_bits)(scm_tc7_foreign | (type<<8)
"foreign")); | (finalizer ? (1<<16) : 0) | (len<<17));
SCM_SET_CELL_WORD_0 (ret, (scm_t_bits)(scm_tc7_foreign | (type<<8))); if (SCM_UNLIKELY ((word0 >> 16) != len))
scm_out_of_range ("scm_take_foreign_pointer", scm_from_size_t (len));
/* set SCM_FOREIGN_OBJECT to point to the third word of the object, which will
be 8-byte aligned. Then copy *val into that space. */
SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2));
memcpy (SCM_FOREIGN_OBJECT (ret, void), val, size);
if (finalizer)
{
/* Register a finalizer for the newly created instance. */
GC_finalization_proc prev_finalizer;
GC_PTR prev_finalizer_data;
GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret),
foreign_finalizer_trampoline,
finalizer,
&prev_finalizer,
&prev_finalizer_data);
}
return ret;
}
SCM
scm_c_take_foreign (scm_t_foreign_type type, void *val,
scm_t_foreign_finalizer finalizer)
{
SCM ret;
ret = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_bits) * 2, ret = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_bits) * 2,
"foreign")); "foreign"));
SCM_SET_CELL_WORD_0 (ret, (scm_t_bits)(scm_tc7_foreign | (type<<8))); SCM_SET_CELL_WORD_0 (ret, word0);
/* Set SCM_FOREIGN_OBJECT to the given pointer. */ SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)ptr);
SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)val);
if (finalizer) if (finalizer)
{ {
@ -115,97 +65,167 @@ scm_c_take_foreign (scm_t_foreign_type type, void *val,
return ret; return ret;
} }
SCM_DEFINE (scm_foreign_ref, "foreign-ref", 1, 0, 0, static void
(SCM foreign), keepalive (GC_PTR obj, GC_PTR data)
{
}
SCM_DEFINE (scm_foreign_ref, "foreign-ref", 1, 3, 0,
(SCM foreign, SCM type, SCM offset, SCM len),
"Reference the foreign value wrapped by @var{foreign}.\n\n" "Reference the foreign value wrapped by @var{foreign}.\n\n"
"Note that only \"simple\" types may be referenced by this\n" "The value will be referenced according to its type.\n"
"function. See @code{foreign-struct-ref} or @code{foreign-pointer-ref}\n" "If and only if the type of the foreign value is @code{void},\n"
"for structs or pointers, respectively.") "this function accepts optional @var{type} and @var{offset}\n"
"arguments, indicating that the pointer wrapped by\n"
"@var{foreign} should be incremented by @var{offset} bytes,\n"
"and treated as a pointer to a value of the given @var{type}.\n"
"@var{offset} defaults to 0.\n\n"
"If @var{type} itself is @code{void}, @var{len} will be used\n"
"to specify the size of the resulting @code{void} pointer.")
#define FUNC_NAME s_scm_foreign_ref #define FUNC_NAME s_scm_foreign_ref
{ {
SCM_VALIDATE_FOREIGN_SIMPLE (1, foreign); scm_t_foreign_type ftype;
scm_t_uint8 *ptr;
switch (SCM_FOREIGN_TYPE (foreign)) SCM_VALIDATE_FOREIGN (1, foreign);
ptr = SCM_FOREIGN_POINTER (foreign, scm_t_uint8);
ftype = SCM_FOREIGN_TYPE (foreign);
if (ftype == SCM_FOREIGN_TYPE_VOID)
{
if (SCM_UNBNDP (type))
scm_error_num_args_subr (FUNC_NAME);
ftype = scm_to_unsigned_integer (type, 0, SCM_FOREIGN_TYPE_LAST);
if (!SCM_UNBNDP (offset))
ptr += scm_to_ssize_t (offset);
}
else
{
if (!SCM_UNBNDP (type))
scm_error_num_args_subr (FUNC_NAME);
}
/* FIXME: is there a window in which we can see ptr but not foreign? */
switch (ftype)
{ {
case SCM_FOREIGN_TYPE_FLOAT: case SCM_FOREIGN_TYPE_FLOAT:
return scm_from_double (SCM_FOREIGN_OBJECT_REF (foreign, float)); return scm_from_double (*(float*)ptr);
case SCM_FOREIGN_TYPE_DOUBLE: case SCM_FOREIGN_TYPE_DOUBLE:
return scm_from_double (SCM_FOREIGN_OBJECT_REF (foreign, double)); return scm_from_double (*(double*)ptr);
case SCM_FOREIGN_TYPE_UINT8: case SCM_FOREIGN_TYPE_UINT8:
return scm_from_uint8 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint8)); return scm_from_uint8 (*(scm_t_uint8*)ptr);
case SCM_FOREIGN_TYPE_INT8: case SCM_FOREIGN_TYPE_INT8:
return scm_from_int8 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int8)); return scm_from_int8 (*(scm_t_int8*)ptr);
case SCM_FOREIGN_TYPE_UINT16: case SCM_FOREIGN_TYPE_UINT16:
return scm_from_uint16 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint16)); return scm_from_uint16 (*(scm_t_uint16*)ptr);
case SCM_FOREIGN_TYPE_INT16: case SCM_FOREIGN_TYPE_INT16:
return scm_from_int16 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int16)); return scm_from_int16 (*(scm_t_int16*)ptr);
case SCM_FOREIGN_TYPE_UINT32: case SCM_FOREIGN_TYPE_UINT32:
return scm_from_uint32 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint32)); return scm_from_uint32 (*(scm_t_uint32*)ptr);
case SCM_FOREIGN_TYPE_INT32: case SCM_FOREIGN_TYPE_INT32:
return scm_from_int32 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int32)); return scm_from_int32 (*(scm_t_int32*)ptr);
case SCM_FOREIGN_TYPE_UINT64: case SCM_FOREIGN_TYPE_UINT64:
return scm_from_uint64 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint64)); return scm_from_uint64 (*(scm_t_uint64*)ptr);
case SCM_FOREIGN_TYPE_INT64: case SCM_FOREIGN_TYPE_INT64:
return scm_from_int64 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int64)); return scm_from_int64 (*(scm_t_int64*)ptr);
case SCM_FOREIGN_TYPE_VOID: case SCM_FOREIGN_TYPE_VOID:
case SCM_FOREIGN_TYPE_STRUCT: /* seems we're making a new pointer, woo */
case SCM_FOREIGN_TYPE_POINTER: {
GC_finalization_proc prev_finalizer;
GC_PTR prev_finalizer_data;
SCM ret = scm_take_foreign_pointer
(ftype, ptr, SCM_UNBNDP (len) ? 0 : scm_to_size_t (len), NULL);
/* while the kid is alive, keep the parent alive */
if (SCM_FOREIGN_HAS_FINALIZER (foreign))
GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret), keepalive, foreign,
&prev_finalizer, &prev_finalizer_data);
return ret;
}
default: default:
/* other cases should have been caught by the FOREIGN_SIMPLE check */
abort (); abort ();
} }
} }
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE (scm_foreign_set_x, "foreign-set!", 2, 0, 0, SCM_DEFINE (scm_foreign_set_x, "foreign-set!", 2, 2, 0,
(SCM foreign, SCM val), (SCM foreign, SCM val, SCM type, SCM offset),
"Set the foreign value wrapped by @var{foreign}.\n\n" "Set the foreign value wrapped by @var{foreign}.\n\n"
"Note that only \"simple\" types may be set by this function.\n" "The value will be set according to its type.\n"
"See @code{foreign-struct-ref} or @code{foreign-pointer-ref} for\n" "If and only if the type of the foreign value is @code{void},\n"
"structs or pointers, respectively.") "this function accepts optional @var{type} and @var{offset}\n"
"arguments, indicating that the pointer wrapped by\n"
"@var{foreign} should be incremented by @var{offset} bytes,\n"
"and treated as a pointer to a value of the given @var{type}.\n"
"@var{offset} defaults to 0.")
#define FUNC_NAME s_scm_foreign_set_x #define FUNC_NAME s_scm_foreign_set_x
{ {
SCM_VALIDATE_FOREIGN_SIMPLE (1, foreign); scm_t_foreign_type ftype;
scm_t_uint8 *ptr;
switch (SCM_FOREIGN_TYPE (foreign)) SCM_VALIDATE_FOREIGN (1, foreign);
ptr = SCM_FOREIGN_POINTER (foreign, scm_t_uint8);
ftype = SCM_FOREIGN_TYPE (foreign);
if (ftype == SCM_FOREIGN_TYPE_VOID)
{
if (SCM_UNBNDP (type))
scm_error_num_args_subr (FUNC_NAME);
ftype = scm_to_unsigned_integer (type, 0, SCM_FOREIGN_TYPE_LAST);
if (!SCM_UNBNDP (offset))
ptr += scm_to_ssize_t (offset);
}
else
{
if (!SCM_UNBNDP (type))
scm_error_num_args_subr (FUNC_NAME);
}
/* FIXME: is there a window in which we can see ptr but not foreign? */
switch (ftype)
{ {
case SCM_FOREIGN_TYPE_FLOAT: case SCM_FOREIGN_TYPE_FLOAT:
SCM_FOREIGN_OBJECT_SET (foreign, float, scm_to_double (val)); *(float*)ptr = scm_to_double (val);
break; break;
case SCM_FOREIGN_TYPE_DOUBLE: case SCM_FOREIGN_TYPE_DOUBLE:
SCM_FOREIGN_OBJECT_SET (foreign, double, scm_to_double (val)); *(double*)ptr = scm_to_double (val);
break; break;
case SCM_FOREIGN_TYPE_UINT8: case SCM_FOREIGN_TYPE_UINT8:
SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint8, scm_to_uint8 (val)); *(scm_t_uint8*)ptr = scm_to_uint8 (val);
break; break;
case SCM_FOREIGN_TYPE_INT8: case SCM_FOREIGN_TYPE_INT8:
SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int8, scm_to_int8 (val)); *(scm_t_int8*)ptr = scm_to_int8 (val);
break; break;
case SCM_FOREIGN_TYPE_UINT16: case SCM_FOREIGN_TYPE_UINT16:
SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint16, scm_to_uint16 (val)); *(scm_t_uint16*)ptr = scm_to_uint16 (val);
break; break;
case SCM_FOREIGN_TYPE_INT16: case SCM_FOREIGN_TYPE_INT16:
SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int16, scm_to_int16 (val)); *(scm_t_int16*)ptr = scm_to_int16 (val);
break; break;
case SCM_FOREIGN_TYPE_UINT32: case SCM_FOREIGN_TYPE_UINT32:
SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint32, scm_to_uint32 (val)); *(scm_t_uint32*)ptr = scm_to_uint32 (val);
break; break;
case SCM_FOREIGN_TYPE_INT32: case SCM_FOREIGN_TYPE_INT32:
SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int32, scm_to_int32 (val)); *(scm_t_int32*)ptr = scm_to_int32 (val);
break; break;
case SCM_FOREIGN_TYPE_UINT64: case SCM_FOREIGN_TYPE_UINT64:
SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint64, scm_to_uint64 (val)); *(scm_t_uint64*)ptr = scm_to_uint64 (val);
break; break;
case SCM_FOREIGN_TYPE_INT64: case SCM_FOREIGN_TYPE_INT64:
SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int64, scm_to_int64 (val)); *(scm_t_int64*)ptr = scm_to_int64 (val);
break; break;
case SCM_FOREIGN_TYPE_VOID: case SCM_FOREIGN_TYPE_VOID:
case SCM_FOREIGN_TYPE_STRUCT: SCM_VALIDATE_FOREIGN (2, val);
case SCM_FOREIGN_TYPE_POINTER: if (SCM_FOREIGN_HAS_FINALIZER (val))
/* setting a pointer inside one foreign value to the pointer of another?
that is asking for trouble */
scm_wrong_type_arg_msg (FUNC_NAME, 2, val,
"foreign value without finalizer");
*(void**)ptr = SCM_FOREIGN_POINTER (val, void*);
break;
default: default:
/* other cases should have been caught by the FOREIGN_SIMPLE check */
abort (); abort ();
} }
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -216,55 +236,69 @@ scm_i_foreign_print (SCM foreign, SCM port, scm_print_state *pstate)
scm_puts ("#<foreign ", port); scm_puts ("#<foreign ", port);
switch (SCM_FOREIGN_TYPE (foreign)) switch (SCM_FOREIGN_TYPE (foreign))
{ {
case SCM_FOREIGN_TYPE_VOID:
abort ();
case SCM_FOREIGN_TYPE_FLOAT: case SCM_FOREIGN_TYPE_FLOAT:
scm_puts ("float ", port); scm_puts ("float ", port);
scm_display (scm_foreign_ref (foreign), port); scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
SCM_UNDEFINED),
port);
break; break;
case SCM_FOREIGN_TYPE_DOUBLE: case SCM_FOREIGN_TYPE_DOUBLE:
scm_puts ("double ", port); scm_puts ("double ", port);
scm_display (scm_foreign_ref (foreign), port); scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
SCM_UNDEFINED),
port);
break; break;
case SCM_FOREIGN_TYPE_UINT8: case SCM_FOREIGN_TYPE_UINT8:
scm_puts ("uint8 ", port); scm_puts ("uint8 ", port);
scm_display (scm_foreign_ref (foreign), port); scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
SCM_UNDEFINED),
port);
break; break;
case SCM_FOREIGN_TYPE_INT8: case SCM_FOREIGN_TYPE_INT8:
scm_puts ("int8 ", port); scm_puts ("int8 ", port);
scm_display (scm_foreign_ref (foreign), port); scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
SCM_UNDEFINED),
port);
break; break;
case SCM_FOREIGN_TYPE_UINT16: case SCM_FOREIGN_TYPE_UINT16:
scm_puts ("uint16 ", port); scm_puts ("uint16 ", port);
scm_display (scm_foreign_ref (foreign), port); scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
SCM_UNDEFINED),
port);
break; break;
case SCM_FOREIGN_TYPE_INT16: case SCM_FOREIGN_TYPE_INT16:
scm_puts ("int16 ", port); scm_puts ("int16 ", port);
scm_display (scm_foreign_ref (foreign), port); scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
SCM_UNDEFINED),
port);
break; break;
case SCM_FOREIGN_TYPE_UINT32: case SCM_FOREIGN_TYPE_UINT32:
scm_puts ("uint32 ", port); scm_puts ("uint32 ", port);
scm_display (scm_foreign_ref (foreign), port); scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
SCM_UNDEFINED),
port);
break; break;
case SCM_FOREIGN_TYPE_INT32: case SCM_FOREIGN_TYPE_INT32:
scm_puts ("int32 ", port); scm_puts ("int32 ", port);
scm_display (scm_foreign_ref (foreign), port); scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
SCM_UNDEFINED),
port);
break; break;
case SCM_FOREIGN_TYPE_UINT64: case SCM_FOREIGN_TYPE_UINT64:
scm_puts ("uint64 ", port); scm_puts ("uint64 ", port);
scm_display (scm_foreign_ref (foreign), port); scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
SCM_UNDEFINED),
port);
break; break;
case SCM_FOREIGN_TYPE_INT64: case SCM_FOREIGN_TYPE_INT64:
scm_puts ("int64 ", port); scm_puts ("int64 ", port);
scm_display (scm_foreign_ref (foreign), port); scm_display (scm_foreign_ref (foreign, SCM_UNDEFINED, SCM_UNDEFINED,
SCM_UNDEFINED),
port);
break; break;
case SCM_FOREIGN_TYPE_STRUCT: case SCM_FOREIGN_TYPE_VOID:
scm_puts ("struct at 0x", port);
scm_uintprint (SCM_CELL_WORD_1 (foreign), 16, port);
break;
case SCM_FOREIGN_TYPE_POINTER:
scm_puts ("pointer 0x", port); scm_puts ("pointer 0x", port);
scm_uintprint (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_bits), 16, port); scm_uintprint ((scm_t_bits)SCM_FOREIGN_POINTER (foreign, void), 16, port);
break; break;
default: default:
abort (); abort ();

58
libguile/foreign.h
View file

@ -21,10 +21,24 @@
/* A subset of libffi's types. */ /* 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.
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 typedef enum
{ {
SCM_FOREIGN_TYPE_VOID, SCM_FOREIGN_TYPE_VOID, /* a pointer out into the wilderness */
SCM_FOREIGN_TYPE_FLOAT, SCM_FOREIGN_TYPE_FLOAT,
SCM_FOREIGN_TYPE_DOUBLE, SCM_FOREIGN_TYPE_DOUBLE,
SCM_FOREIGN_TYPE_UINT8, SCM_FOREIGN_TYPE_UINT8,
@ -35,8 +49,7 @@ typedef enum
SCM_FOREIGN_TYPE_INT32, SCM_FOREIGN_TYPE_INT32,
SCM_FOREIGN_TYPE_UINT64, SCM_FOREIGN_TYPE_UINT64,
SCM_FOREIGN_TYPE_INT64, SCM_FOREIGN_TYPE_INT64,
SCM_FOREIGN_TYPE_STRUCT, SCM_FOREIGN_TYPE_LAST = SCM_FOREIGN_TYPE_INT64
SCM_FOREIGN_TYPE_POINTER
} scm_t_foreign_type; } scm_t_foreign_type;
@ -48,12 +61,16 @@ typedef void (*scm_t_foreign_finalizer) (void *);
SCM_MAKE_VALIDATE (pos, x, FOREIGN_P) SCM_MAKE_VALIDATE (pos, x, FOREIGN_P)
#define SCM_FOREIGN_TYPE(x) \ #define SCM_FOREIGN_TYPE(x) \
((scm_t_foreign_type)((SCM_CELL_WORD_0 (x) >> 8)&0xff)) ((scm_t_foreign_type)((SCM_CELL_WORD_0 (x) >> 8)&0xff))
#define SCM_FOREIGN_OBJECT(x, ctype) \ #define SCM_FOREIGN_POINTER(x, ctype) \
((ctype*)SCM_CELL_OBJECT_1 (x)) ((ctype*)SCM_CELL_WORD_1 (x))
#define SCM_FOREIGN_OBJECT_REF(x, ctype) \ #define SCM_FOREIGN_VALUE_REF(x, ctype) \
(*SCM_FOREIGN_OBJECT (x, ctype)) (*SCM_FOREIGN_POINTER (x, ctype))
#define SCM_FOREIGN_OBJECT_SET(x, ctype, val) \ #define SCM_FOREIGN_VALUE_SET(x, ctype, val) \
(*SCM_FOREIGN_OBJECT (x, ctype) = (val)) (*SCM_FOREIGN_POINTER (x, ctype) = (val))
#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) \ #define SCM_FOREIGN_TYPED_P(x, type) \
(SCM_FOREIGN_P (x) && SCM_FOREIGN_TYPE (x) == SCM_FOREIGN_TYPE_##type) (SCM_FOREIGN_P (x) && SCM_FOREIGN_TYPE (x) == SCM_FOREIGN_TYPE_##type)
@ -63,21 +80,18 @@ typedef void (*scm_t_foreign_finalizer) (void *);
"FOREIGN_"#type"_P"); \ "FOREIGN_"#type"_P"); \
} while (0) } while (0)
#define SCM_FOREIGN_SIMPLE_P(x) \ #define SCM_FOREIGN_VALUE_P(x) \
(SCM_FOREIGN_P (x) \ (SCM_FOREIGN_P (x) && SCM_FOREIGN_TYPE (x) != SCM_FOREIGN_TYPE_VOID)
&& SCM_FOREIGN_TYPE (x) != SCM_FOREIGN_TYPE_VOID \ #define SCM_VALIDATE_FOREIGN_VALUE(pos, x) \
&& SCM_FOREIGN_TYPE (x) != SCM_FOREIGN_TYPE_STRUCT \ SCM_MAKE_VALIDATE (pos, x, FOREIGN_VALUE_P)
&& SCM_FOREIGN_TYPE (x) != SCM_FOREIGN_TYPE_POINTER)
#define SCM_VALIDATE_FOREIGN_SIMPLE(pos, x) \
SCM_MAKE_VALIDATE (pos, x, FOREIGN_SIMPLE_P)
SCM_API SCM scm_c_from_foreign (scm_t_foreign_type type, void *val, size_t size, SCM_API SCM scm_take_foreign_pointer (scm_t_foreign_type type, void *ptr,
scm_t_foreign_finalizer finalizer); size_t len,
SCM_API SCM scm_c_take_foreign (scm_t_foreign_type type, void *val,
scm_t_foreign_finalizer finalizer); scm_t_foreign_finalizer finalizer);
SCM_API SCM scm_foreign_ref (SCM foreign); SCM_API SCM scm_foreign_type (SCM foreign);
SCM_API SCM scm_foreign_set_x (SCM foreign, SCM val); SCM_API SCM scm_foreign_ref (SCM foreign, SCM type, SCM offset, SCM len);
SCM_API SCM scm_foreign_set_x (SCM foreign, SCM val, SCM type, SCM offset);
SCM_INTERNAL void scm_i_foreign_print (SCM foreign, SCM port, SCM_INTERNAL void scm_i_foreign_print (SCM foreign, SCM port,
scm_print_state *pstate); scm_print_state *pstate);

8
libguile/goops.c
View file

@ -1725,10 +1725,10 @@ SCM_DEFINE (scm_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1
{ {
SCM subr = SCM_CAR (subrs); SCM subr = SCM_CAR (subrs);
SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARGn, FUNC_NAME); SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARGn, FUNC_NAME);
*SCM_SUBR_GENERIC (subr) SCM_SET_SUBR_GENERIC (subr,
= scm_make (scm_list_3 (scm_class_generic, scm_make (scm_list_3 (scm_class_generic,
k_name, k_name,
SCM_SUBR_NAME (subr))); SCM_SUBR_NAME (subr))));
subrs = SCM_CDR (subrs); subrs = SCM_CDR (subrs);
} }
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
@ -1742,7 +1742,7 @@ SCM_DEFINE (scm_set_primitive_generic_x, "set-primitive-generic!", 2, 0, 0,
{ {
SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARG1, FUNC_NAME); SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARG1, FUNC_NAME);
SCM_ASSERT (SCM_PUREGENERICP (generic), generic, SCM_ARG2, FUNC_NAME); SCM_ASSERT (SCM_PUREGENERICP (generic), generic, SCM_ARG2, FUNC_NAME);
*SCM_SUBR_GENERIC (subr) = generic; SCM_SET_SUBR_GENERIC (subr, generic);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
#undef FUNC_NAME #undef FUNC_NAME

8
libguile/gsubr.c
View file

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

4
libguile/gsubr.h
View file

@ -43,10 +43,10 @@ SCM_API SCM scm_subr_objcode_trampoline (unsigned int nreq,
#define SCM_PRIMITIVE_P(x) (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE (x)) #define SCM_PRIMITIVE_P(x) (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE (x))
#define SCM_PRIMITIVE_GENERIC_P(x) (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x)) #define SCM_PRIMITIVE_GENERIC_P(x) (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x))
#define SCM_SUBRF(x) ((SCM (*)()) (SCM_FOREIGN_OBJECT (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 0), void*))) #define SCM_SUBRF(x) ((SCM (*)()) (SCM_FOREIGN_POINTER (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 0), void)))
#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_FOREIGN_OBJECT_REF (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 2), SCM*)) (SCM_FOREIGN_POINTER (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 2), SCM))
#define SCM_SET_SUBR_GENERIC(x, g) \ #define SCM_SET_SUBR_GENERIC(x, g) \
(*SCM_SUBR_GENERIC (x) = (g)) (*SCM_SUBR_GENERIC (x) = (g))

10
libguile/snarf.h
View file

@ -105,10 +105,8 @@ 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; \
static const scm_t_bits scm_i_paste (FNAME, __subr_ptr) = \
(scm_t_bits) &FNAME; /* the subr */ \
SCM_IMMUTABLE_FOREIGN (scm_i_paste (FNAME, __subr_foreign), \ SCM_IMMUTABLE_FOREIGN (scm_i_paste (FNAME, __subr_foreign), \
scm_i_paste (FNAME, __subr_ptr)); \ (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 */ \
SCM_BOOL_F); \ SCM_BOOL_F); \
@ -363,10 +361,10 @@ 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, loc) \ #define SCM_IMMUTABLE_FOREIGN(c_name, ptr) \
SCM_IMMUTABLE_CELL (c_name, \ SCM_IMMUTABLE_CELL (c_name, \
scm_tc7_foreign | (SCM_FOREIGN_TYPE_POINTER << 8), \ scm_tc7_foreign | (SCM_FOREIGN_TYPE_VOID << 8), \
&loc) ptr)
/* for primitive-generics, add a foreign to the end */ /* for primitive-generics, add a foreign to the end */
#define SCM_STATIC_SUBR_OBJVECT(c_name, foreign) \ #define SCM_STATIC_SUBR_OBJVECT(c_name, foreign) \

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

@ -842,7 +842,7 @@ VM_DEFINE_INSTRUCTION (80, subr_call, "subr-call", 1, -1, -1)
nargs = FETCH (); nargs = FETCH ();
POP (foreign); POP (foreign);
subr = SCM_FOREIGN_OBJECT_REF (foreign, void*); subr = SCM_FOREIGN_POINTER (foreign, void);
VM_HANDLE_INTERRUPTS; VM_HANDLE_INTERRUPTS;
SYNC_REGISTER (); SYNC_REGISTER ();