Merge remote-tracking branch 'origin/stable-2.0'

[bpt/guile.git] / module / system / foreign.scm

diff --git a/module/system/foreign.scm b/module/system/foreign.scm
index 16834ce..01a71b8 100644 (file)
--- a/module/system/foreign.scm
+++ b/module/system/foreign.scm
@@ -1,4 +1,4 @@
-;;;;   Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;;   Copyright (C) 2010, 2011, 2013 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
@@ -25,7 +25,7 @@
             float double
             short
             unsigned-short
-            int unsigned-int long unsigned-long size_t
+            int unsigned-int long unsigned-long size_t ssize_t ptrdiff_t
             int8 uint8
             uint16 int16
             uint32 int32
@@ -37,6 +37,8 @@
             null-pointer?
             pointer?
             make-pointer
+            pointer->scm
+            scm->pointer
             pointer-address
 
             pointer->bytevector
@@ -178,20 +180,8 @@ 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)
-       (and (symbol? (syntax->datum #'pred))
-            (symbol? (syntax->datum #'wrap))
-            (symbol? (syntax->datum #'unwrap)))
-
-       ;; Choose TYPE-NAME deterministically to help separate
-       ;; compilation.  It could be an arg of the macro, but that would
-       ;; expose an implementation detail.
-       (with-syntax ((type-name (datum->syntax
-                                 #'pred
-                                 (symbol-append '%%
-                                                (syntax->datum #'pred)
-                                                '-type-name)))
-                     (%wrap     (datum->syntax #'wrap (gensym "wrap"))))
+      ((_ type-name pred wrap unwrap print)
+       (with-syntax ((%wrap (datum->syntax #'wrap (gensym "wrap"))))
          #'(begin
              (define-record-type type-name
                (%wrap pointer)
@@ -202,9 +192,8 @@ which does the reverse.  PRINT must name a user-defined object printer."
                ;; 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))))))
+                   (or (hash-ref ptr->obj ptr)
+                       (let ((o (%wrap ptr)))
+                         (hash-set! ptr->obj ptr o)
+                         o)))))
              (set-record-type-printer! type-name print)))))))