summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--doc/ref/api-foreign.texi74
-rw-r--r--module/system/foreign.scm41
-rw-r--r--test-suite/tests/foreign.test29
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"