diff options
-rw-r--r-- | doc/ref/api-foreign.texi | 74 | ||||
-rw-r--r-- | module/system/foreign.scm | 41 | ||||
-rw-r--r-- | test-suite/tests/foreign.test | 29 |
3 files changed, 139 insertions, 5 deletions
diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi index 69a10933f..9b9e481dc 100644 --- a/doc/ref/api-foreign.texi +++ b/doc/ref/api-foreign.texi @@ -1,7 +1,7 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2008, 2009, 2010 -@c Free Software Foundation, Inc. +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2008, +@c 2009, 2010, 2011 Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node Foreign Function Interface @@ -495,6 +495,10 @@ The @code{void} type. It can be used as the first argument to @code{pointer->procedure} to wrap a C function that returns nothing. @end defvr +In addition, the symbol @code{*} is used by convention to denote pointer +types. Procedures detailed in the following sections, such as +@code{pointer->procedure}, accept it as a type descriptor. + @node Foreign Variables @subsubsection Foreign Variables @@ -613,6 +617,72 @@ in the current locale encoding. This is the Scheme equivalent of @code{scm_from_locale_string}. @end deffn +@cindex wrapped pointer types +Most object-oriented C libraries use pointers to specific data +structures to identify objects. It is useful in such cases to reify the +different pointer types as disjoint Scheme types. The +@code{define-wrapped-pointer-type} macro simplifies this. + +@deffn {Scheme Syntax} define-wrapped-pointer-type pred wrap unwrap print +Define helper procedures to wrap pointer objects into Scheme objects +with a disjoint type. Specifically, this macro defines: + +@itemize +@item @var{pred}, a predicate for the new Scheme type; +@item @var{wrap}, a procedure that takes a pointer object and returns an +object that satisfies @var{pred}; +@item @var{unwrap}, which does the reverse. +@end itemize + +@var{wrap} preserves pointer identity, for two pointer objects @var{p1} +and @var{p2} that are @code{equal?}, @code{(eq? (@var{wrap} @var{p1}) +(@var{wrap} @var{p2})) @result{} #t}. + +Finally, @var{print} should name a user-defined procedure to print such +objects. The procedure is passed the wrapped object and a port to write +to. + +For example, assume we are wrapping a C library that defines a type, +@code{bottle_t}, and functions that can be passed @code{bottle_t *} +pointers to manipulate them. We could write: + +@example +(define-wrapped-pointer-type bottle? + wrap-bottle unwrap-bottle + (lambda (b p) + (format p "#<bottle of ~a ~x>" + (bottle-contents b) + (pointer-address (unwrap-foo b))))) + +(define grab-bottle + ;; Wrapper for `bottle_t *grab (void)'. + (let ((grab (pointer->procedure '* + (dynamic-func "grab_bottle" libbottle) + '()))) + (lambda () + "Return a new bottle." + (wrap-bottle (grab))))) + +(define bottle-contents + ;; Wrapper for `const char *bottle_contents (bottle_t *)'. + (let ((contents (pointer->procedure '* + (dynamic-func "bottle_contents" + libbottle) + '(*)))) + (lambda (b) + "Return the contents of B." + (pointer->string (contents (unwrap-bottle b)))))) + +(write (grab-bottle)) +@result{} #<bottle of Ch@^ateau Haut-Brion 803d36> +@end example + +In this example, @code{grab-bottle} is guaranteed to return a genuine +@code{bottle} object satisfying @code{bottle?}. Likewise, +@code{bottle-contents} errors out when its argument is not a genuine +@code{bottle} object. +@end deffn + Going back to the @code{scm_numptob} example above, here is how we can read its value as a C @code{long} integer: diff --git a/module/system/foreign.scm b/module/system/foreign.scm index b15577b2a..a8779e421 100644 --- a/module/system/foreign.scm +++ b/module/system/foreign.scm @@ -1,4 +1,4 @@ -;;;; Copyright (C) 2010 Free Software Foundation, Inc. +;;;; Copyright (C) 2010, 2011 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 @@ -19,6 +19,8 @@ (define-module (system foreign) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) #:export (void float double short @@ -46,7 +48,9 @@ pointer->procedure ;; procedure->pointer (see below) - make-c-struct parse-c-struct)) + make-c-struct parse-c-struct + + define-wrapped-pointer-type)) (eval-when (load eval compile) (load-extension (string-append "libguile-" (effective-version)) @@ -159,3 +163,36 @@ 0 types))) (read-c-struct (pointer->bytevector foreign size) 0 types))) + + +;;; +;;; Wrapped pointer types. +;;; + +(define-syntax define-wrapped-pointer-type + (lambda (stx) + "Define helper procedures to wrap pointer objects into Scheme +objects with a disjoint type. Specifically, this macro defines PRED, a +predicate for the new Scheme type, WRAP, a procedure that takes a +pointer object and returns an object that satisfies PRED, and UNWRAP +which does the reverse. PRINT must name a user-defined object printer." + (syntax-case stx () + ((_ pred wrap unwrap print) + (with-syntax ((type-name (datum->syntax #'pred (gensym))) + (%wrap (datum->syntax #'wrap (gensym)))) + #'(begin + (define-record-type type-name + (%wrap pointer) + pred + (pointer unwrap)) + (define wrap + ;; Use a weak hash table to preserve pointer identity, i.e., + ;; PTR1 == PTR2 <-> (eq? (wrap PTR1) (wrap PTR2)). + (let ((ptr->obj (make-weak-value-hash-table 3000))) + (lambda (ptr) + (let ((key+value (hash-create-handle! ptr->obj ptr #f))) + (or (cdr key+value) + (let ((o (%wrap ptr))) + (set-cdr! key+value o) + o)))))) + (set-record-type-printer! type-name print))))))) diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test index 59ea6b907..dc7371412 100644 --- a/test-suite/tests/foreign.test +++ b/test-suite/tests/foreign.test @@ -1,6 +1,6 @@ ;;;; foreign.test --- FFI. -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2010 Free Software Foundation, Inc. +;;;; Copyright (C) 2010, 2011 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 @@ -61,6 +61,33 @@ (not (equal? (make-pointer 123) (make-pointer 456))))) +(define-wrapped-pointer-type foo? + wrap-foo unwrap-foo + (lambda (x p) + (format p "#<foo! ~a>" (pointer-address (unwrap-foo x))))) + +(with-test-prefix "define-wrapped-pointer-type" + + (pass-if "foo?" + (foo? (wrap-foo %null-pointer))) + + (pass-if "unwrap-foo" + (let ((p (make-pointer 123))) + (eq? p (unwrap-foo (wrap-foo p))))) + + (pass-if "identity" + (let ((p1 (make-pointer 123)) + (p2 (make-pointer 123))) + (eq? (wrap-foo p1) + (wrap-foo p2)))) + + (pass-if "printer" + (string=? "#<foo! 123>" + (with-output-to-string + (lambda () + (write (wrap-foo (make-pointer 123)))))))) + + (with-test-prefix "pointer<->bytevector" (pass-if "bijection" |