#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
#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"
finalizers.c \
fluids.c \
foreign.c \
+ foreign-object.c \
fports.c \
frames.c \
gc-malloc.c \
filesys.h \
fluids.h \
foreign.h \
+ foreign-object.h \
fports.h \
frames.h \
gc.h \
--- /dev/null
+/* 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
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/goops.h"
+#include "libguile/foreign-object.h"
+
+
+\f
+
+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);
+}
--- /dev/null
+#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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+#include "libguile/print.h"
+
+
+\f
+
+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 */
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 ();
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 \
--- /dev/null
+;;; 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 ...))))))))))
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}
--- /dev/null
+/* 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;
+}
--- /dev/null
+#!/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:
HCoop / bpt / guile.git / commitdiff