[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-6-68-ge77
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-6-68-ge773b1e |
|
Date: |
Mon, 04 Jan 2010 11:38:53 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=e773b1e6ce2af1753034cb1065518c2341228008
The branch, master has been updated
via e773b1e6ce2af1753034cb1065518c2341228008 (commit)
via e2c2a6994d05124760ea7f18caf5d28fb47e453c (commit)
from 208fae8a0ebaa56b69105c89d69e337aef6a3e62 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit e773b1e6ce2af1753034cb1065518c2341228008
Author: Andy Wingo <address@hidden>
Date: Mon Jan 4 12:21:02 2010 +0100
dynamic-func returns foreign objects, not bignums
* libguile/dynl.c (scm_dynamic_func, scm_dynamic_call)
(scm_dynamic_args_call): Change the representation of dynamic
functions to be foreign objects. Shouldn't affect any users, as people
should be treating the return value of dynamic-func as an opaque
object.
commit e2c2a6994d05124760ea7f18caf5d28fb47e453c
Author: Andy Wingo <address@hidden>
Date: Mon Jan 4 12:11:33 2010 +0100
add foreign value wrapper
* libguile/foreign.h:
* libguile/foreign.c: New files, implementing simple wrappers around
foreign values, such as those that one might link in dynamically from
a library.
* libguile/tags.h (scm_tc7_foreign): Take a tc7 for foreign values.
* libguile.h:
* libguile/init.c: Add foreign.h to headers and init.
* libguile/print.c (iprin1): Add printer for foreign values.
* libguile/gc.c (scm_i_tag_name): Case for foreign values.
* libguile/goops.c (scm_class_of, create_standard_classes): Add a class
for foreign values.
* libguile/evalext.c (scm_self_evaluating_p): Add case for foreign
values.
* libguile/Makefile.am: Add foreign.[ch] to the build.
-----------------------------------------------------------------------
Summary of changes:
libguile.h | 3 +-
libguile/Makefile.am | 6 +-
libguile/dynl.c | 16 ++--
libguile/evalext.c | 3 +-
libguile/foreign.c | 288 ++++++++++++++++++++++++++++++++++++++++++++++++++
libguile/foreign.h | 87 +++++++++++++++
libguile/gc.c | 4 +-
libguile/goops.c | 7 +-
libguile/init.c | 3 +-
libguile/print.c | 5 +-
libguile/tags.h | 4 +-
11 files changed, 409 insertions(+), 17 deletions(-)
create mode 100644 libguile/foreign.c
create mode 100644 libguile/foreign.h
diff --git a/libguile.h b/libguile.h
index 7a8b633..6f1b3f8 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 6e3061f..9bef507 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/dynl.c b/libguile/dynl.c
index 52c43e5..a55ba86 100644
--- a/libguile/dynl.c
+++ b/libguile/dynl.c
@@ -1,7 +1,7 @@
/* dynl.c - dynamic linking
*
* Copyright (C) 1990, 91, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 2001, 2002,
- * 2003, 2008, 2009 Free Software Foundation, Inc.
+ * 2003, 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
@@ -58,6 +58,7 @@ maybe_drag_in_eprintf ()
#include "libguile/lang.h"
#include "libguile/validate.h"
#include "libguile/dynwind.h"
+#include "libguile/foreign.h"
#include <ltdl.h>
@@ -225,10 +226,6 @@ SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
"since it will be added automatically when necessary.")
#define FUNC_NAME s_scm_dynamic_func
{
- /* The returned handle is formed by casting the address of the function to a
- * long value and converting this to a scheme number
- */
-
void (*func) ();
SCM_VALIDATE_STRING (1, name);
@@ -245,7 +242,7 @@ SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
func = (void (*) ()) sysdep_dynl_func (chars, DYNL_HANDLE (dobj),
FUNC_NAME);
scm_dynwind_end ();
- return scm_from_ulong ((unsigned long) func);
+ return scm_c_from_foreign (SCM_FOREIGN_TYPE_POINTER, &func, 0, NULL);
}
}
#undef FUNC_NAME
@@ -275,7 +272,9 @@ SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0,
if (scm_is_string (func))
func = scm_dynamic_func (func, dobj);
- fptr = (void (*) ()) scm_to_ulong (func);
+ SCM_VALIDATE_FOREIGN_TYPED (SCM_ARG1, func, POINTER);
+
+ fptr = SCM_FOREIGN_OBJECT_REF (func, void*);
fptr ();
return SCM_UNSPECIFIED;
}
@@ -303,8 +302,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);
- fptr = (int (*) (int, char **)) scm_to_ulong (func);
+ fptr = SCM_FOREIGN_OBJECT_REF (func, void*);
argv = scm_i_allocate_string_pointers (args);
for (argc = 0; argv[argc]; argc++)
diff --git a/libguile/evalext.c b/libguile/evalext.c
index 84218b3..32f1f4f 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 0000000..8ace4a1
--- /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 <config.h>
+#endif
+
+#include <string.h>
+#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 ("#<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);
+ break;
+ case SCM_FOREIGN_TYPE_DOUBLE:
+ scm_puts ("double ", port);
+ scm_display (scm_foreign_ref (foreign), port);
+ break;
+ case SCM_FOREIGN_TYPE_UINT8:
+ scm_puts ("uint8 ", port);
+ scm_display (scm_foreign_ref (foreign), port);
+ break;
+ case SCM_FOREIGN_TYPE_INT8:
+ scm_puts ("int8 ", port);
+ scm_display (scm_foreign_ref (foreign), port);
+ break;
+ case SCM_FOREIGN_TYPE_UINT16:
+ scm_puts ("uint16 ", port);
+ scm_display (scm_foreign_ref (foreign), port);
+ break;
+ case SCM_FOREIGN_TYPE_INT16:
+ scm_puts ("int16 ", port);
+ scm_display (scm_foreign_ref (foreign), port);
+ break;
+ case SCM_FOREIGN_TYPE_UINT32:
+ scm_puts ("uint32 ", port);
+ scm_display (scm_foreign_ref (foreign), port);
+ break;
+ case SCM_FOREIGN_TYPE_INT32:
+ scm_puts ("int32 ", port);
+ scm_display (scm_foreign_ref (foreign), port);
+ break;
+ case SCM_FOREIGN_TYPE_UINT64:
+ scm_puts ("uint64 ", port);
+ scm_display (scm_foreign_ref (foreign), port);
+ break;
+ case SCM_FOREIGN_TYPE_INT64:
+ scm_puts ("int64 ", port);
+ scm_display (scm_foreign_ref (foreign), 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:
+ scm_puts ("pointer 0x", port);
+ scm_uintprint (SCM_FOREIGN_OBJECT_REF (foreign, scm_t_bits), 16, port);
+ break;
+ default:
+ abort ();
+ }
+ scm_putc ('>', 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 0000000..954c1c5
--- /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 e33d43e..d5943b4 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 9fb6d4a..983fa59 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, "<vector>",
scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&class_foreign, "<foreign>",
+ scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&class_hashtable, "<hashtable>",
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&class_fluid, "<fluid>",
diff --git a/libguile/init.c b/libguile/init.c
index 0571d6b..81db86b 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 d50df2d..6e3d1f4 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 e1e0913..d2e66e3 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
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-6-68-ge773b1e,
Andy Wingo <=