Commit | Line | Data |
---|---|---|
01ad5a7b LC |
1 | ;;;; foreign.test --- FFI. -*- mode: scheme; coding: utf-8; -*- |
2 | ;;;; | |
8364ae3f | 3 | ;;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc. |
01ad5a7b LC |
4 | ;;;; |
5 | ;;;; This library is free software; you can redistribute it and/or | |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 3 of the License, or (at your option) any later version. | |
9 | ;;;; | |
10 | ;;;; This library is distributed in the hope that it will be useful, | |
11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;;; License along with this library; if not, write to the Free Software | |
17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
18 | ||
19 | ;;; | |
20 | ;;; See also ../standalone/test-ffi for FFI tests. | |
21 | ;;; | |
22 | ||
23 | (define-module (test-foreign) | |
24 | #:use-module (system foreign) | |
07d22c02 | 25 | #:use-module (rnrs bytevectors) |
d4149a51 | 26 | #:use-module (srfi srfi-1) |
fb0b64c1 | 27 | #:use-module (srfi srfi-26) |
b22e94db | 28 | #:use-module (ice-9 format) |
01ad5a7b LC |
29 | #:use-module (test-suite lib)) |
30 | ||
31 | \f | |
0f1fd214 MG |
32 | (with-test-prefix "dynamic-pointer" |
33 | ||
34 | (pass-if-exception | |
35 | "error message" | |
36 | '(misc-error . "^Symbol not found") | |
37 | (dynamic-func "does_not_exist___" (dynamic-link)))) | |
38 | ||
39 | \f | |
01ad5a7b LC |
40 | (with-test-prefix "null pointer" |
41 | ||
6e097560 LC |
42 | (pass-if "pointer?" |
43 | (pointer? %null-pointer)) | |
44 | ||
01ad5a7b | 45 | (pass-if "zero" |
5b46a8c2 | 46 | (= 0 (pointer-address %null-pointer))) |
01ad5a7b | 47 | |
d4149a51 LC |
48 | (pass-if "null pointer identity" |
49 | (eq? %null-pointer (make-pointer 0))) | |
50 | ||
51 | (pass-if "null-pointer? %null-pointer" | |
52 | (null-pointer? %null-pointer)) | |
01ad5a7b | 53 | |
b7c1b60c MW |
54 | (pass-if-exception "dereference-pointer %null-pointer" |
55 | exception:null-pointer-error | |
56 | (dereference-pointer %null-pointer)) | |
57 | ||
5b46a8c2 | 58 | (pass-if-exception "pointer->bytevector %null-pointer" |
01ad5a7b | 59 | exception:null-pointer-error |
5b46a8c2 | 60 | (pointer->bytevector %null-pointer 7))) |
01ad5a7b | 61 | |
d4149a51 LC |
62 | \f |
63 | (with-test-prefix "make-pointer" | |
64 | ||
6e097560 LC |
65 | (pass-if "pointer?" |
66 | (pointer? (make-pointer 123))) | |
67 | ||
d4149a51 | 68 | (pass-if "address preserved" |
cb2d8076 LC |
69 | (= 123 (pointer-address (make-pointer 123)))) |
70 | ||
71 | (pass-if "equal?" | |
72 | (equal? (make-pointer 123) (make-pointer 123))) | |
73 | ||
74 | (pass-if "equal? modulo finalizer" | |
9a5b6f6e LC |
75 | (let ((finalizer (false-if-exception |
76 | (dynamic-func "scm_is_pair" (dynamic-link))))) | |
8364ae3f | 77 | (if (not finalizer) |
9a5b6f6e | 78 | (throw 'unresolved) ; Windows or a static build |
8364ae3f LC |
79 | (equal? (make-pointer 123) |
80 | (make-pointer 123 finalizer))))) | |
cb2d8076 | 81 | |
5765c5a8 | 82 | (pass-if "equal? modulo finalizer (set-pointer-finalizer!)" |
9a5b6f6e LC |
83 | (let ((finalizer (false-if-exception |
84 | (dynamic-func "scm_is_pair" (dynamic-link)))) | |
5765c5a8 | 85 | (ptr (make-pointer 123))) |
8364ae3f | 86 | (if (not finalizer) |
9a5b6f6e | 87 | (throw 'unresolved) ; Windows or a static build |
8364ae3f LC |
88 | (begin |
89 | (set-pointer-finalizer! ptr finalizer) | |
90 | (equal? (make-pointer 123) ptr))))) | |
5765c5a8 | 91 | |
cb2d8076 LC |
92 | (pass-if "not equal?" |
93 | (not (equal? (make-pointer 123) (make-pointer 456))))) | |
d4149a51 LC |
94 | |
95 | \f | |
148c3317 AW |
96 | (with-test-prefix "pointer<->scm" |
97 | ||
98 | (pass-if "immediates" | |
99 | (equal? (pointer->scm (scm->pointer #\newline)) | |
100 | #\newline)) | |
101 | ||
102 | (pass-if "non-immediates" | |
103 | (equal? (pointer->scm (scm->pointer "Hello, world!")) | |
104 | "Hello, world!"))) | |
105 | ||
106 | \f | |
de6fb187 LC |
107 | (define-wrapped-pointer-type foo |
108 | foo? | |
1f4f7674 LC |
109 | wrap-foo unwrap-foo |
110 | (lambda (x p) | |
111 | (format p "#<foo! ~a>" (pointer-address (unwrap-foo x))))) | |
112 | ||
113 | (with-test-prefix "define-wrapped-pointer-type" | |
114 | ||
115 | (pass-if "foo?" | |
116 | (foo? (wrap-foo %null-pointer))) | |
117 | ||
118 | (pass-if "unwrap-foo" | |
119 | (let ((p (make-pointer 123))) | |
120 | (eq? p (unwrap-foo (wrap-foo p))))) | |
121 | ||
122 | (pass-if "identity" | |
123 | (let ((p1 (make-pointer 123)) | |
124 | (p2 (make-pointer 123))) | |
125 | (eq? (wrap-foo p1) | |
126 | (wrap-foo p2)))) | |
127 | ||
128 | (pass-if "printer" | |
129 | (string=? "#<foo! 123>" | |
130 | (with-output-to-string | |
131 | (lambda () | |
132 | (write (wrap-foo (make-pointer 123)))))))) | |
133 | ||
134 | \f | |
5b46a8c2 | 135 | (with-test-prefix "pointer<->bytevector" |
d4149a51 LC |
136 | |
137 | (pass-if "bijection" | |
138 | (let ((bv #vu8(0 1 2 3 4 5 6 7))) | |
5b46a8c2 | 139 | (equal? (pointer->bytevector (bytevector->pointer bv) |
d4149a51 LC |
140 | (bytevector-length bv)) |
141 | bv))) | |
142 | ||
143 | (pass-if "pointer from bits" | |
144 | (let* ((bytes (iota (sizeof '*))) | |
1f78c669 LC |
145 | (bv (u8-list->bytevector bytes)) |
146 | (fold (case (native-endianness) | |
147 | ((little) fold-right) | |
148 | ((big) fold) | |
149 | (else (error "unsupported endianness"))))) | |
5b46a8c2 | 150 | (= (pointer-address |
d4149a51 LC |
151 | (make-pointer (bytevector-uint-ref bv 0 (native-endianness) |
152 | (sizeof '*)))) | |
1f78c669 LC |
153 | (fold (lambda (byte address) |
154 | (+ byte (* 256 address))) | |
155 | 0 | |
156 | bytes)))) | |
17fc9efe LC |
157 | |
158 | (pass-if "dereference-pointer" | |
159 | (let* ((bytes (iota (sizeof '*))) | |
1f78c669 LC |
160 | (bv (u8-list->bytevector bytes)) |
161 | (fold (case (native-endianness) | |
162 | ((little) fold-right) | |
163 | ((big) fold) | |
164 | (else (error "unsupported endianness"))))) | |
5b46a8c2 LC |
165 | (= (pointer-address |
166 | (dereference-pointer (bytevector->pointer bv))) | |
1f78c669 LC |
167 | (fold (lambda (byte address) |
168 | (+ byte (* 256 address))) | |
169 | 0 | |
170 | bytes))))) | |
7387c231 LC |
171 | |
172 | \f | |
fa2a89a6 LC |
173 | (with-test-prefix "pointer<->string" |
174 | ||
b22e94db LC |
175 | (pass-if-exception "%default-port-conversion-strategy is error" |
176 | exception:encoding-error | |
177 | (let ((s "χαοσ")) | |
178 | (with-fluids ((%default-port-conversion-strategy 'error)) | |
179 | (string->pointer s "ISO-8859-1")))) | |
180 | ||
27ea5c3f | 181 | (pass-if "%default-port-conversion-strategy is escape" |
b22e94db | 182 | (let ((s "teĥniko")) |
27ea5c3f LC |
183 | (equal? (with-fluids ((%default-port-conversion-strategy 'escape)) |
184 | (pointer->string (string->pointer s "ISO-8859-1"))) | |
185 | (format #f "te\\u~4,'0xniko" | |
186 | (char->integer #\ĥ))))) | |
187 | ||
188 | (pass-if "%default-port-conversion-strategy is substitute" | |
189 | (let ((s "teĥniko") | |
190 | (member (negate (negate member)))) | |
191 | (member (with-fluids ((%default-port-conversion-strategy 'substitute)) | |
192 | (pointer->string (string->pointer s "ISO-8859-1"))) | |
193 | '("te?niko" | |
194 | ||
195 | ;; This form is found on FreeBSD 8.2 and Darwin 10.8.0. | |
196 | "te^hniko")))) | |
b22e94db | 197 | |
fa2a89a6 LC |
198 | (pass-if "bijection" |
199 | (let ((s "hello, world")) | |
200 | (string=? s (pointer->string (string->pointer s))))) | |
201 | ||
202 | (pass-if "bijection [latin1]" | |
203 | (with-latin1-locale | |
204 | (let ((s "Szép jó napot!")) | |
c6b08d21 AW |
205 | (string=? s (pointer->string (string->pointer s)))))) |
206 | ||
207 | (pass-if "bijection, utf-8" | |
208 | (let ((s "hello, world")) | |
209 | (string=? s (pointer->string (string->pointer s "utf-8") | |
210 | -1 "utf-8")))) | |
211 | ||
212 | (pass-if "bijection, utf-8 [latin1]" | |
213 | (let ((s "Szép jó napot!")) | |
214 | (string=? s (pointer->string (string->pointer s "utf-8") | |
215 | -1 "utf-8"))))) | |
216 | ||
fa2a89a6 LC |
217 | |
218 | \f | |
9970cf67 LC |
219 | (with-test-prefix "pointer->procedure" |
220 | ||
221 | (pass-if-exception "object instead of pointer" | |
222 | exception:wrong-type-arg | |
223 | (let ((p (pointer->procedure '* %null-pointer '(*)))) | |
224 | (p #t)))) | |
225 | ||
226 | \f | |
33186356 LC |
227 | (with-test-prefix "procedure->pointer" |
228 | ||
229 | (define qsort | |
230 | ;; Bindings for libc's `qsort' function. | |
09fb52b6 LC |
231 | ;; On some platforms, such as MinGW, `qsort' is visible only if |
232 | ;; linking with `-export-dynamic'. Just skip these tests when it's | |
233 | ;; not visible. | |
234 | (false-if-exception | |
235 | (pointer->procedure void | |
236 | (dynamic-func "qsort" (dynamic-link)) | |
237 | (list '* size_t size_t '*)))) | |
33186356 LC |
238 | |
239 | (define (dereference-pointer-to-byte ptr) | |
240 | (let ((b (pointer->bytevector ptr 1))) | |
241 | (bytevector-u8-ref b 0))) | |
242 | ||
243 | (define input | |
244 | '(7 1 127 3 5 4 77 2 9 0)) | |
245 | ||
246 | (pass-if "qsort" | |
09fb52b6 | 247 | (if (and qsort (defined? 'procedure->pointer)) |
33186356 LC |
248 | (let* ((called? #f) |
249 | (cmp (lambda (x y) | |
250 | (set! called? #t) | |
251 | (- (dereference-pointer-to-byte x) | |
252 | (dereference-pointer-to-byte y)))) | |
253 | (ptr (procedure->pointer int cmp (list '* '*))) | |
254 | (bv (u8-list->bytevector input))) | |
255 | (qsort (bytevector->pointer bv) (bytevector-length bv) 1 | |
256 | (procedure->pointer int cmp (list '* '*))) | |
257 | (and called? | |
258 | (equal? (bytevector->u8-list bv) | |
259 | (sort input <)))) | |
260 | (throw 'unresolved))) | |
261 | ||
262 | (pass-if-exception "qsort, wrong return type" | |
263 | exception:wrong-type-arg | |
264 | ||
09fb52b6 | 265 | (if (and qsort (defined? 'procedure->pointer)) |
33186356 LC |
266 | (let* ((cmp (lambda (x y) #f)) ; wrong return type |
267 | (ptr (procedure->pointer int cmp (list '* '*))) | |
268 | (bv (u8-list->bytevector input))) | |
269 | (qsort (bytevector->pointer bv) (bytevector-length bv) 1 | |
270 | (procedure->pointer int cmp (list '* '*))) | |
271 | #f) | |
272 | (throw 'unresolved))) | |
273 | ||
274 | (pass-if-exception "qsort, wrong arity" | |
275 | exception:wrong-num-args | |
276 | ||
09fb52b6 | 277 | (if (and qsort (defined? 'procedure->pointer)) |
33186356 LC |
278 | (let* ((cmp (lambda (x y z) #f)) ; wrong arity |
279 | (ptr (procedure->pointer int cmp (list '* '*))) | |
280 | (bv (u8-list->bytevector input))) | |
281 | (qsort (bytevector->pointer bv) (bytevector-length bv) 1 | |
282 | (procedure->pointer int cmp (list '* '*))) | |
283 | #f) | |
fb0b64c1 LC |
284 | (throw 'unresolved))) |
285 | ||
286 | (pass-if "bijection" | |
287 | (if (defined? 'procedure->pointer) | |
288 | (let* ((proc (lambda (x y z) | |
289 | (+ x y z 0.0))) | |
290 | (ret double) | |
291 | (args (list float int16 double)) | |
2ee07358 LC |
292 | (proc* (pointer->procedure ret |
293 | (procedure->pointer ret proc args) | |
294 | args)) | |
fb0b64c1 LC |
295 | (arg1 (map (cut / <> 2.0) (iota 123))) |
296 | (arg2 (iota 123 32000)) | |
297 | (arg3 (map (cut / <> 4.0) (iota 123 100 4)))) | |
298 | (equal? (map proc arg1 arg2 arg3) | |
299 | (map proc* arg1 arg2 arg3))) | |
443f25dc LC |
300 | (throw 'unresolved))) |
301 | ||
449c4d44 LC |
302 | (pass-if "procedures returning a pointer" |
303 | (if (defined? 'procedure->pointer) | |
304 | (let* ((called? #f) | |
305 | (proc (lambda (i) (set! called? #t) (make-pointer i))) | |
306 | (pointer (procedure->pointer '* proc (list int))) | |
307 | (proc* (pointer->procedure '* pointer (list int))) | |
308 | (result (proc* 777))) | |
309 | (and called? (equal? result (make-pointer 777)))) | |
310 | (throw 'unresolved))) | |
311 | ||
443f25dc LC |
312 | (pass-if "procedures returning void" |
313 | (if (defined? 'procedure->pointer) | |
314 | (let* ((called? #f) | |
315 | (proc (lambda () (set! called? #t))) | |
316 | (pointer (procedure->pointer void proc '())) | |
317 | (proc* (pointer->procedure void pointer '()))) | |
318 | (proc*) | |
319 | called?) | |
59a02733 LC |
320 | (throw 'unresolved))) |
321 | ||
322 | (pass-if "procedure is retained" | |
323 | ;; The lambda passed to `procedure->pointer' must remain live. | |
324 | (if (defined? 'procedure->pointer) | |
325 | (let* ((ptr (procedure->pointer int | |
326 | (lambda (x) (+ x 7)) | |
327 | (list int))) | |
328 | (procs (unfold (cut >= <> 10000) | |
329 | (lambda (i) | |
330 | (pointer->procedure int ptr (list int))) | |
331 | 1+ | |
332 | 0))) | |
333 | (gc) (gc) (gc) | |
334 | (every (cut = <> 9) | |
335 | (map (lambda (f) (f 2)) procs))) | |
b0ca878c AW |
336 | (throw 'unresolved))) |
337 | ||
338 | (pass-if "arity" | |
339 | (if (and qsort (defined? 'procedure->pointer)) | |
340 | (equal? '(4 0 #f) (procedure-minimum-arity qsort)) | |
33186356 LC |
341 | (throw 'unresolved)))) |
342 | ||
343 | \f | |
7387c231 LC |
344 | (with-test-prefix "structs" |
345 | ||
16f06128 LC |
346 | (pass-if "sizeof { int8, double }" |
347 | (= (sizeof (list int8 double)) | |
348 | (+ (alignof double) (sizeof double)))) | |
349 | ||
cff1d39b KR |
350 | (pass-if "sizeof { double, int8 }" |
351 | (= (sizeof (list double int8)) | |
352 | (+ (alignof double) (sizeof double)))) | |
353 | ||
16f06128 LC |
354 | (pass-if "sizeof { short, int, long, pointer }" |
355 | (let ((layout (list short int long '*))) | |
356 | (>= (sizeof layout) | |
357 | (reduce + 0.0 (map sizeof layout))))) | |
358 | ||
d82f8518 LC |
359 | (pass-if "alignof { int8, double, int8 }" |
360 | ;; alignment of the most strictly aligned component | |
361 | (let ((layout (list int8 double int8))) | |
362 | (= (alignof layout) (alignof double)))) | |
363 | ||
7387c231 LC |
364 | (pass-if "parse-c-struct" |
365 | (let ((layout (list int64 uint8)) | |
366 | (data (list -300 43))) | |
1f864a16 LC |
367 | (equal? (parse-c-struct (make-c-struct layout data) |
368 | layout) | |
369 | data))) | |
370 | ||
371 | (pass-if "alignment constraints honored" | |
372 | (let ((layout (list int8 double)) | |
373 | (data (list -7 3.14))) | |
fb636a1c LC |
374 | (equal? (parse-c-struct (make-c-struct layout data) |
375 | layout) | |
376 | data))) | |
377 | ||
378 | (pass-if "int8, pointer" | |
379 | (let ((layout (list uint8 '*)) | |
380 | (data (list 222 (make-pointer 7777)))) | |
381 | (equal? (parse-c-struct (make-c-struct layout data) | |
382 | layout) | |
383 | data))) | |
384 | ||
385 | (pass-if "unsigned-long, int8, size_t" | |
386 | (let ((layout (list unsigned-long int8 size_t)) | |
387 | (data (list (expt 2 17) -128 (expt 2 18)))) | |
388 | (equal? (parse-c-struct (make-c-struct layout data) | |
389 | layout) | |
390 | data))) | |
391 | ||
392 | (pass-if "long, int, pointer" | |
393 | (let ((layout (list long int '*)) | |
394 | (data (list (- (expt 2 17)) -222 (make-pointer 777)))) | |
42f7c01e LC |
395 | (equal? (parse-c-struct (make-c-struct layout data) |
396 | layout) | |
397 | data))) | |
398 | ||
399 | (pass-if "int8, pointer, short, double" | |
400 | (let ((layout (list int8 '* short double)) | |
401 | (data (list 77 %null-pointer -42 3.14))) | |
d82f8518 LC |
402 | (equal? (parse-c-struct (make-c-struct layout data) |
403 | layout) | |
404 | data))) | |
405 | ||
406 | (pass-if "int8, { int8, double, int8 }, int16" | |
407 | (let ((layout (list int8 (list int8 double int8) int16)) | |
408 | (data (list 77 (list 42 4.2 55) 88))) | |
7387c231 LC |
409 | (equal? (parse-c-struct (make-c-struct layout data) |
410 | layout) | |
411 | data)))) |