diff --git a/libguile.h b/libguile.h index 7a8b6333f..6f1b3f822 100644 --- a/libguile.h +++ b/libguile.h @@ -1,7 +1,7 @@ #ifndef SCM_LIBGUILE_H #define SCM_LIBGUILE_H -/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2008, 2009 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2008, 2009, 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 @@ -50,6 +50,7 @@ extern "C" { #include "libguile/feature.h" #include "libguile/filesys.h" #include "libguile/fluids.h" +#include "libguile/foreign.h" #include "libguile/fports.h" #include "libguile/gc.h" #include "libguile/gdbint.h" diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 6e3061f50..9bef5077b 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -1,6 +1,6 @@ ## Process this file with Automake to create Makefile.in ## -## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. +## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -129,6 +129,7 @@ libguile_la_SOURCES = \ extensions.c \ feature.c \ fluids.c \ + foreign.c \ fports.c \ frames.c \ gc-malloc.c \ @@ -230,6 +231,7 @@ DOT_X_FILES = \ extensions.x \ feature.x \ fluids.x \ + foreign.x \ fports.x \ gc-malloc.x \ gc.x \ @@ -328,6 +330,7 @@ DOT_DOC_FILES = \ extensions.doc \ feature.doc \ fluids.doc \ + foreign.doc \ fports.doc \ gc-malloc.doc \ gc.doc \ @@ -487,6 +490,7 @@ modinclude_HEADERS = \ feature.h \ filesys.h \ fluids.h \ + foreign.h \ fports.h \ frames.h \ gc.h \ diff --git a/libguile/evalext.c b/libguile/evalext.c index 84218b35f..32f1f4f4c 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009 Free Software Foundation, Inc. +/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 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 @@ -77,6 +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_hashtable: case scm_tc7_fluid: case scm_tc7_dynamic_state: diff --git a/libguile/foreign.c b/libguile/foreign.c new file mode 100644 index 000000000..8ace4a1b3 --- /dev/null +++ b/libguile/foreign.c @@ -0,0 +1,288 @@ +/* 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 + * the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA + */ + +#if HAVE_CONFIG_H +# include +#endif + +#include +#include "_scm.h" +#include "foreign.h" + + + +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*)); +} + +SCM +scm_c_from_foreign (scm_t_foreign_type type, void *val, size_t size, + scm_t_foreign_finalizer finalizer) +{ + void *ret; + if (!size) + size = sizeof_type (type); + + ret = scm_gc_malloc_pointerless (sizeof (scm_t_bits) * 2 + size, "foreign"); + SCM_SET_CELL_WORD_0 (PTR2SCM (ret), 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 (PTR2SCM (ret), + (scm_t_bits)SCM_CELL_OBJECT_LOC (PTR2SCM (ret), 2)); + memcpy (SCM_FOREIGN_OBJECT (PTR2SCM (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 (ret, + foreign_finalizer_trampoline, + finalizer, + &prev_finalizer, + &prev_finalizer_data); + } + + return PTR2SCM (ret); +} + +SCM +scm_c_take_foreign (scm_t_foreign_type type, void *val, + scm_t_foreign_finalizer finalizer) +{ + void *ret; + + ret = scm_gc_malloc_pointerless (sizeof (scm_t_bits) * 2, "foreign"); + SCM_SET_CELL_WORD_0 (PTR2SCM (ret), scm_tc7_foreign | (type<<8)); + /* Set SCM_FOREIGN_OBJECT to the given pointer. */ + SCM_SET_CELL_WORD_1 (PTR2SCM (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 (ret, + foreign_finalizer_trampoline, + finalizer, + &prev_finalizer, + &prev_finalizer_data); + } + + return PTR2SCM (ret); +} + +SCM_DEFINE (scm_foreign_ref, "foreign-ref", 1, 0, 0, + (SCM foreign), + "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.") +#define FUNC_NAME s_scm_foreign_ref +{ + SCM_VALIDATE_FOREIGN_SIMPLE (1, foreign); + + switch (SCM_FOREIGN_TYPE (foreign)) + { + case SCM_FOREIGN_TYPE_FLOAT: + return scm_from_double (SCM_FOREIGN_OBJECT_REF (foreign, float)); + case SCM_FOREIGN_TYPE_DOUBLE: + return scm_from_double (SCM_FOREIGN_OBJECT_REF (foreign, double)); + case SCM_FOREIGN_TYPE_UINT8: + return scm_from_uint8 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint8)); + case SCM_FOREIGN_TYPE_INT8: + return scm_from_int8 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int8)); + case SCM_FOREIGN_TYPE_UINT16: + return scm_from_uint16 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint16)); + case SCM_FOREIGN_TYPE_INT16: + return scm_from_int16 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int16)); + case SCM_FOREIGN_TYPE_UINT32: + return scm_from_uint32 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint32)); + case SCM_FOREIGN_TYPE_INT32: + return scm_from_int32 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int32)); + case SCM_FOREIGN_TYPE_UINT64: + return scm_from_uint64 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_uint64)); + case SCM_FOREIGN_TYPE_INT64: + return scm_from_int64 (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_int64)); + case SCM_FOREIGN_TYPE_VOID: + case SCM_FOREIGN_TYPE_STRUCT: + case SCM_FOREIGN_TYPE_POINTER: + 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), + "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.") +#define FUNC_NAME s_scm_foreign_set_x +{ + SCM_VALIDATE_FOREIGN_SIMPLE (1, foreign); + + switch (SCM_FOREIGN_TYPE (foreign)) + { + case SCM_FOREIGN_TYPE_FLOAT: + SCM_FOREIGN_OBJECT_SET (foreign, float, scm_to_double (val)); + break; + case SCM_FOREIGN_TYPE_DOUBLE: + SCM_FOREIGN_OBJECT_SET (foreign, double, scm_to_double (val)); + break; + case SCM_FOREIGN_TYPE_UINT8: + SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint8, scm_to_uint8 (val)); + break; + case SCM_FOREIGN_TYPE_INT8: + SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int8, scm_to_int8 (val)); + break; + case SCM_FOREIGN_TYPE_UINT16: + SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint16, scm_to_uint16 (val)); + break; + case SCM_FOREIGN_TYPE_INT16: + SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int16, scm_to_int16 (val)); + break; + case SCM_FOREIGN_TYPE_UINT32: + SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint32, scm_to_uint32 (val)); + break; + case SCM_FOREIGN_TYPE_INT32: + SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int32, scm_to_int32 (val)); + break; + case SCM_FOREIGN_TYPE_UINT64: + SCM_FOREIGN_OBJECT_SET (foreign, scm_t_uint64, scm_to_uint64 (val)); + break; + case SCM_FOREIGN_TYPE_INT64: + SCM_FOREIGN_OBJECT_SET (foreign, scm_t_int64, scm_to_int64 (val)); + break; + case SCM_FOREIGN_TYPE_VOID: + case SCM_FOREIGN_TYPE_STRUCT: + case SCM_FOREIGN_TYPE_POINTER: + default: + /* other cases should have been caught by the FOREIGN_SIMPLE check */ + abort (); + } + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +void +scm_i_foreign_print (SCM foreign, SCM port, scm_print_state *pstate) +{ + scm_puts ("#', port); +} + + + +void +scm_init_foreign (void) +{ +#ifndef SCM_MAGIC_SNARFER +#include "libguile/foreign.x" +#endif +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/foreign.h b/libguile/foreign.h new file mode 100644 index 000000000..954c1c5b3 --- /dev/null +++ b/libguile/foreign.h @@ -0,0 +1,87 @@ +/* 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 + * the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA + */ + +#ifndef SCM_FOREIGN_H +#define SCM_FOREIGN_H + + + +/* A subset of libffi's types. */ +typedef enum + { + SCM_FOREIGN_TYPE_VOID, + SCM_FOREIGN_TYPE_FLOAT, + SCM_FOREIGN_TYPE_DOUBLE, + SCM_FOREIGN_TYPE_UINT8, + SCM_FOREIGN_TYPE_INT8, + SCM_FOREIGN_TYPE_UINT16, + SCM_FOREIGN_TYPE_INT16, + SCM_FOREIGN_TYPE_UINT32, + SCM_FOREIGN_TYPE_INT32, + SCM_FOREIGN_TYPE_UINT64, + SCM_FOREIGN_TYPE_INT64, + SCM_FOREIGN_TYPE_STRUCT, + SCM_FOREIGN_TYPE_POINTER + } scm_t_foreign_type; + + +typedef void (*scm_t_foreign_finalizer) (void *); + +#define SCM_FOREIGN_P(x) \ + (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_foreign) +#define SCM_VALIDATE_FOREIGN(pos, x) \ + 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_TYPED_P(x, type) \ + (SCM_FOREIGN_P (x) && SCM_FOREIGN_TYPE (x) == SCM_FOREIGN_TYPE_##type) +#define SCM_VALIDATE_FOREIGN_TYPED(pos, x, type) \ + do { \ + SCM_ASSERT_TYPE (SCM_FOREIGN_TYPED_P (x, type), x, pos, FUNC_NAME, \ + "FOREIGN_"#type"_P"); \ + } while (0) + +#define SCM_FOREIGN_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); + +SCM_INTERNAL void scm_i_foreign_print (SCM foreign, SCM port, + scm_print_state *pstate); +SCM_INTERNAL void scm_init_foreign (void); + + +#endif /* SCM_FOREIGN_H */ diff --git a/libguile/gc.c b/libguile/gc.c index e33d43e2e..d5943b42a 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009, 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 @@ -748,6 +748,8 @@ 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: + return "foreign"; case scm_tc7_hashtable: return "hashtable"; case scm_tc7_fluid: diff --git a/libguile/goops.c b/libguile/goops.c index 9fb6d4a6c..983fa5924 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009 +/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010 * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or @@ -157,6 +157,7 @@ SCM scm_class_protected_hidden, scm_class_protected_opaque, scm_class_protected_ SCM scm_class_scm; SCM scm_class_int, scm_class_float, scm_class_double; +static SCM class_foreign; static SCM class_hashtable; static SCM class_fluid; static SCM class_dynamic_state; @@ -213,6 +214,8 @@ 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: + return class_foreign; case scm_tc7_hashtable: return class_hashtable; case scm_tc7_fluid: @@ -2394,6 +2397,8 @@ create_standard_classes (void) scm_class_class, scm_class_top, SCM_EOL); make_stdcls (&scm_class_vector, "", scm_class_class, scm_class_top, SCM_EOL); + make_stdcls (&class_foreign, "", + scm_class_class, scm_class_top, SCM_EOL); make_stdcls (&class_hashtable, "", scm_class_class, scm_class_top, SCM_EOL); make_stdcls (&class_fluid, "", diff --git a/libguile/init.c b/libguile/init.c index 0571d6b67..81db86bea 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2009 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2009, 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 @@ -474,6 +474,7 @@ scm_i_init_guile (SCM_STACKITEM *base) scm_init_ports (); scm_init_hash (); scm_init_hashtab (); + scm_init_foreign (); scm_init_deprecation (); scm_init_objprop (); scm_init_promises (); /* requires smob_prehistory */ diff --git a/libguile/print.c b/libguile/print.c index d50df2d24..6e3d1f444 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995-1999,2000,2001, 2002, 2003, 2004, 2006, 2008, 2009 Free Software Foundation, Inc. +/* Copyright (C) 1995-1999,2000,2001, 2002, 2003, 2004, 2006, 2008, 2009, 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 @@ -708,6 +708,9 @@ 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); + break; case scm_tc7_hashtable: scm_i_hashtable_print (exp, port, pstate); break; diff --git a/libguile/tags.h b/libguile/tags.h index e1e0913fe..d2e66e330 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -3,7 +3,7 @@ #ifndef SCM_TAGS_H #define SCM_TAGS_H -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009 +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010 * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or @@ -411,7 +411,7 @@ typedef scm_t_uintptr scm_t_bits; #define scm_tc7_stringbuf 39 #define scm_tc7_bytevector 77 -#define scm_tc7_unused_1 31 +#define scm_tc7_foreign 31 #define scm_tc7_hashtable 29 #define scm_tc7_fluid 37 #define scm_tc7_dynamic_state 45