Commit | Line | Data |
---|---|---|
01ad5a7b LC |
1 | ;;;; foreign.test --- FFI. -*- mode: scheme; coding: utf-8; -*- |
2 | ;;;; | |
1f4f7674 | 3 | ;;;; Copyright (C) 2010, 2011 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) |
01ad5a7b LC |
28 | #:use-module (test-suite lib)) |
29 | ||
30 | \f | |
31 | (with-test-prefix "null pointer" | |
32 | ||
6e097560 LC |
33 | (pass-if "pointer?" |
34 | (pointer? %null-pointer)) | |
35 | ||
01ad5a7b | 36 | (pass-if "zero" |
5b46a8c2 | 37 | (= 0 (pointer-address %null-pointer))) |
01ad5a7b | 38 | |
d4149a51 LC |
39 | (pass-if "null pointer identity" |
40 | (eq? %null-pointer (make-pointer 0))) | |
41 | ||
42 | (pass-if "null-pointer? %null-pointer" | |
43 | (null-pointer? %null-pointer)) | |
01ad5a7b | 44 | |
5b46a8c2 | 45 | (pass-if-exception "pointer->bytevector %null-pointer" |
01ad5a7b | 46 | exception:null-pointer-error |
5b46a8c2 | 47 | (pointer->bytevector %null-pointer 7))) |
01ad5a7b | 48 | |
d4149a51 LC |
49 | \f |
50 | (with-test-prefix "make-pointer" | |
51 | ||
6e097560 LC |
52 | (pass-if "pointer?" |
53 | (pointer? (make-pointer 123))) | |
54 | ||
d4149a51 | 55 | (pass-if "address preserved" |
cb2d8076 LC |
56 | (= 123 (pointer-address (make-pointer 123)))) |
57 | ||
58 | (pass-if "equal?" | |
59 | (equal? (make-pointer 123) (make-pointer 123))) | |
60 | ||
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)))) | |
65 | ||
66 | (pass-if "not equal?" | |
67 | (not (equal? (make-pointer 123) (make-pointer 456))))) | |
d4149a51 LC |
68 | |
69 | \f | |
1f4f7674 LC |
70 | (define-wrapped-pointer-type foo? |
71 | wrap-foo unwrap-foo | |
72 | (lambda (x p) | |
73 | (format p "#<foo! ~a>" (pointer-address (unwrap-foo x))))) | |
74 | ||
75 | (with-test-prefix "define-wrapped-pointer-type" | |
76 | ||
77 | (pass-if "foo?" | |
78 | (foo? (wrap-foo %null-pointer))) | |
79 | ||
80 | (pass-if "unwrap-foo" | |
81 | (let ((p (make-pointer 123))) | |
82 | (eq? p (unwrap-foo (wrap-foo p))))) | |
83 | ||
84 | (pass-if "identity" | |
85 | (let ((p1 (make-pointer 123)) | |
86 | (p2 (make-pointer 123))) | |
87 | (eq? (wrap-foo p1) | |
88 | (wrap-foo p2)))) | |
89 | ||
90 | (pass-if "printer" | |
91 | (string=? "#<foo! 123>" | |
92 | (with-output-to-string | |
93 | (lambda () | |
94 | (write (wrap-foo (make-pointer 123)))))))) | |
95 | ||
96 | \f | |
5b46a8c2 | 97 | (with-test-prefix "pointer<->bytevector" |
d4149a51 LC |
98 | |
99 | (pass-if "bijection" | |
100 | (let ((bv #vu8(0 1 2 3 4 5 6 7))) | |
5b46a8c2 | 101 | (equal? (pointer->bytevector (bytevector->pointer bv) |
d4149a51 LC |
102 | (bytevector-length bv)) |
103 | bv))) | |
104 | ||
105 | (pass-if "pointer from bits" | |
106 | (let* ((bytes (iota (sizeof '*))) | |
107 | (bv (u8-list->bytevector bytes))) | |
5b46a8c2 | 108 | (= (pointer-address |
d4149a51 LC |
109 | (make-pointer (bytevector-uint-ref bv 0 (native-endianness) |
110 | (sizeof '*)))) | |
17fc9efe LC |
111 | (fold-right (lambda (byte address) |
112 | (+ byte (* 256 address))) | |
113 | 0 | |
114 | bytes)))) | |
115 | ||
116 | (pass-if "dereference-pointer" | |
117 | (let* ((bytes (iota (sizeof '*))) | |
118 | (bv (u8-list->bytevector bytes))) | |
5b46a8c2 LC |
119 | (= (pointer-address |
120 | (dereference-pointer (bytevector->pointer bv))) | |
d4149a51 LC |
121 | (fold-right (lambda (byte address) |
122 | (+ byte (* 256 address))) | |
123 | 0 | |
124 | bytes))))) | |
7387c231 LC |
125 | |
126 | \f | |
fa2a89a6 LC |
127 | (with-test-prefix "pointer<->string" |
128 | ||
129 | (pass-if "bijection" | |
130 | (let ((s "hello, world")) | |
131 | (string=? s (pointer->string (string->pointer s))))) | |
132 | ||
133 | (pass-if "bijection [latin1]" | |
134 | (with-latin1-locale | |
135 | (let ((s "Szép jó napot!")) | |
136 | (string=? s (pointer->string (string->pointer s))))))) | |
137 | ||
138 | \f | |
33186356 LC |
139 | (with-test-prefix "procedure->pointer" |
140 | ||
141 | (define qsort | |
142 | ;; Bindings for libc's `qsort' function. | |
2ee07358 LC |
143 | (pointer->procedure void |
144 | (dynamic-func "qsort" (dynamic-link)) | |
145 | (list '* size_t size_t '*))) | |
33186356 LC |
146 | |
147 | (define (dereference-pointer-to-byte ptr) | |
148 | (let ((b (pointer->bytevector ptr 1))) | |
149 | (bytevector-u8-ref b 0))) | |
150 | ||
151 | (define input | |
152 | '(7 1 127 3 5 4 77 2 9 0)) | |
153 | ||
154 | (pass-if "qsort" | |
155 | (if (defined? 'procedure->pointer) | |
156 | (let* ((called? #f) | |
157 | (cmp (lambda (x y) | |
158 | (set! called? #t) | |
159 | (- (dereference-pointer-to-byte x) | |
160 | (dereference-pointer-to-byte y)))) | |
161 | (ptr (procedure->pointer int cmp (list '* '*))) | |
162 | (bv (u8-list->bytevector input))) | |
163 | (qsort (bytevector->pointer bv) (bytevector-length bv) 1 | |
164 | (procedure->pointer int cmp (list '* '*))) | |
165 | (and called? | |
166 | (equal? (bytevector->u8-list bv) | |
167 | (sort input <)))) | |
168 | (throw 'unresolved))) | |
169 | ||
170 | (pass-if-exception "qsort, wrong return type" | |
171 | exception:wrong-type-arg | |
172 | ||
173 | (if (defined? 'procedure->pointer) | |
174 | (let* ((cmp (lambda (x y) #f)) ; wrong return type | |
175 | (ptr (procedure->pointer int cmp (list '* '*))) | |
176 | (bv (u8-list->bytevector input))) | |
177 | (qsort (bytevector->pointer bv) (bytevector-length bv) 1 | |
178 | (procedure->pointer int cmp (list '* '*))) | |
179 | #f) | |
180 | (throw 'unresolved))) | |
181 | ||
182 | (pass-if-exception "qsort, wrong arity" | |
183 | exception:wrong-num-args | |
184 | ||
185 | (if (defined? 'procedure->pointer) | |
186 | (let* ((cmp (lambda (x y z) #f)) ; wrong arity | |
187 | (ptr (procedure->pointer int cmp (list '* '*))) | |
188 | (bv (u8-list->bytevector input))) | |
189 | (qsort (bytevector->pointer bv) (bytevector-length bv) 1 | |
190 | (procedure->pointer int cmp (list '* '*))) | |
191 | #f) | |
fb0b64c1 LC |
192 | (throw 'unresolved))) |
193 | ||
194 | (pass-if "bijection" | |
195 | (if (defined? 'procedure->pointer) | |
196 | (let* ((proc (lambda (x y z) | |
197 | (+ x y z 0.0))) | |
198 | (ret double) | |
199 | (args (list float int16 double)) | |
2ee07358 LC |
200 | (proc* (pointer->procedure ret |
201 | (procedure->pointer ret proc args) | |
202 | args)) | |
fb0b64c1 LC |
203 | (arg1 (map (cut / <> 2.0) (iota 123))) |
204 | (arg2 (iota 123 32000)) | |
205 | (arg3 (map (cut / <> 4.0) (iota 123 100 4)))) | |
206 | (equal? (map proc arg1 arg2 arg3) | |
207 | (map proc* arg1 arg2 arg3))) | |
33186356 LC |
208 | (throw 'unresolved)))) |
209 | ||
210 | \f | |
7387c231 LC |
211 | (with-test-prefix "structs" |
212 | ||
16f06128 LC |
213 | (pass-if "sizeof { int8, double }" |
214 | (= (sizeof (list int8 double)) | |
215 | (+ (alignof double) (sizeof double)))) | |
216 | ||
217 | (pass-if "sizeof { short, int, long, pointer }" | |
218 | (let ((layout (list short int long '*))) | |
219 | (>= (sizeof layout) | |
220 | (reduce + 0.0 (map sizeof layout))))) | |
221 | ||
7387c231 LC |
222 | (pass-if "parse-c-struct" |
223 | (let ((layout (list int64 uint8)) | |
224 | (data (list -300 43))) | |
1f864a16 LC |
225 | (equal? (parse-c-struct (make-c-struct layout data) |
226 | layout) | |
227 | data))) | |
228 | ||
229 | (pass-if "alignment constraints honored" | |
230 | (let ((layout (list int8 double)) | |
231 | (data (list -7 3.14))) | |
fb636a1c LC |
232 | (equal? (parse-c-struct (make-c-struct layout data) |
233 | layout) | |
234 | data))) | |
235 | ||
236 | (pass-if "int8, pointer" | |
237 | (let ((layout (list uint8 '*)) | |
238 | (data (list 222 (make-pointer 7777)))) | |
239 | (equal? (parse-c-struct (make-c-struct layout data) | |
240 | layout) | |
241 | data))) | |
242 | ||
243 | (pass-if "unsigned-long, int8, size_t" | |
244 | (let ((layout (list unsigned-long int8 size_t)) | |
245 | (data (list (expt 2 17) -128 (expt 2 18)))) | |
246 | (equal? (parse-c-struct (make-c-struct layout data) | |
247 | layout) | |
248 | data))) | |
249 | ||
250 | (pass-if "long, int, pointer" | |
251 | (let ((layout (list long int '*)) | |
252 | (data (list (- (expt 2 17)) -222 (make-pointer 777)))) | |
42f7c01e LC |
253 | (equal? (parse-c-struct (make-c-struct layout data) |
254 | layout) | |
255 | data))) | |
256 | ||
257 | (pass-if "int8, pointer, short, double" | |
258 | (let ((layout (list int8 '* short double)) | |
259 | (data (list 77 %null-pointer -42 3.14))) | |
7387c231 LC |
260 | (equal? (parse-c-struct (make-c-struct layout data) |
261 | layout) | |
262 | data)))) |