From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Andy Wingo Newsgroups: gmane.lisp.guile.devel Subject: RFC: Foreign objects facility Date: Sun, 27 Apr 2014 15:17:21 +0200 Message-ID: <87bnvm52u6.fsf@pobox.com> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: ger.gmane.org 1398604672 20347 80.91.229.3 (27 Apr 2014 13:17:52 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Sun, 27 Apr 2014 13:17:52 +0000 (UTC) To: guile-devel Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Sun Apr 27 15:17:48 2014 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1WeOxl-0002BE-1z for guile-devel@m.gmane.org; Sun, 27 Apr 2014 15:17:45 +0200 Original-Received: from localhost ([::1]:39281 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1WeOxk-00049c-J1 for guile-devel@m.gmane.org; Sun, 27 Apr 2014 09:17:44 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:53377) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1WeOxc-00049J-9I for guile-devel@gnu.org; Sun, 27 Apr 2014 09:17:40 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1WeOxW-0006H5-SK for guile-devel@gnu.org; Sun, 27 Apr 2014 09:17:36 -0400 Original-Received: from a-pb-sasl-quonix.pobox.com ([208.72.237.25]:33869 helo=sasl.smtp.pobox.com) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1WeOxW-0006Gv-LK for guile-devel@gnu.org; Sun, 27 Apr 2014 09:17:30 -0400 Original-Received: from sasl.smtp.pobox.com (unknown [127.0.0.1]) by a-pb-sasl-quonix.pobox.com (Postfix) with ESMTP id F05C110645; Sun, 27 Apr 2014 09:17:29 -0400 (EDT) DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to:cc :subject:date:message-id:mime-version:content-type; s=sasl; bh=2 qEFmZ1KkzTFwOCCUFJj1mYWfog=; b=Hd19ikFGt3PTdRttQwoZqTXySDR9sZucJ 2iJBBVOVxMYuR6wFSrZKtKK6oCcyW29SA1nwE3N74HmivjYmhPFqmp+4ixi0FQzB 1BheT+NpRfXMxY/63LrXwyGJvfKkoDi8QezaEAC3qk6Vnwd7ee7qWVSijPb5l4hB DEEeRePuQA= DomainKey-Signature: a=rsa-sha1; c=nofws; d=pobox.com; h=from:to:cc :subject:date:message-id:mime-version:content-type; q=dns; s= sasl; b=myfnJ3Jhkv/ZtxFK6AoTU2aDb8sgCGGLm9BLk5VgyS0//crE8aP3iS4P 0eEmxbu+2hLwzAkeus8ATIFA3xUEYyXgIGZ3mreDb44hTDO3Nsz5B4nCj4rP5A18 INch+7q8c9qauhy+CTKGn9ZvFoLp0xDEkU9aLVLyFV61FIc//Zg= Original-Received: from a-pb-sasl-quonix.pobox.com (unknown [127.0.0.1]) by a-pb-sasl-quonix.pobox.com (Postfix) with ESMTP id DFD3110644; Sun, 27 Apr 2014 09:17:29 -0400 (EDT) Original-Received: from badger (unknown [88.160.190.192]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (No client certificate requested) by a-pb-sasl-quonix.pobox.com (Postfix) with ESMTPSA id 09EEC10643; Sun, 27 Apr 2014 09:17:24 -0400 (EDT) User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/24.3 (gnu/linux) X-Pobox-Relay-ID: 461EEB48-CE0E-11E3-BC68-6F330E5B5709-02397024!a-pb-sasl-quonix.pobox.com X-detected-operating-system: by eggs.gnu.org: Solaris 10 X-Received-From: 208.72.237.25 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:17104 Archived-At: --=-=-= Content-Type: text/plain 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 # 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 --=-=-= Content-Type: text/plain Content-Disposition: inline; filename=0001-New-foreign-object-facility-to-replace-SMOBs.patch >From a12efcfaae1c65cc703616ea15106a88efba3f55 Mon Sep 17 00:00:00 2001 From: Andy Wingo 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 @@ 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 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 +#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 #:init-keyword #:finalizer #:init-value #f + #:getter finalizer)) + +(define-method (allocate-instance (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 + #:init-keyword (symbol->keyword slot) + #:init-value 0)) + slots))) + (if finalizer + (make-class '() dslots #:name name + #:finalizer finalizer #:metaclass ) + (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 +#endif + +#include + +#include +#include +#include + +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 (""); + 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 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 ) port) + (format port "< ~s>" (cstr->string cstr))) + +(define-method (display (cstr ) port) + (display (cstr->string cstr) port)) + +(define-method (+ (a ) (b )) + (string->cstr (string-append (cstr->string a) (cstr->string b)))) + +(define-method (equal? (a ) (b )) + (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 #:addr addr #:len len)))) + +;; Subclassing. +(define-class () + (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 #:addr addr #:len len + #:wrapped-string string)))) + +(let ((wrapped-cstr (string->wrapped-cstr "Hello, world!"))) + ;; Tests that methods work on . + (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 --=-=-= Content-Type: text/plain -- http://wingolog.org/ --=-=-=--