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 617b6aa..01a71b8 100644 (file)
--- 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, 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
@@ -18,9 +18,14 @@
 
 (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
-            int unsigned-int long unsigned-long size_t
+            short
+            unsigned-short
+            int unsigned-int long unsigned-long size_t ssize_t ptrdiff_t
             int8 uint8
             uint16 int16
             uint32 int32
@@ -30,19 +35,29 @@
 
             %null-pointer
             null-pointer?
+            pointer?
             make-pointer
+            pointer->scm
+            scm->pointer
             pointer-address
-            dereference-pointer
 
             pointer->bytevector
             bytevector->pointer
             set-pointer-finalizer!
 
-            make-foreign-function
-            make-c-struct parse-c-struct))
+            dereference-pointer
+            string->pointer
+            pointer->string
+
+            pointer->procedure
+            ;; procedure->pointer (see below)
+            make-c-struct parse-c-struct
 
-(load-extension (string-append "libguile-" (effective-version))
-                "scm_init_foreign")
+            define-wrapped-pointer-type))
+
+(eval-when (load eval compile)
+  (load-extension (string-append "libguile-" (effective-version))
+                  "scm_init_foreign"))
 
 \f
 ;;;
@@ -50,14 +65,33 @@
 ;;;
 
 (define (null-pointer? pointer)
+  "Return true if POINTER is the null pointer."
   (= (pointer-address pointer) 0))
 
+(if (defined? 'procedure->pointer)
+    (export procedure->pointer))
 
 \f
 ;;;
 ;;; Structures.
 ;;;
 
+(define bytevector-pointer-ref
+  (case (sizeof '*)
+    ((8) (lambda (bv offset)
+           (make-pointer (bytevector-u64-native-ref bv offset))))
+    ((4) (lambda (bv offset)
+           (make-pointer (bytevector-u32-native-ref bv offset))))
+    (else (error "what machine is this?"))))
+
+(define bytevector-pointer-set!
+  (case (sizeof '*)
+    ((8) (lambda (bv offset ptr)
+           (bytevector-u64-native-set! bv offset (pointer-address ptr))))
+    ((4) (lambda (bv offset ptr)
+           (bytevector-u32-native-set! bv offset (pointer-address ptr))))
+    (else (error "what machine is this?"))))
+
 (define *writers*
   `((,float . ,bytevector-ieee-single-native-set!)
     (,double . ,bytevector-ieee-double-native-set!)
@@ -68,7 +102,8 @@
     (,int32 . ,bytevector-s32-native-set!)
     (,uint32 . ,bytevector-u32-native-set!)
     (,int64 . ,bytevector-s64-native-set!)
-    (,uint64 . ,bytevector-u64-native-set!)))
+    (,uint64 . ,bytevector-u64-native-set!)
+    (* . ,bytevector-pointer-set!)))
 
 (define *readers*
   `((,float . ,bytevector-ieee-single-native-ref)
@@ -80,7 +115,9 @@
     (,int32 . ,bytevector-s32-native-ref)
     (,uint32 . ,bytevector-u32-native-ref)
     (,int64 . ,bytevector-s64-native-ref)
-    (,uint64 . ,bytevector-u64-native-ref)))
+    (,uint64 . ,bytevector-u64-native-ref)
+    (* . ,bytevector-pointer-ref)))
+
 
 (define (align off alignment)
   (1+ (logior (1- off) (1- alignment))))
@@ -123,4 +160,40 @@
     (bytevector->pointer bv)))
 
 (define (parse-c-struct foreign types)
-  (read-c-struct (pointer->bytevector foreign) 0 types))
+  (let ((size (fold (lambda (type total)
+                      (+ (sizeof type)
+                         (align total (alignof type))))
+                    0
+                    types)))
+    (read-c-struct (pointer->bytevector foreign size) 0 types)))
+
+\f
+;;;
+;;; 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 ()
+      ((_ type-name pred wrap unwrap print)
+       (with-syntax ((%wrap (datum->syntax #'wrap (gensym "wrap"))))
+         #'(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)
+                   (or (hash-ref ptr->obj ptr)
+                       (let ((o (%wrap ptr)))
+                         (hash-set! ptr->obj ptr o)
+                         o)))))
+             (set-record-type-printer! type-name print)))))))