diff options
| -rw-r--r-- | libguile.h | 3 | ||||
| -rw-r--r-- | libguile/Makefile.am | 2 | ||||
| -rw-r--r-- | libguile/foreign-object.c | 187 | ||||
| -rw-r--r-- | libguile/foreign-object.h | 48 | ||||
| -rw-r--r-- | libguile/init.c | 1 | ||||
| -rw-r--r-- | module/Makefile.am | 1 | ||||
| -rw-r--r-- | module/system/foreign-object.scm | 88 | ||||
| -rw-r--r-- | test-suite/standalone/Makefile.am | 11 | ||||
| -rw-r--r-- | test-suite/standalone/test-foreign-object-c.c | 116 | ||||
| -rwxr-xr-x | test-suite/standalone/test-foreign-object-scm | 119 |
10 files changed, 575 insertions, 1 deletions
diff --git a/libguile.h b/libguile.h index fefca435b..48548c393 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 5decd99c0..2bdf71f65 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -147,6 +147,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_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 000000000..78b017aa5 --- /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 000000000..fadb3b554 --- /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 b3203609c..87a69884e 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 fb9174b52..521318b50 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 000000000..319b0f4e4 --- /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 7c4633a25..9360f6903 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 000000000..9cd8d6721 --- /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 000000000..7e4bd85d8 --- /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: |