Commit | Line | Data |
---|---|---|
3a3bea72 | 1 | ;;;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc. |
ab4779ff AW |
2 | ;;;; |
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. | |
7 | ;;;; | |
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. | |
12 | ;;;; | |
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 | |
16 | ;;;; | |
17 | \f | |
18 | ||
19 | (define-module (system foreign) | |
07d22c02 | 20 | #:use-module (rnrs bytevectors) |
7387c231 | 21 | #:use-module (srfi srfi-1) |
1f4f7674 LC |
22 | #:use-module (srfi srfi-9) |
23 | #:use-module (srfi srfi-9 gnu) | |
ab4779ff AW |
24 | #:export (void |
25 | float double | |
42f7c01e LC |
26 | short |
27 | unsigned-short | |
3a3bea72 | 28 | int unsigned-int long unsigned-long size_t ssize_t ptrdiff_t |
ab4779ff AW |
29 | int8 uint8 |
30 | uint16 int16 | |
31 | uint32 int32 | |
32 | uint64 int64 | |
33 | ||
70ea39f7 AW |
34 | sizeof alignof |
35 | ||
d4149a51 LC |
36 | %null-pointer |
37 | null-pointer? | |
6e097560 | 38 | pointer? |
d4149a51 | 39 | make-pointer |
148c3317 AW |
40 | pointer->scm |
41 | scm->pointer | |
5b46a8c2 | 42 | pointer-address |
d4149a51 | 43 | |
5b46a8c2 LC |
44 | pointer->bytevector |
45 | bytevector->pointer | |
46 | set-pointer-finalizer! | |
47 | ||
fa2a89a6 LC |
48 | dereference-pointer |
49 | string->pointer | |
50 | pointer->string | |
51 | ||
2ee07358 | 52 | pointer->procedure |
33186356 | 53 | ;; procedure->pointer (see below) |
1f4f7674 LC |
54 | make-c-struct parse-c-struct |
55 | ||
56 | define-wrapped-pointer-type)) | |
ab4779ff | 57 | |
fb636a1c LC |
58 | (eval-when (load eval compile) |
59 | (load-extension (string-append "libguile-" (effective-version)) | |
60 | "scm_init_foreign")) | |
70ea39f7 | 61 | |
d4149a51 LC |
62 | \f |
63 | ;;; | |
64 | ;;; Pointers. | |
65 | ;;; | |
66 | ||
67 | (define (null-pointer? pointer) | |
183a2a22 | 68 | "Return true if POINTER is the null pointer." |
5b46a8c2 | 69 | (= (pointer-address pointer) 0)) |
d4149a51 | 70 | |
33186356 LC |
71 | (if (defined? 'procedure->pointer) |
72 | (export procedure->pointer)) | |
d4149a51 LC |
73 | |
74 | \f | |
75 | ;;; | |
76 | ;;; Structures. | |
77 | ;;; | |
78 | ||
a6b1b27a AW |
79 | (define bytevector-pointer-ref |
80 | (case (sizeof '*) | |
81 | ((8) (lambda (bv offset) | |
82 | (make-pointer (bytevector-u64-native-ref bv offset)))) | |
83 | ((4) (lambda (bv offset) | |
84 | (make-pointer (bytevector-u32-native-ref bv offset)))) | |
85 | (else (error "what machine is this?")))) | |
86 | ||
87 | (define bytevector-pointer-set! | |
88 | (case (sizeof '*) | |
89 | ((8) (lambda (bv offset ptr) | |
90 | (bytevector-u64-native-set! bv offset (pointer-address ptr)))) | |
91 | ((4) (lambda (bv offset ptr) | |
92 | (bytevector-u32-native-set! bv offset (pointer-address ptr)))) | |
93 | (else (error "what machine is this?")))) | |
fb636a1c | 94 | |
70ea39f7 AW |
95 | (define *writers* |
96 | `((,float . ,bytevector-ieee-single-native-set!) | |
97 | (,double . ,bytevector-ieee-double-native-set!) | |
98 | (,int8 . ,bytevector-s8-set!) | |
99 | (,uint8 . ,bytevector-u8-set!) | |
100 | (,int16 . ,bytevector-s16-native-set!) | |
101 | (,uint16 . ,bytevector-u16-native-set!) | |
102 | (,int32 . ,bytevector-s32-native-set!) | |
103 | (,uint32 . ,bytevector-u32-native-set!) | |
104 | (,int64 . ,bytevector-s64-native-set!) | |
fb636a1c | 105 | (,uint64 . ,bytevector-u64-native-set!) |
a6b1b27a | 106 | (* . ,bytevector-pointer-set!))) |
70ea39f7 AW |
107 | |
108 | (define *readers* | |
109 | `((,float . ,bytevector-ieee-single-native-ref) | |
110 | (,double . ,bytevector-ieee-double-native-ref) | |
111 | (,int8 . ,bytevector-s8-ref) | |
112 | (,uint8 . ,bytevector-u8-ref) | |
113 | (,int16 . ,bytevector-s16-native-ref) | |
114 | (,uint16 . ,bytevector-u16-native-ref) | |
115 | (,int32 . ,bytevector-s32-native-ref) | |
116 | (,uint32 . ,bytevector-u32-native-ref) | |
117 | (,int64 . ,bytevector-s64-native-ref) | |
fb636a1c | 118 | (,uint64 . ,bytevector-u64-native-ref) |
a6b1b27a | 119 | (* . ,bytevector-pointer-ref))) |
fb636a1c | 120 | |
70ea39f7 AW |
121 | |
122 | (define (align off alignment) | |
123 | (1+ (logior (1- off) (1- alignment)))) | |
124 | ||
125 | (define (write-c-struct bv offset types vals) | |
126 | (let lp ((offset offset) (types types) (vals vals)) | |
127 | (cond | |
128 | ((not (pair? types)) | |
129 | (or (null? vals) | |
130 | (error "too many values" vals))) | |
131 | ((not (pair? vals)) | |
132 | (error "too few values" types)) | |
133 | (else | |
134 | ;; alignof will error-check | |
135 | (let* ((type (car types)) | |
136 | (offset (align offset (alignof type)))) | |
137 | (if (pair? type) | |
138 | (write-c-struct bv offset (car types) (car vals)) | |
139 | ((assv-ref *writers* type) bv offset (car vals))) | |
140 | (lp (+ offset (sizeof type)) (cdr types) (cdr vals))))))) | |
141 | ||
142 | (define (read-c-struct bv offset types) | |
143 | (let lp ((offset offset) (types types) (vals '())) | |
144 | (cond | |
145 | ((not (pair? types)) | |
146 | (reverse vals)) | |
147 | (else | |
148 | ;; alignof will error-check | |
149 | (let* ((type (car types)) | |
150 | (offset (align offset (alignof type)))) | |
151 | (lp (+ offset (sizeof type)) (cdr types) | |
152 | (cons (if (pair? type) | |
153 | (read-c-struct bv offset (car types)) | |
154 | ((assv-ref *readers* type) bv offset)) | |
155 | vals))))))) | |
156 | ||
157 | (define (make-c-struct types vals) | |
158 | (let ((bv (make-bytevector (sizeof types) 0))) | |
159 | (write-c-struct bv 0 types vals) | |
5b46a8c2 | 160 | (bytevector->pointer bv))) |
70ea39f7 AW |
161 | |
162 | (define (parse-c-struct foreign types) | |
7387c231 | 163 | (let ((size (fold (lambda (type total) |
1f864a16 LC |
164 | (+ (sizeof type) |
165 | (align total (alignof type)))) | |
7387c231 LC |
166 | 0 |
167 | types))) | |
168 | (read-c-struct (pointer->bytevector foreign size) 0 types))) | |
1f4f7674 LC |
169 | |
170 | \f | |
171 | ;;; | |
172 | ;;; Wrapped pointer types. | |
173 | ;;; | |
174 | ||
175 | (define-syntax define-wrapped-pointer-type | |
176 | (lambda (stx) | |
177 | "Define helper procedures to wrap pointer objects into Scheme | |
178 | objects with a disjoint type. Specifically, this macro defines PRED, a | |
179 | predicate for the new Scheme type, WRAP, a procedure that takes a | |
180 | pointer object and returns an object that satisfies PRED, and UNWRAP | |
181 | which does the reverse. PRINT must name a user-defined object printer." | |
182 | (syntax-case stx () | |
de6fb187 LC |
183 | ((_ type-name pred wrap unwrap print) |
184 | (with-syntax ((%wrap (datum->syntax #'wrap (gensym "wrap")))) | |
1f4f7674 LC |
185 | #'(begin |
186 | (define-record-type type-name | |
187 | (%wrap pointer) | |
188 | pred | |
189 | (pointer unwrap)) | |
190 | (define wrap | |
191 | ;; Use a weak hash table to preserve pointer identity, i.e., | |
192 | ;; PTR1 == PTR2 <-> (eq? (wrap PTR1) (wrap PTR2)). | |
193 | (let ((ptr->obj (make-weak-value-hash-table 3000))) | |
194 | (lambda (ptr) | |
ca33b501 LC |
195 | (or (hash-ref ptr->obj ptr) |
196 | (let ((o (%wrap ptr))) | |
197 | (hash-set! ptr->obj ptr o) | |
198 | o))))) | |
1f4f7674 | 199 | (set-record-type-printer! type-name print))))))) |