1 ;;;; foreign.test --- FFI. -*- mode: scheme; coding: utf-8; -*-
3 ;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
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.
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.
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
20 ;;; See also ../standalone/test-ffi for FFI tests.
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 (test-suite lib))
31 (with-test-prefix "null pointer"
34 (pointer? %null-pointer))
37 (= 0 (pointer-address %null-pointer)))
39 (pass-if "null pointer identity"
40 (eq? %null-pointer (make-pointer 0)))
42 (pass-if "null-pointer? %null-pointer"
43 (null-pointer? %null-pointer))
45 (pass-if-exception "pointer->bytevector %null-pointer"
46 exception:null-pointer-error
47 (pointer->bytevector %null-pointer 7)))
50 (with-test-prefix "make-pointer"
53 (pointer? (make-pointer 123)))
55 (pass-if "address preserved"
56 (= 123 (pointer-address (make-pointer 123))))
59 (equal? (make-pointer 123) (make-pointer 123)))
61 (pass-if "equal? modulo finalizer"
62 (let ((finalizer (dynamic-func "scm_is_pair" (dynamic-link))))
63 (equal? (make-pointer 123)
64 (make-pointer 123 finalizer))))
67 (not (equal? (make-pointer 123) (make-pointer 456)))))
70 (define-wrapped-pointer-type foo
74 (format p "#<foo! ~a>" (pointer-address (unwrap-foo x)))))
76 (with-test-prefix "define-wrapped-pointer-type"
79 (foo? (wrap-foo %null-pointer)))
82 (let ((p (make-pointer 123)))
83 (eq? p (unwrap-foo (wrap-foo p)))))
86 (let ((p1 (make-pointer 123))
87 (p2 (make-pointer 123)))
92 (string=? "#<foo! 123>"
93 (with-output-to-string
95 (write (wrap-foo (make-pointer 123))))))))
98 (with-test-prefix "pointer<->bytevector"
101 (let ((bv #vu8(0 1 2 3 4 5 6 7)))
102 (equal? (pointer->bytevector (bytevector->pointer bv)
103 (bytevector-length bv))
106 (pass-if "pointer from bits"
107 (let* ((bytes (iota (sizeof '*)))
108 (bv (u8-list->bytevector bytes)))
110 (make-pointer (bytevector-uint-ref bv 0 (native-endianness)
112 (fold-right (lambda (byte address)
113 (+ byte (* 256 address)))
117 (pass-if "dereference-pointer"
118 (let* ((bytes (iota (sizeof '*)))
119 (bv (u8-list->bytevector bytes)))
121 (dereference-pointer (bytevector->pointer bv)))
122 (fold-right (lambda (byte address)
123 (+ byte (* 256 address)))
128 (with-test-prefix "pointer<->string"
131 (let ((s "hello, world"))
132 (string=? s (pointer->string (string->pointer s)))))
134 (pass-if "bijection [latin1]"
136 (let ((s "Szép jó napot!"))
137 (string=? s (pointer->string (string->pointer s)))))))
140 (with-test-prefix "pointer->procedure"
142 (pass-if-exception "object instead of pointer"
143 exception:wrong-type-arg
144 (let ((p (pointer->procedure '* %null-pointer '(*))))
148 (with-test-prefix "procedure->pointer"
151 ;; Bindings for libc's `qsort' function.
152 (pointer->procedure void
153 (dynamic-func "qsort" (dynamic-link))
154 (list '* size_t size_t '*)))
156 (define (dereference-pointer-to-byte ptr)
157 (let ((b (pointer->bytevector ptr 1)))
158 (bytevector-u8-ref b 0)))
161 '(7 1 127 3 5 4 77 2 9 0))
164 (if (defined? 'procedure->pointer)
168 (- (dereference-pointer-to-byte x)
169 (dereference-pointer-to-byte y))))
170 (ptr (procedure->pointer int cmp (list '* '*)))
171 (bv (u8-list->bytevector input)))
172 (qsort (bytevector->pointer bv) (bytevector-length bv) 1
173 (procedure->pointer int cmp (list '* '*)))
175 (equal? (bytevector->u8-list bv)
177 (throw 'unresolved)))
179 (pass-if-exception "qsort, wrong return type"
180 exception:wrong-type-arg
182 (if (defined? 'procedure->pointer)
183 (let* ((cmp (lambda (x y) #f)) ; wrong return type
184 (ptr (procedure->pointer int cmp (list '* '*)))
185 (bv (u8-list->bytevector input)))
186 (qsort (bytevector->pointer bv) (bytevector-length bv) 1
187 (procedure->pointer int cmp (list '* '*)))
189 (throw 'unresolved)))
191 (pass-if-exception "qsort, wrong arity"
192 exception:wrong-num-args
194 (if (defined? 'procedure->pointer)
195 (let* ((cmp (lambda (x y z) #f)) ; wrong arity
196 (ptr (procedure->pointer int cmp (list '* '*)))
197 (bv (u8-list->bytevector input)))
198 (qsort (bytevector->pointer bv) (bytevector-length bv) 1
199 (procedure->pointer int cmp (list '* '*)))
201 (throw 'unresolved)))
204 (if (defined? 'procedure->pointer)
205 (let* ((proc (lambda (x y z)
208 (args (list float int16 double))
209 (proc* (pointer->procedure ret
210 (procedure->pointer ret proc args)
212 (arg1 (map (cut / <> 2.0) (iota 123)))
213 (arg2 (iota 123 32000))
214 (arg3 (map (cut / <> 4.0) (iota 123 100 4))))
215 (equal? (map proc arg1 arg2 arg3)
216 (map proc* arg1 arg2 arg3)))
217 (throw 'unresolved))))
220 (with-test-prefix "structs"
222 (pass-if "sizeof { int8, double }"
223 (= (sizeof (list int8 double))
224 (+ (alignof double) (sizeof double))))
226 (pass-if "sizeof { short, int, long, pointer }"
227 (let ((layout (list short int long '*)))
229 (reduce + 0.0 (map sizeof layout)))))
231 (pass-if "parse-c-struct"
232 (let ((layout (list int64 uint8))
233 (data (list -300 43)))
234 (equal? (parse-c-struct (make-c-struct layout data)
238 (pass-if "alignment constraints honored"
239 (let ((layout (list int8 double))
240 (data (list -7 3.14)))
241 (equal? (parse-c-struct (make-c-struct layout data)
245 (pass-if "int8, pointer"
246 (let ((layout (list uint8 '*))
247 (data (list 222 (make-pointer 7777))))
248 (equal? (parse-c-struct (make-c-struct layout data)
252 (pass-if "unsigned-long, int8, size_t"
253 (let ((layout (list unsigned-long int8 size_t))
254 (data (list (expt 2 17) -128 (expt 2 18))))
255 (equal? (parse-c-struct (make-c-struct layout data)
259 (pass-if "long, int, pointer"
260 (let ((layout (list long int '*))
261 (data (list (- (expt 2 17)) -222 (make-pointer 777))))
262 (equal? (parse-c-struct (make-c-struct layout data)
266 (pass-if "int8, pointer, short, double"
267 (let ((layout (list int8 '* short double))
268 (data (list 77 %null-pointer -42 3.14)))
269 (equal? (parse-c-struct (make-c-struct layout data)