[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
RFC: Foreign objects facility
|
From: |
Andy Wingo |
|
Subject: |
RFC: Foreign objects facility |
|
Date: |
Sun, 27 Apr 2014 15:17:21 +0200 |
|
User-agent: |
Gnus/5.13 (Gnus v5.13) Emacs/24.3 (gnu/linux) |
Hi,
SMOBs have a few problems.
1) They are limited in number to 255.
2) It's difficult to refer to a SMOB type from Scheme. You can use
class-of once you have an object, but the class-of isn't exactly
the same as the SMOB tc16, and getting the type beforehand is
gnarly. (See http://article.gmane.org/gmane.comp.gdb.patches/96857
for an example).
3) You can't create SMOB types from Scheme. This goes against our
general trend of making Scheme more powerful.
4) You can't create SMOB objects from Scheme.
5) Similarly, you can't access SMOB fields from Scheme.
6) You can't subclass SMOB types. (Some people would like this
ability.)
7) There is legacy code out there that uses e.g. SCM_SETCDR to set
smob fields. (This is terrible, but it exists:
https://github.com/search?q=SCM_SETCDR+smob&ref=cmdform&type=Code
for an example.)
8) The single/double SMOB thing is outdated and bogus. Objects should
be able to have any number of fields.
9) We document mark functions in the manual, even recommending them,
but they are really difficult to get right (see
https://lists.gnu.org/archive/html/guile-user/2011-11/msg00069.html),
and almost always a bad design -- the BDW GC can do a better job
without them.
And yet, if we consider the generic problem of wrapping C objects in
Scheme objects, it's clear that we have more solutions now than we used
to -- raw #<pointer> values, define-wrapped-pointer-type, etc. But
there's nothing that's accessible to C like SMOBs are, so people that
use the libguile interface to wrap C types and values are out of luck.
I propose to provide a new interface that will eventually make SMOBs
obsolete. This new interface is based on structs with raw fields -- the
'u' fields. (See
http://www.gnu.org/software/guile/docs/master/guile.html/Vtables.html#Vtables
for description of 'u' fields. Note that the documentation is wrong --
these fields are indeed traced by the GC.)
Here is the proposed C API:
SCM scm_make_foreign_object_type (SCM name, SCM slot_names,
scm_t_struct_finalize finalizer);
void scm_assert_foreign_object_type (SCM type, SCM val);
SCM scm_make_foreign_object_1 (SCM type, scm_t_bits val0);
SCM scm_make_foreign_object_2 (SCM type, scm_t_bits val0,
scm_t_bits val1);
SCM scm_make_foreign_object_3 (SCM type, scm_t_bits val0,
scm_t_bits val1, scm_t_bits val2);
SCM scm_make_foreign_object_n (SCM type, size_t n, scm_t_bits vals[]);
scm_t_bits scm_foreign_object_ref (SCM obj, size_t n);
void scm_foreign_object_set_x (SCM obj, size_t n, scm_t_bits val);
The finalizer may be NULL. The scm_make_foreign_object* functions are
just scm_make_struct without the no_tail arguments, and interpreting the
values as raw untagged values, not unpacked SCM values. Same thing with
scm_foreign_object_ref/set_x.
The overhead of a foreign object is two words -- the same as the
overhead on any struct. (Compare to SMOBs, which have a half-word
overhead.)
Here is the proposed Scheme API:
;; Exported from (system foreign-object):
(define* (make-foreign-object-type name slots #:key finalizer)
...)
(define-syntax-rule (define-foreign-object-type name constructor (slot ...)
kwarg ...)
(begin
(define name
(make-foreign-object-type 'name '(slot ...) kwarg ...))
(define slot [getter for slot])
...
(define constructor
(lambda (slot ...)
[...]))))
Foreign object types are GOOPS classes, although this is not really
exposed in the API. Foreign objects are GOOPS objects -- with no
additional overhead of course, compared to structs. You can subclass an
object type; see the test-foreign-object-scm test in the patch below.
So, what do people think? The patch below is against stable-2.0.
Andy
>From a12efcfaae1c65cc703616ea15106a88efba3f55 Mon Sep 17 00:00:00 2001
From: Andy Wingo <address@hidden>
Date: Sun, 27 Apr 2014 14:47:40 +0200
Subject: [PATCH] New foreign object facility, to replace SMOBs
* libguile/foreign-object.c:
* libguile/foreign-object.h:
* module/system/foreign-object.scm:
* test-suite/standalone/test-foreign-object-c.c:
* test-suite/standalone/test-foreign-object-scm: New files.
* test-suite/standalone/Makefile.am:
* module/Makefile.am:
* libguile/Makefile.am: Add new files.
* libguile.h: Add foreign-object.h.
* libguile/init.c (scm_i_init_guile): Call scm_register_foreign_object.
---
libguile.h | 3 +-
libguile/Makefile.am | 2 +
libguile/foreign-object.c | 187 ++++++++++++++++++++++++++
libguile/foreign-object.h | 48 +++++++
libguile/init.c | 1 +
module/Makefile.am | 1 +
module/system/foreign-object.scm | 88 ++++++++++++
test-suite/standalone/Makefile.am | 11 ++
test-suite/standalone/test-foreign-object-c.c | 116 ++++++++++++++++
test-suite/standalone/test-foreign-object-scm | 119 ++++++++++++++++
10 files changed, 575 insertions(+), 1 deletion(-)
create mode 100644 libguile/foreign-object.c
create mode 100644 libguile/foreign-object.h
create mode 100644 module/system/foreign-object.scm
create mode 100644 test-suite/standalone/test-foreign-object-c.c
create mode 100755 test-suite/standalone/test-foreign-object-scm
diff --git a/libguile.h b/libguile.h
index fefca43..48548c3 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, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2008,
2009, 2010, 2011, 2012, 2014 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
@@ -52,6 +52,7 @@ extern "C" {
#include "libguile/finalizers.h"
#include "libguile/fluids.h"
#include "libguile/foreign.h"
+#include "libguile/foreign-object.h"
#include "libguile/fports.h"
#include "libguile/gc.h"
#include "libguile/gdbint.h"
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 5decd99..2bdf71f 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -147,6 +147,7 @@ address@hidden@_la_SOURCES =
\
finalizers.c \
fluids.c \
foreign.c \
+ foreign-object.c \
fports.c \
frames.c \
gc-malloc.c \
@@ -573,6 +574,7 @@ modinclude_HEADERS = \
filesys.h \
fluids.h \
foreign.h \
+ foreign-object.h \
fports.h \
frames.h \
gc.h \
diff --git a/libguile/foreign-object.c b/libguile/foreign-object.c
new file mode 100644
index 0000000..78b017a
--- /dev/null
+++ b/libguile/foreign-object.c
@@ -0,0 +1,187 @@
+/* Copyright (C) 2014 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
+ */
+
+
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/goops.h"
+#include "libguile/foreign-object.h"
+
+
+
+
+static SCM make_fobj_type_var;
+
+static void
+init_make_fobj_type_var (void)
+{
+ make_fobj_type_var = scm_c_private_lookup ("system foreign-object",
+ "make-foreign-object-type");
+}
+
+SCM
+scm_make_foreign_object_type (SCM name, SCM slot_names,
+ scm_t_struct_finalize finalizer)
+{
+ SCM type;
+
+ static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+ scm_i_pthread_once (&once, init_make_fobj_type_var);
+
+ type = scm_call_2 (scm_variable_ref (make_fobj_type_var), name, slot_names);
+
+ if (finalizer)
+ SCM_SET_VTABLE_INSTANCE_FINALIZER (type, finalizer);
+
+ return type;
+}
+
+void
+scm_assert_foreign_object_type (SCM type, SCM val)
+{
+ if (!SCM_IS_A_P (val, type))
+ scm_error (scm_arg_type_key, NULL, "Wrong type (expecting ~A): ~S",
+ scm_list_2 (scm_class_name (type), val), scm_list_1 (val));
+}
+
+SCM
+scm_make_foreign_object_1 (SCM type, scm_t_bits val0)
+{
+ return scm_make_foreign_object_n (type, 1, &val0);
+}
+
+SCM
+scm_make_foreign_object_2 (SCM type, scm_t_bits val0, scm_t_bits val1)
+{
+ scm_t_bits vals[2] = { val0, val1 };
+
+ return scm_make_foreign_object_n (type, 2, vals);
+}
+
+SCM
+scm_make_foreign_object_3 (SCM type, scm_t_bits val0, scm_t_bits val1,
+ scm_t_bits val2)
+{
+ scm_t_bits vals[3] = { val0, val1, val2 };
+
+ return scm_make_foreign_object_n (type, 3, vals);
+}
+
+SCM
+scm_make_foreign_object_n (SCM type, size_t n, scm_t_bits vals[])
+#define FUNC_NAME "make-foreign-object"
+{
+ SCM obj;
+ SCM layout;
+ size_t i;
+
+ SCM_VALIDATE_VTABLE (SCM_ARG1, type);
+
+ layout = SCM_VTABLE_LAYOUT (type);
+
+ if (scm_i_symbol_length (layout) / 2 < n)
+ scm_out_of_range (FUNC_NAME, scm_from_size_t (n));
+
+ for (i = 0; i < n; i++)
+ if (scm_i_symbol_ref (layout, i * 2) != 'u')
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, layout, "'u' field");
+
+ obj = scm_c_make_structv (type, 0, 0, NULL);
+
+ for (i = 0; i < n; i++)
+ SCM_STRUCT_DATA_SET (obj, i, vals[i]);
+
+ return obj;
+}
+#undef FUNC_NAME
+
+scm_t_bits
+scm_foreign_object_ref (SCM obj, size_t n)
+#define FUNC_NAME "foreign-object-ref"
+{
+ SCM layout;
+
+ SCM_VALIDATE_STRUCT (SCM_ARG1, obj);
+
+ layout = SCM_STRUCT_LAYOUT (obj);
+ if (scm_i_symbol_length (layout) / 2 < n)
+ scm_out_of_range (FUNC_NAME, scm_from_size_t (n));
+
+ if (scm_i_symbol_ref (layout, n * 2) != 'u')
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, layout, "'u' field");
+
+ return SCM_STRUCT_DATA_REF (obj, n);
+}
+#undef FUNC_NAME
+
+void
+scm_foreign_object_set_x (SCM obj, size_t n, scm_t_bits val)
+#define FUNC_NAME "foreign-object-set!"
+{
+ SCM layout;
+
+ SCM_VALIDATE_STRUCT (SCM_ARG1, obj);
+
+ layout = SCM_STRUCT_LAYOUT (obj);
+ if (scm_i_symbol_length (layout) / 2 < n)
+ scm_out_of_range (FUNC_NAME, scm_from_size_t (n));
+
+ if (scm_i_symbol_ref (layout, n * 2) != 'u')
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, layout, "'u' field");
+
+ SCM_STRUCT_DATA_SET (obj, n, val);
+}
+#undef FUNC_NAME
+
+static void
+invoke_finalizer (void *obj, void *data)
+{
+ scm_call_1 (PTR2SCM (data), PTR2SCM (obj));
+}
+
+static SCM
+sys_add_finalizer_x (SCM obj, SCM finalizer)
+#define FUNC_NAME "%add-finalizer!"
+{
+ SCM_VALIDATE_PROC (SCM_ARG2, finalizer);
+
+ scm_i_add_finalizer (SCM2PTR (obj), invoke_finalizer, SCM2PTR (finalizer));
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+static void
+scm_init_foreign_object (void)
+{
+ scm_c_define_gsubr ("%add-finalizer!", 2, 0, 0,
+ (scm_t_subr) sys_add_finalizer_x);
+}
+
+void
+scm_register_foreign_object (void)
+{
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_foreign_object",
+ (scm_t_extension_init_func)scm_init_foreign_object,
+ NULL);
+}
diff --git a/libguile/foreign-object.h b/libguile/foreign-object.h
new file mode 100644
index 0000000..fadb3b5
--- /dev/null
+++ b/libguile/foreign-object.h
@@ -0,0 +1,48 @@
+#ifndef SCM_FOREIGN_OBJECT_H
+#define SCM_FOREIGN_OBJECT_H
+
+/* Copyright (C) 2014 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
+ */
+
+
+
+#include "libguile/__scm.h"
+#include "libguile/print.h"
+
+
+
+
+SCM_API SCM scm_make_foreign_object_type (SCM name, SCM slot_names,
+ scm_t_struct_finalize finalizer);
+
+SCM_API void scm_assert_foreign_object_type (SCM type, SCM val);
+
+SCM_API SCM scm_make_foreign_object_1 (SCM type, scm_t_bits val0);
+SCM_API SCM scm_make_foreign_object_2 (SCM type, scm_t_bits val0,
+ scm_t_bits val1);
+SCM_API SCM scm_make_foreign_object_3 (SCM type, scm_t_bits val0,
+ scm_t_bits val1, scm_t_bits val2);
+SCM_API SCM scm_make_foreign_object_n (SCM type, size_t n, scm_t_bits vals[]);
+
+SCM_API scm_t_bits scm_foreign_object_ref (SCM obj, size_t n);
+SCM_API void scm_foreign_object_set_x (SCM obj, size_t n, scm_t_bits val);
+
+SCM_INTERNAL void scm_register_foreign_object (void);
+
+
+#endif /* SCM_FOREIGN_OBJECT_H */
diff --git a/libguile/init.c b/libguile/init.c
index b320360..87a6988 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -397,6 +397,7 @@ scm_i_init_guile (void *base)
scm_bootstrap_vm ();
scm_register_r6rs_ports ();
scm_register_foreign ();
+ scm_register_foreign_object ();
scm_register_srfi_1 ();
scm_register_srfi_60 ();
scm_register_poll ();
diff --git a/module/Makefile.am b/module/Makefile.am
index fb9174b..521318b 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -361,6 +361,7 @@ SYSTEM_SOURCES = \
system/vm/trap-state.scm \
system/vm/vm.scm \
system/foreign.scm \
+ system/foreign-object.scm \
system/xref.scm \
system/repl/debug.scm \
system/repl/error-handling.scm \
diff --git a/module/system/foreign-object.scm b/module/system/foreign-object.scm
new file mode 100644
index 0000000..319b0f4
--- /dev/null
+++ b/module/system/foreign-object.scm
@@ -0,0 +1,88 @@
+;;; Wrapping foreign objects in Scheme
+
+;;; Copyright (C) 2014 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
+;;;
+
+;;; Commentary:
+;;
+;;
+;;; Code:
+
+(define-module (system foreign-object)
+ #:use-module (oop goops)
+ #:export (make-foreign-object-type
+ define-foreign-object-type))
+
+(eval-when (eval load expand)
+ (load-extension (string-append "libguile-" (effective-version))
+ "scm_init_foreign_object"))
+
+(define-class <finalizer-class> (<class>)
+ (finalizer #:init-keyword #:finalizer #:init-value #f
+ #:getter finalizer))
+
+(define-method (allocate-instance (class <finalizer-class>) initargs)
+ (let ((instance (next-method))
+ (finalizer (finalizer class)))
+ (when finalizer
+ (%add-finalizer! instance finalizer))
+ instance))
+
+(define (getter-method class slot-name existing)
+ (let ((getter (ensure-generic existing slot-name))
+ (slot-def (or (assq slot-name (slot-ref class 'getters-n-setters))
+ (slot-missing class slot-name))))
+ (add-method! getter (compute-getter-method class slot-def))
+ getter))
+
+(define* (make-foreign-object-type name slots #:key finalizer)
+ (unless (symbol? name)
+ (error "type name should be a symbol" name))
+ (unless (or (not finalizer) (procedure? finalizer))
+ (error "finalizer should be a procedure" finalizer))
+ (let ((dslots (map (lambda (slot)
+ (unless (symbol? slot)
+ (error "slot name should be a symbol" slot))
+ (list slot #:class <foreign-slot>
+ #:init-keyword (symbol->keyword slot)
+ #:init-value 0))
+ slots)))
+ (if finalizer
+ (make-class '() dslots #:name name
+ #:finalizer finalizer #:metaclass <finalizer-class>)
+ (make-class '() dslots #:name name))))
+
+(define-syntax define-foreign-object-type
+ (lambda (x)
+ (define (kw-apply slots)
+ (syntax-case slots ()
+ (() #'())
+ ((slot . slots)
+ (let ((kw (symbol->keyword (syntax->datum #'slot))))
+ #`(#,kw slot . #,(kw-apply #'slots))))))
+
+ (syntax-case x ()
+ ((_ name constructor (slot ...) kwarg ...)
+ #`(begin
+ (define name
+ (make-foreign-object-type 'name '(slot ...) kwarg ...))
+ (define slot
+ (getter-method name 'slot (and (defined? 'slot) slot)))
+ ...
+ (define constructor
+ (lambda (slot ...)
+ (make name #,@(kw-apply #'(slot ...))))))))))
diff --git a/test-suite/standalone/Makefile.am
b/test-suite/standalone/Makefile.am
index 7c4633a..9360f69 100644
--- a/test-suite/standalone/Makefile.am
+++ b/test-suite/standalone/Makefile.am
@@ -129,6 +129,17 @@ TESTS += test-ffi
endif HAVE_SHARED_LIBRARIES
+# test-foreign-object-scm
+check_SCRIPTS += test-foreign-object-scm
+TESTS += test-foreign-object-scm
+
+# test-foreign-object-c
+test_foreign_object_c_SOURCES = test-foreign-object-c.c
+test_foreign_object_c_CFLAGS = ${test_cflags}
+test_foreign_object_c_LDADD = $(LIBGUILE_LDADD)
+check_PROGRAMS += test-foreign-object-c
+TESTS += test-foreign-object-c
+
# test-list
test_list_SOURCES = test-list.c
test_list_CFLAGS = ${test_cflags}
diff --git a/test-suite/standalone/test-foreign-object-c.c
b/test-suite/standalone/test-foreign-object-c.c
new file mode 100644
index 0000000..9cd8d67
--- /dev/null
+++ b/test-suite/standalone/test-foreign-object-c.c
@@ -0,0 +1,116 @@
+/* test-foreign-object-c.c - exercise C foreign object interface */
+
+/* Copyright (C) 2014 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
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <libguile.h>
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+
+enum
+ {
+ CSTR_SLOT_ADDR,
+ CSTR_SLOT_LEN,
+ CSTR_SLOT_COUNT
+ };
+
+static void
+finalizer (SCM obj)
+{
+ scm_t_bits addr = scm_foreign_object_ref (obj, CSTR_SLOT_ADDR);
+ free ((void *) addr);
+}
+
+static SCM
+make_cstr_from_static (SCM type, const char *str)
+{
+ char *ours = strdup (str);
+
+ if (!ours)
+ abort ();
+
+ return scm_make_foreign_object_2 (type, (scm_t_bits) ours, strlen (ours));
+}
+
+static int
+cstr_equals_static_p (SCM cstr, const char *str)
+{
+ const char *addr;
+ size_t len;
+
+ addr = (const char *) scm_foreign_object_ref (cstr, CSTR_SLOT_ADDR);
+ len = scm_foreign_object_ref (cstr, CSTR_SLOT_LEN);
+
+ if (strlen (str) != len)
+ return 0;
+
+ return strncmp (addr, str, len) == 0;
+}
+
+static void
+test_scm_foreign_object (void)
+{
+ SCM type_name, slot_names, type, cstr;
+
+ type_name = scm_from_utf8_symbol ("<cstr>");
+ slot_names = scm_list_2 (scm_from_utf8_symbol ("addr"),
+ scm_from_utf8_symbol ("len"));
+ type = scm_make_foreign_object_type (type_name, slot_names, finalizer);
+
+ cstr = make_cstr_from_static (type, "Hello, world!");
+ scm_assert_foreign_object_type (type, cstr);
+
+ if (!cstr_equals_static_p (cstr, "Hello, world!"))
+ {
+ fprintf (stderr, "fail: test-foreign-object 1\n");
+ exit (EXIT_FAILURE);
+ }
+
+ {
+ int i;
+ for (i = 0; i < 5000; i++)
+ cstr = make_cstr_from_static (type, "Hello, world!");
+ cstr = SCM_BOOL_F;
+ }
+
+ scm_gc ();
+ scm_gc ();
+ scm_gc ();
+
+ /* Allow time for the finalizer thread to run. */
+ scm_usleep (scm_from_uint (50 * 1000));
+}
+
+static void
+tests (void *data, int argc, char **argv)
+{
+ test_scm_foreign_object ();
+}
+
+int
+main (int argc, char *argv[])
+{
+ scm_boot_guile (argc, argv, tests, NULL);
+ return 0;
+}
diff --git a/test-suite/standalone/test-foreign-object-scm
b/test-suite/standalone/test-foreign-object-scm
new file mode 100755
index 0000000..7e4bd85
--- /dev/null
+++ b/test-suite/standalone/test-foreign-object-scm
@@ -0,0 +1,119 @@
+#!/bin/sh
+exec guile -q -s "$0" "$@"
+!#
+;;; test-foreign-object-scm --- Foreign object interface. -*- Scheme -*-
+;;;
+;;; Copyright (C) 2014 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
+
+(use-modules (system foreign)
+ (system foreign-object)
+ (rnrs bytevectors)
+ (oop goops))
+
+(define (libc-ptr name)
+ (catch #t
+ (lambda () (dynamic-pointer name (dynamic-link)))
+ (lambda (k . args)
+ (print-exception (current-error-port) #f k args)
+ (write "Skipping test.\n" (current-error-port))
+ (exit 0))))
+
+(define malloc (pointer->procedure '* (libc-ptr "malloc") (list size_t)))
+(define memcpy (pointer->procedure void (libc-ptr "memcpy") (list '* '*
size_t)))
+(define free (pointer->procedure void (libc-ptr "free") '(*)))
+
+(define (finalize-cstr cstr)
+ (free (make-pointer (addr cstr))))
+
+(define-foreign-object-type <cstr> make-cstr (addr len)
+ #:finalizer finalize-cstr)
+
+(define (cstr->string cstr)
+ (pointer->string (make-pointer (addr cstr)) (len cstr) "UTF-8"))
+
+(define* (string->cstr str #:optional (k make-cstr))
+ (let* ((bv (string->utf8 str))
+ (len (bytevector-length bv))
+ (mem (malloc len)))
+ (when (null-pointer? mem)
+ (error "Out of memory."))
+ (memcpy mem (bytevector->pointer bv) len)
+ (k (pointer-address mem) len)))
+
+(define-method (write (cstr <cstr>) port)
+ (format port "<<cstr> ~s>" (cstr->string cstr)))
+
+(define-method (display (cstr <cstr>) port)
+ (display (cstr->string cstr) port))
+
+(define-method (+ (a <cstr>) (b <cstr>))
+ (string->cstr (string-append (cstr->string a) (cstr->string b))))
+
+(define-method (equal? (a <cstr>) (b <cstr>))
+ (equal? (cstr->string a) (cstr->string b)))
+
+(define failed? #f)
+(define-syntax test
+ (syntax-rules ()
+ ((_ exp res)
+ (let ((expected res)
+ (actual exp))
+ (if (not (equal? actual expected))
+ (begin
+ (set! failed? #t)
+ (format (current-error-port)
+ "bad return from expression `~a': expected ~A; got ~A~%"
+ 'exp expected actual)))))))
+
+(test (string->cstr "Hello, world!")
+ (+ (string->cstr "Hello, ") (string->cstr "world!")))
+
+;; GOOPS construction syntax instead of make-cstr.
+(test (string->cstr "Hello, world!")
+ (string->cstr "Hello, world!"
+ (lambda (addr len)
+ (make <cstr> #:addr addr #:len len))))
+
+;; Subclassing.
+(define-class <wrapped-cstr> (<cstr>)
+ (wrapped-string #:init-keyword #:wrapped-string
+ #:getter wrapped-string
+ #:init-form (error "missing #:wrapped-string")))
+
+(define (string->wrapped-cstr string)
+ (string->cstr string (lambda (addr len)
+ (make <wrapped-cstr> #:addr addr #:len len
+ #:wrapped-string string))))
+
+(let ((wrapped-cstr (string->wrapped-cstr "Hello, world!")))
+ ;; Tests that <cst> methods work on <wrapped-cstr>.
+ (test "Hello, world!" (cstr->string wrapped-cstr))
+ ;; Test the additional #:wrapped-string slot.
+ (test "Hello, world!" (wrapped-string wrapped-cstr)))
+
+(gc) (gc) (gc)
+
+;; Sleep 50 milliseconds to allow the finalization thread to run.
+(usleep #e50e3)
+
+;; But we don't really know if it ran. Oh well.
+
+(exit (if failed? 1 0))
+
+;; Local Variables:
+;; mode: scheme
+;; End:
--
2.0.0.rc0
--
http://wingolog.org/