[Guile-commits] GNU Guile branch, master, updated. release_1-9-14-149-g6e09756

[Ludovic Courtès]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=6e0975603eb4e568def1a91f9b127a6a35bdbe44

The branch, master has been updated
       via  6e0975603eb4e568def1a91f9b127a6a35bdbe44 (commit)
       via  690a0112e55823aa8b862daeddcf44cea97e7917 (commit)
       via  1f4f7674bc352be9c5bdce0e0fb346345b04fa81 (commit)
      from  2519490c50ae063ef27201c5403e80628fff9eeb (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 6e0975603eb4e568def1a91f9b127a6a35bdbe44
Author: Ludovic Courtès <address@hidden>
Date:   Sun Jan 30 22:47:35 2011 +0100

    Add `pointer?'.
    
    * libguile/foreign.c (scm_pointer_p): New function.
    * libguile/foreign.h (scm_pointer_p): New declaration.
    * module/system/foreign.scm: Export `pointer?'.
    
    * test-suite/tests/foreign.test ("null pointer")["pointer?"]: New
      test.
      ("make-pointer")["pointer?"]: New test.
    
    * doc/ref/api-foreign.texi (Foreign Variables): Document `pointer?'.

commit 690a0112e55823aa8b862daeddcf44cea97e7917
Author: Ludovic Courtès <address@hidden>
Date:   Sun Jan 30 22:05:21 2011 +0100

    Remove the "has finalizer?" bit from pointer objects.
    
    * libguile/foreign.h (SCM_POINTER_HAS_FINALIZER): Remove.
    
    * libguile/foreign.c (scm_from_pointer): Store nothing more than
      `scm_tc7_pointer' in the type slot.

commit 1f4f7674bc352be9c5bdce0e0fb346345b04fa81
Author: Ludovic Courtès <address@hidden>
Date:   Sun Jan 30 22:00:35 2011 +0100

    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.

-----------------------------------------------------------------------

Summary of changes:
 doc/ref/api-foreign.texi      |   78 +++++++++++++++++++++++++++++++++++++++-
 libguile/foreign.c            |   15 ++++++--
 libguile/foreign.h            |    5 +--
 module/system/foreign.scm     |   42 +++++++++++++++++++++-
 test-suite/tests/foreign.test |   35 ++++++++++++++++++-
 5 files changed, 163 insertions(+), 12 deletions(-)

diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi
index 69a1093..f275242 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.
address@hidden Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 
2008, 2009, 2010
address@hidden   Free Software Foundation, Inc.
address@hidden Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 
2008,
address@hidden   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
address@hidden>procedure}, accept it as a type descriptor.
+
 @node Foreign Variables
 @subsubsection Foreign Variables
 
@@ -545,6 +549,10 @@ function that will be called when the pointer object 
becomes
 unreachable.
 @end deffn
 
address@hidden {Scheme Procedure} pointer? obj
+Return @code{#t} if @var{obj} is a pointer object, @code{#f} otherwise.
address@hidden deffn
+
 @defvr {Scheme Variable} %null-pointer
 A foreign pointer whose value is 0.
 @end defvr
@@ -613,6 +621,72 @@ in the current locale encoding.
 This is the Scheme equivalent of @code{scm_from_locale_string}.
 @end deffn
 
address@hidden 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
address@hidden macro simplifies this.
+
address@hidden {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:
+
address@hidden
address@hidden @var{pred}, a predicate for the new Scheme type;
address@hidden @var{wrap}, a procedure that takes a pointer object and returns 
an
+object that satisfies @var{pred};
address@hidden @var{unwrap}, which does the reverse.
address@hidden itemize
+
address@hidden 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,
address@hidden, and functions that can be passed @code{bottle_t *}
+pointers to manipulate them.  We could write:
+
address@hidden
+(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))
address@hidden #<bottle of address@hidden Haut-Brion 803d36>
address@hidden example
+
+In this example, @code{grab-bottle} is guaranteed to return a genuine
address@hidden object satisfying @code{bottle?}.  Likewise,
address@hidden errors out when its argument is not a genuine
address@hidden object.
address@hidden 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/libguile/foreign.c b/libguile/foreign.c
index 47579af..52da23f 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -100,6 +100,16 @@ pointer_finalizer_trampoline (GC_PTR ptr, GC_PTR data)
   finalizer (SCM_POINTER_VALUE (PTR2SCM (ptr)));
 }
 
