Add `define-wrapped-pointer-type'.

* module/system/foreign.scm (define-wrapped-pointer-type): New macro.

* doc/ref/api-foreign.texi (Foreign Types): Mention the `*' symbol.
  (Void Pointers and Byte Access): Document `define-wrapped-pointer-type'.

* test-suite/tests/foreign.test ("define-wrapped-pointer-type"): New
  test prefix.

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:
 

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)))))))

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
@@ -60,6 +60,33 @@
   (pass-if "not equal?"
     (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"