1 ;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
3 ;;;; This library is free software; you can redistribute it and/or
4 ;;;; modify it under the terms of the GNU Lesser General Public
5 ;;;; License as published by the Free Software Foundation; either
6 ;;;; version 2.1 of the License, or (at your option) any later version.
8 ;;;; This library is distributed in the hope that it will be useful,
9 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
10 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 ;;;; Lesser General Public License for more details.
13 ;;;; You should have received a copy of the GNU Lesser General Public
14 ;;;; License along with this library; if not, write to the Free Software
15 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
19 (define-module (system foreign)
20 #:use-module (rnrs bytevectors)
21 #:use-module (srfi srfi-1)
22 #:use-module (srfi srfi-9)
23 #:use-module (srfi srfi-9 gnu)
28 int unsigned-int long unsigned-long size_t
44 set-pointer-finalizer!
51 ;; procedure->pointer (see below)
52 make-c-struct parse-c-struct
54 define-wrapped-pointer-type))
56 (eval-when (load eval compile)
57 (load-extension (string-append "libguile-" (effective-version))
65 (define (null-pointer? pointer)
66 "Return true if POINTER is the null pointer."
67 (= (pointer-address pointer) 0))
69 (if (defined? 'procedure->pointer)
70 (export procedure->pointer))
77 (define bytevector-pointer-ref
79 ((8) (lambda (bv offset)
80 (make-pointer (bytevector-u64-native-ref bv offset))))
81 ((4) (lambda (bv offset)
82 (make-pointer (bytevector-u32-native-ref bv offset))))
83 (else (error "what machine is this?"))))
85 (define bytevector-pointer-set!
87 ((8) (lambda (bv offset ptr)
88 (bytevector-u64-native-set! bv offset (pointer-address ptr))))
89 ((4) (lambda (bv offset ptr)
90 (bytevector-u32-native-set! bv offset (pointer-address ptr))))
91 (else (error "what machine is this?"))))
94 `((,float . ,bytevector-ieee-single-native-set!)
95 (,double . ,bytevector-ieee-double-native-set!)
96 (,int8 . ,bytevector-s8-set!)
97 (,uint8 . ,bytevector-u8-set!)
98 (,int16 . ,bytevector-s16-native-set!)
99 (,uint16 . ,bytevector-u16-native-set!)
100 (,int32 . ,bytevector-s32-native-set!)
101 (,uint32 . ,bytevector-u32-native-set!)
102 (,int64 . ,bytevector-s64-native-set!)
103 (,uint64 . ,bytevector-u64-native-set!)
104 (* . ,bytevector-pointer-set!)))
107 `((,float . ,bytevector-ieee-single-native-ref)
108 (,double . ,bytevector-ieee-double-native-ref)
109 (,int8 . ,bytevector-s8-ref)
110 (,uint8 . ,bytevector-u8-ref)
111 (,int16 . ,bytevector-s16-native-ref)
112 (,uint16 . ,bytevector-u16-native-ref)
113 (,int32 . ,bytevector-s32-native-ref)
114 (,uint32 . ,bytevector-u32-native-ref)
115 (,int64 . ,bytevector-s64-native-ref)
116 (,uint64 . ,bytevector-u64-native-ref)
117 (* . ,bytevector-pointer-ref)))
120 (define (align off alignment)
121 (1+ (logior (1- off) (1- alignment))))
123 (define (write-c-struct bv offset types vals)
124 (let lp ((offset offset) (types types) (vals vals))
128 (error "too many values" vals)))
130 (error "too few values" types))
132 ;; alignof will error-check
133 (let* ((type (car types))
134 (offset (align offset (alignof type))))
136 (write-c-struct bv offset (car types) (car vals))
137 ((assv-ref *writers* type) bv offset (car vals)))
138 (lp (+ offset (sizeof type)) (cdr types) (cdr vals)))))))
140 (define (read-c-struct bv offset types)
141 (let lp ((offset offset) (types types) (vals '()))
146 ;; alignof will error-check
147 (let* ((type (car types))
148 (offset (align offset (alignof type))))
149 (lp (+ offset (sizeof type)) (cdr types)
150 (cons (if (pair? type)
151 (read-c-struct bv offset (car types))
152 ((assv-ref *readers* type) bv offset))
155 (define (make-c-struct types vals)
156 (let ((bv (make-bytevector (sizeof types) 0)))
157 (write-c-struct bv 0 types vals)
158 (bytevector->pointer bv)))
160 (define (parse-c-struct foreign types)
161 (let ((size (fold (lambda (type total)
163 (align total (alignof type))))
166 (read-c-struct (pointer->bytevector foreign size) 0 types)))
170 ;;; Wrapped pointer types.
173 (define-syntax define-wrapped-pointer-type
175 "Define helper procedures to wrap pointer objects into Scheme
176 objects with a disjoint type. Specifically, this macro defines PRED, a
177 predicate for the new Scheme type, WRAP, a procedure that takes a
178 pointer object and returns an object that satisfies PRED, and UNWRAP
179 which does the reverse. PRINT must name a user-defined object printer."
181 ((_ type-name pred wrap unwrap print)
182 (with-syntax ((%wrap (datum->syntax #'wrap (gensym "wrap"))))
184 (define-record-type type-name
189 ;; Use a weak hash table to preserve pointer identity, i.e.,
190 ;; PTR1 == PTR2 <-> (eq? (wrap PTR1) (wrap PTR2)).
191 (let ((ptr->obj (make-weak-value-hash-table 3000)))
193 (let ((key+value (hash-create-handle! ptr->obj ptr #f)))
195 (let ((o (%wrap ptr)))
196 (set-cdr! key+value o)
198 (set-record-type-printer! type-name print)))))))