+SCM_DEFINE (scm_pointer_p, "pointer?", 1, 0, 0,
+           (SCM obj),
+           "Return @code{#t} if @var{obj} is a pointer object, "
+           "@code{#f} otherwise.\n")
+#define FUNC_NAME s_scm_pointer_p
+{
+  return scm_from_bool (SCM_POINTER_P (obj));
+}
+#undef FUNC_NAME
+
 SCM_DEFINE (scm_make_pointer, "make-pointer", 1, 1, 0,
            (SCM address, SCM finalizer),
            "Return a foreign pointer object pointing to @var{address}. "
@@ -133,10 +143,7 @@ scm_from_pointer (void *ptr, scm_t_pointer_finalizer 
finalizer)
     ret = null_pointer;
   else
     {
-      scm_t_bits type;
-
-      type = scm_tc7_pointer | (finalizer ? (1 << 16UL) : 0UL);
-      ret = scm_cell (type, (scm_t_bits) ptr);
+      ret = scm_cell (scm_tc7_pointer, (scm_t_bits) ptr);
 
       if (finalizer)
        {
diff --git a/libguile/foreign.h b/libguile/foreign.h
index e534d48..b290019 100644
--- a/libguile/foreign.h
+++ b/libguile/foreign.h
@@ -1,7 +1,7 @@
 #ifndef SCM_FOREIGN_H
 #define SCM_FOREIGN_H
 
-/* 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 License
@@ -55,8 +55,6 @@ typedef void (*scm_t_pointer_finalizer) (void *);
   SCM_MAKE_VALIDATE (pos, x, POINTER_P)
 #define SCM_POINTER_VALUE(x)                   \
   ((void *) SCM_CELL_WORD_1 (x))
-#define SCM_POINTER_HAS_FINALIZER(x)           \
-  ((SCM_CELL_WORD_0 (x) >> 16) & 0x1)
 
 SCM_API SCM scm_from_pointer (void *, scm_t_pointer_finalizer);
 
@@ -68,6 +66,7 @@ SCM_API SCM scm_pointer_to_bytevector (SCM pointer, SCM type,
 SCM_API SCM scm_set_pointer_finalizer_x (SCM pointer, SCM finalizer);
 SCM_API SCM scm_bytevector_to_pointer (SCM bv, SCM offset);
 
+SCM_INTERNAL SCM scm_pointer_p (SCM obj);
 SCM_INTERNAL SCM scm_make_pointer (SCM address, SCM finalizer);
 SCM_INTERNAL void scm_i_pointer_print (SCM pointer, SCM port,
                                        scm_print_state *pstate);
diff --git a/module/system/foreign.scm b/module/system/foreign.scm
index b15577b..4b0618b 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
@@ -33,6 +35,7 @@
 
             %null-pointer
             null-pointer?
+            pointer?
             make-pointer
             pointer-address
 
@@ -46,7 +49,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 +164,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 59ea6b9..a0ded0b 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
@@ -30,6 +30,9 @@
 
 (with-test-prefix "null pointer"
 
+  (pass-if "pointer?"
+    (pointer? %null-pointer))
+
   (pass-if "zero"
     (= 0 (pointer-address %null-pointer)))
 
@@ -46,6 +49,9 @@
 
 (with-test-prefix "make-pointer"
 
+  (pass-if "pointer?"
+    (pointer? (make-pointer 123)))
+
   (pass-if "address preserved"
     (= 123 (pointer-address (make-pointer 123))))
 
@@ -61,6 +67,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"


hooks/post-receive
-- 
GNU Guile