Merge commit 'a7bbba05838cabe2294f498e7008e1c51db6d664'
[bpt/guile.git] / test-suite / tests / foreign.test
1 ;;;; foreign.test --- FFI. -*- mode: scheme; coding: utf-8; -*-
2 ;;;;
3 ;;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
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)
25 #:use-module (rnrs bytevectors)
26 #:use-module (srfi srfi-1)
27 #:use-module (srfi srfi-26)
28 #:use-module (ice-9 format)
29 #:use-module (test-suite lib))
30
31 \f
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
40 (with-test-prefix "null pointer"
41
42 (pass-if "pointer?"
43 (pointer? %null-pointer))
44
45 (pass-if "zero"
46 (= 0 (pointer-address %null-pointer)))
47
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))
53
54 (pass-if-exception "dereference-pointer %null-pointer"
55 exception:null-pointer-error
56 (dereference-pointer %null-pointer))
57
58 (pass-if-exception "pointer->bytevector %null-pointer"
59 exception:null-pointer-error
60 (pointer->bytevector %null-pointer 7)))
61
62 \f
63 (with-test-prefix "make-pointer"
64
65 (pass-if "pointer?"
66 (pointer? (make-pointer 123)))
67
68 (pass-if "address preserved"
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"
75 (let ((finalizer (false-if-exception
76 (dynamic-func "scm_is_pair" (dynamic-link)))))
77 (if (not finalizer)
78 (throw 'unresolved) ; Windows or a static build
79 (equal? (make-pointer 123)
80 (make-pointer 123 finalizer)))))
81
82 (pass-if "equal? modulo finalizer (set-pointer-finalizer!)"
83 (let ((finalizer (false-if-exception
84 (dynamic-func "scm_is_pair" (dynamic-link))))
85 (ptr (make-pointer 123)))
86 (if (not finalizer)
87 (throw 'unresolved) ; Windows or a static build
88 (begin
89 (set-pointer-finalizer! ptr finalizer)
90 (equal? (make-pointer 123) ptr)))))
91
92 (pass-if "not equal?"
93 (not (equal? (make-pointer 123) (make-pointer 456)))))
94
95 \f
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
107 (define-wrapped-pointer-type foo
108 foo?
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
135 (with-test-prefix "pointer<->bytevector"
136
137 (pass-if "bijection"
138 (let ((bv #vu8(0 1 2 3 4 5 6 7)))
139 (equal? (pointer->bytevector (bytevector->pointer bv)
140 (bytevector-length bv))
141 bv)))
142
143 (pass-if "pointer from bits"
144 (let* ((bytes (iota (sizeof '*)))
145 (bv (u8-list->bytevector bytes))
146 (fold (case (native-endianness)
147 ((little) fold-right)
148 ((big) fold)
149 (else (error "unsupported endianness")))))
150 (= (pointer-address
151 (make-pointer (bytevector-uint-ref bv 0 (native-endianness)
152 (sizeof '*))))
153 (fold (lambda (byte address)
154 (+ byte (* 256 address)))
155 0
156 bytes))))
157
158 (pass-if "dereference-pointer"
159 (let* ((bytes (iota (sizeof '*)))
160 (bv (u8-list->bytevector bytes))
161 (fold (case (native-endianness)
162 ((little) fold-right)
163 ((big) fold)
164 (else (error "unsupported endianness")))))
165 (= (pointer-address
166 (dereference-pointer (bytevector->pointer bv)))
167 (fold (lambda (byte address)
168 (+ byte (* 256 address)))
169 0
170 bytes)))))
171
172 \f
173 (with-test-prefix "pointer<->string"
174
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
181 (pass-if "%default-port-conversion-strategy is escape"
182 (let ((s "teĥniko"))
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"))))
197
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!"))
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
217
218 \f
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
227 (with-test-prefix "procedure->pointer"
228
229 (define qsort
230 ;; Bindings for libc's `qsort' function.
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 '*))))
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"
247 (if (and qsort (defined? 'procedure->pointer))
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
265 (if (and qsort (defined? 'procedure->pointer))
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
277 (if (and qsort (defined? 'procedure->pointer))
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)
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))
292 (proc* (pointer->procedure ret
293 (procedure->pointer ret proc args)
294 args))
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)))
300 (throw 'unresolved)))
301
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
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?)
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)))
336 (throw 'unresolved)))
337
338 (pass-if "arity"
339 (if (and qsort (defined? 'procedure->pointer))
340 (equal? '(4 0 #f) (procedure-minimum-arity qsort))
341 (throw 'unresolved))))
342
343 \f
344 (with-test-prefix "structs"
345
346 (pass-if "sizeof { int8, double }"
347 (= (sizeof (list int8 double))
348 (+ (alignof double) (sizeof double))))
349
350 (pass-if "sizeof { double, int8 }"
351 (= (sizeof (list double int8))
352 (+ (alignof double) (sizeof double))))
353
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
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
364 (pass-if "parse-c-struct"
365 (let ((layout (list int64 uint8))
366 (data (list -300 43)))
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)))
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))))
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)))
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)))
409 (equal? (parse-c-struct (make-c-struct layout data)
410 layout)
411 data))))