diff options
author | Andy Wingo <wingo@pobox.com> | 2010-01-18 11:42:35 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-01-26 22:56:41 +0100 |
commit | 52fd9639fdeee068434342e1bdb8693b05ecac5c (patch) | |
tree | 9d8ab132c65a07ce2c2b102ae66682df5085d977 | |
parent | 75c242a256c273ab0690397df4277d44f01946e6 (diff) | |
download | guile-52fd9639fdeee068434342e1bdb8693b05ecac5c.tar.gz |
foreign.h presents a more pointer-centric interface
* 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.
-rw-r--r-- | libguile/dynl.c | 61 | ||||
-rw-r--r-- | libguile/dynl.h | 3 | ||||
-rw-r--r-- | libguile/foreign.c | 268 | ||||
-rw-r--r-- | libguile/foreign.h | 64 | ||||
-rw-r--r-- | libguile/goops.c | 10 | ||||
-rw-r--r-- | libguile/gsubr.c | 8 | ||||
-rw-r--r-- | libguile/gsubr.h | 4 | ||||
-rw-r--r-- | libguile/snarf.h | 10 | ||||
-rw-r--r-- | libguile/vm-i-system.c | 2 |
9 files changed, 253 insertions, 177 deletions
diff --git a/libguile/dynl.c b/libguile/dynl.c index a55ba86ea..0175c336a 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -100,7 +100,7 @@ sysdep_dynl_unlink (void *handle, const char *subr) } 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; @@ -214,23 +214,31 @@ SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0, #undef FUNC_NAME -SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0, - (SCM name, SCM dobj), - "Return a ``handle'' for the function @var{name} in the\n" +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" - "can be passed to @code{dynamic-call} to actually\n" - "call the function.\n\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_func +#define FUNC_NAME s_scm_dynamic_pointer { - void (*func) (); + 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_ARG2, dobj, dynamic_obj); + SCM_VALIDATE_SMOB (SCM_ARG3, dobj, dynamic_obj); if (DYNL_HANDLE (dobj) == NULL) { SCM_MISC_ERROR ("Already unlinked: ~S", dobj); } else { @@ -239,15 +247,36 @@ SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0, 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); + val = sysdep_dynl_value (chars, DYNL_HANDLE (dobj), FUNC_NAME); scm_dynwind_end (); - return scm_c_from_foreign (SCM_FOREIGN_TYPE_POINTER, &func, 0, NULL); + 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 name, SCM dobj), + "Return a ``handle'' for the function @var{name} in the\n" + "shared object referred to by @var{dobj}. The handle\n" + "can be passed to @code{dynamic-call} to actually\n" + "call the function.\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_func +{ + return scm_dynamic_pointer (name, + scm_from_uint (SCM_FOREIGN_TYPE_VOID), + dobj, + SCM_UNDEFINED); +} +#undef FUNC_NAME + + SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0, (SCM func, SCM dobj), "Call a C function in a dynamic object. Two styles of\n" @@ -272,9 +301,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, POINTER); + SCM_VALIDATE_FOREIGN_TYPED (SCM_ARG1, func, VOID); - fptr = SCM_FOREIGN_OBJECT_REF (func, void*); + fptr = SCM_FOREIGN_POINTER (func, void); fptr (); return SCM_UNSPECIFIED; } @@ -302,9 +331,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, 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); for (argc = 0; argv[argc]; argc++) diff --git a/libguile/dynl.h b/libguile/dynl.h index eb318ae98..2b34c2e49 100644 --- a/libguile/dynl.h +++ b/libguile/dynl.h @@ -3,7 +3,7 @@ #ifndef 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 * 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_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_func (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); diff --git a/libguile/foreign.c b/libguile/foreign.c index 4a4b2181a..ec76a00aa 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -26,52 +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 foreign_finalizer_trampoline (GC_PTR ptr, GC_PTR data) { scm_t_foreign_finalizer finalizer = data; - finalizer (SCM_FOREIGN_OBJECT (PTR2SCM (ptr), void*)); + finalizer (SCM_FOREIGN_POINTER (PTR2SCM (ptr), void)); } SCM -scm_c_from_foreign (scm_t_foreign_type type, void *val, size_t size, - scm_t_foreign_finalizer finalizer) +scm_take_foreign_pointer (scm_t_foreign_type type, void *ptr, size_t len, + scm_t_foreign_finalizer finalizer) { SCM ret; - if (!size) - size = sizeof_type (type); + scm_t_bits word0; - ret = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_bits) * 2 + size, + word0 = (scm_t_bits)(scm_tc7_foreign | (type<<8) + | (finalizer ? (1<<16) : 0) | (len<<17)); + if (SCM_UNLIKELY ((word0 >> 16) != len)) + scm_out_of_range ("scm_take_foreign_pointer", scm_from_size_t (len)); + + ret = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_bits) * 2, "foreign")); - SCM_SET_CELL_WORD_0 (ret, (scm_t_bits)(scm_tc7_foreign | (type<<8))); - - /* 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); + SCM_SET_CELL_WORD_0 (ret, word0); + SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)ptr); if (finalizer) { @@ -88,124 +65,167 @@ scm_c_from_foreign (scm_t_foreign_type type, void *val, size_t size, return ret; } -SCM -scm_c_take_foreign (scm_t_foreign_type type, void *val, - scm_t_foreign_finalizer finalizer) +static void +keepalive (GC_PTR obj, GC_PTR data) { - SCM ret; - - ret = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_bits) * 2, - "foreign")); - SCM_SET_CELL_WORD_0 (ret, (scm_t_bits)(scm_tc7_foreign | (type<<8))); - /* Set SCM_FOREIGN_OBJECT to the given pointer. */ - SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)val); - - 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_DEFINE (scm_foreign_ref, "foreign-ref", 1, 0, 0, - (SCM foreign), +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" - "Note that only \"simple\" types may be referenced by this\n" - "function. See @code{foreign-struct-ref} or @code{foreign-pointer-ref}\n" - "for structs or pointers, respectively.") + "The value will be referenced according to its type.\n" + "If and only if the type of the foreign value is @code{void},\n" + "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 { - 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: - return scm_from_double (SCM_FOREIGN_OBJECT_REF (foreign, float)); + return scm_from_double (*(float*)ptr); 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: - 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: - 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: - 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: - 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: - 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: - 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: - 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: - 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_STRUCT: - case SCM_FOREIGN_TYPE_POINTER: + /* seems we're making a new pointer, woo */ + { + 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: - /* other cases should have been caught by the FOREIGN_SIMPLE check */ abort (); } } #undef FUNC_NAME -SCM_DEFINE (scm_foreign_set_x, "foreign-set!", 2, 0, 0, - (SCM foreign, SCM val), +SCM_DEFINE (scm_foreign_set_x, "foreign-set!", 2, 2, 0, + (SCM foreign, SCM val, SCM type, SCM offset), "Set the foreign value wrapped by @var{foreign}.\n\n" - "Note that only \"simple\" types may be set by this function.\n" - "See @code{foreign-struct-ref} or @code{foreign-pointer-ref} for\n" - "structs or pointers, respectively.") + "The value will be set according to its type.\n" + "If and only if the type of the foreign value is @code{void},\n" + "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 { - 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: - SCM_FOREIGN_OBJECT_SET (foreign, float, scm_to_double (val)); + *(float*)ptr = scm_to_double (val); break; case SCM_FOREIGN_TYPE_DOUBLE: - SCM_FOREIGN_OBJECT_SET (foreign, double, scm_to_double (val)); + *(double*)ptr = scm_to_double (val); break; 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; 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; 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; 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; 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; 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; 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; 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; case SCM_FOREIGN_TYPE_VOID: - case SCM_FOREIGN_TYPE_STRUCT: - case SCM_FOREIGN_TYPE_POINTER: + SCM_VALIDATE_FOREIGN (2, val); + 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: - /* other cases should have been caught by the FOREIGN_SIMPLE check */ abort (); } + return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -216,55 +236,69 @@ 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_VOID: - abort (); case SCM_FOREIGN_TYPE_FLOAT: 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; case SCM_FOREIGN_TYPE_DOUBLE: 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; case SCM_FOREIGN_TYPE_UINT8: 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; case SCM_FOREIGN_TYPE_INT8: 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; case SCM_FOREIGN_TYPE_UINT16: 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; case SCM_FOREIGN_TYPE_INT16: 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; case SCM_FOREIGN_TYPE_UINT32: 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; case SCM_FOREIGN_TYPE_INT32: 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; case SCM_FOREIGN_TYPE_UINT64: 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; case SCM_FOREIGN_TYPE_INT64: 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; - case SCM_FOREIGN_TYPE_STRUCT: - scm_puts ("struct at 0x", port); - scm_uintprint (SCM_CELL_WORD_1 (foreign), 16, port); - break; - case SCM_FOREIGN_TYPE_POINTER: + case SCM_FOREIGN_TYPE_VOID: 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; default: abort (); diff --git a/libguile/foreign.h b/libguile/foreign.h index 954c1c5b3..d48027799 100644 --- a/libguile/foreign.h +++ b/libguile/foreign.h @@ -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 { - SCM_FOREIGN_TYPE_VOID, + SCM_FOREIGN_TYPE_VOID, /* a pointer out into the wilderness */ SCM_FOREIGN_TYPE_FLOAT, SCM_FOREIGN_TYPE_DOUBLE, SCM_FOREIGN_TYPE_UINT8, @@ -35,8 +49,7 @@ typedef enum SCM_FOREIGN_TYPE_INT32, SCM_FOREIGN_TYPE_UINT64, SCM_FOREIGN_TYPE_INT64, - SCM_FOREIGN_TYPE_STRUCT, - SCM_FOREIGN_TYPE_POINTER + SCM_FOREIGN_TYPE_LAST = SCM_FOREIGN_TYPE_INT64 } scm_t_foreign_type; @@ -48,12 +61,16 @@ typedef void (*scm_t_foreign_finalizer) (void *); 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_OBJECT(x, ctype) \ - ((ctype*)SCM_CELL_OBJECT_1 (x)) -#define SCM_FOREIGN_OBJECT_REF(x, ctype) \ - (*SCM_FOREIGN_OBJECT (x, ctype)) -#define SCM_FOREIGN_OBJECT_SET(x, ctype, val) \ - (*SCM_FOREIGN_OBJECT (x, ctype) = (val)) +#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) \ + ((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) @@ -63,21 +80,18 @@ typedef void (*scm_t_foreign_finalizer) (void *); "FOREIGN_"#type"_P"); \ } while (0) -#define SCM_FOREIGN_SIMPLE_P(x) \ - (SCM_FOREIGN_P (x) \ - && SCM_FOREIGN_TYPE (x) != SCM_FOREIGN_TYPE_VOID \ - && SCM_FOREIGN_TYPE (x) != SCM_FOREIGN_TYPE_STRUCT \ - && 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_t_foreign_finalizer finalizer); -SCM_API SCM scm_c_take_foreign (scm_t_foreign_type type, void *val, - scm_t_foreign_finalizer finalizer); - -SCM_API SCM scm_foreign_ref (SCM foreign); -SCM_API SCM scm_foreign_set_x (SCM foreign, SCM val); +#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_foreign_type (SCM foreign); +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_print_state *pstate); diff --git a/libguile/goops.c b/libguile/goops.c index 33293fea4..6fc073bdc 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1725,10 +1725,10 @@ SCM_DEFINE (scm_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1 { SCM subr = SCM_CAR (subrs); SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARGn, FUNC_NAME); - *SCM_SUBR_GENERIC (subr) - = scm_make (scm_list_3 (scm_class_generic, - k_name, - SCM_SUBR_NAME (subr))); + SCM_SET_SUBR_GENERIC (subr, + scm_make (scm_list_3 (scm_class_generic, + k_name, + SCM_SUBR_NAME (subr)))); subrs = SCM_CDR (subrs); } 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_PUREGENERICP (generic), generic, SCM_ARG2, FUNC_NAME); - *SCM_SUBR_GENERIC (subr) = generic; + SCM_SET_SUBR_GENERIC (subr, generic); return SCM_UNSPECIFIED; } #undef FUNC_NAME diff --git a/libguile/gsubr.c b/libguile/gsubr.c index f0c622290..de4bff69f 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -794,13 +794,13 @@ 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_c_from_foreign (SCM_FOREIGN_TYPE_POINTER, - &fcn, 0, NULL)); + scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID, + fcn, 0, NULL)); SCM_SIMPLE_VECTOR_SET (table, 1, sname); if (generic_loc) SCM_SIMPLE_VECTOR_SET (table, 2, - scm_c_from_foreign (SCM_FOREIGN_TYPE_POINTER, - &generic_loc, 0, NULL)); + scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID, + generic_loc, 0, 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 a4dc5602e..e94d0d0ad 100644 --- a/libguile/gsubr.h +++ b/libguile/gsubr.h @@ -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_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_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) \ (*SCM_SUBR_GENERIC (x) = (g)) diff --git a/libguile/snarf.h b/libguile/snarf.h index 717c953e8..98f660115 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -105,10 +105,8 @@ 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; \ - 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_i_paste (FNAME, __subr_ptr)); \ + (scm_t_bits) &FNAME); /* the subr */ \ SCM_STATIC_SUBR_OBJVECT (scm_i_paste (FNAME, __raw_objtable), \ /* FIXME: directly be the foreign */ \ 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) sizeof (contents) - 1) -#define SCM_IMMUTABLE_FOREIGN(c_name, loc) \ +#define SCM_IMMUTABLE_FOREIGN(c_name, ptr) \ SCM_IMMUTABLE_CELL (c_name, \ - scm_tc7_foreign | (SCM_FOREIGN_TYPE_POINTER << 8), \ - &loc) + scm_tc7_foreign | (SCM_FOREIGN_TYPE_VOID << 8), \ + 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 8297c5b0e..c9c743792 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -842,7 +842,7 @@ VM_DEFINE_INSTRUCTION (80, subr_call, "subr-call", 1, -1, -1) nargs = FETCH (); POP (foreign); - subr = SCM_FOREIGN_OBJECT_REF (foreign, void*); + subr = SCM_FOREIGN_POINTER (foreign, void); VM_HANDLE_INTERRUPTS; SYNC_REGISTER (); |