 |
tcallbacks.lisp - clic - Clic is an command line interactive client for gopher … |
 |
git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/ |
 |
Log |
|
Files |
|
Refs |
|
Tags |
|
LICENSE |
|
--- |
|
tcallbacks.lisp (20279B) |
|
--- |
|
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- |
|
2 ;;; |
|
3 ;;; callbacks.lisp --- Tests on callbacks. |
|
4 ;;; |
|
5 ;;; Copyright (C) 2005-2006, Luis Oliveira <loliveira(@)common-lisp.net> |
|
6 ;;; |
|
7 ;;; Permission is hereby granted, free of charge, to any person |
|
8 ;;; obtaining a copy of this software and associated documentation |
|
9 ;;; files (the "Software"), to deal in the Software without |
|
10 ;;; restriction, including without limitation the rights to use, copy, |
|
11 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies |
|
12 ;;; of the Software, and to permit persons to whom the Software is |
|
13 ;;; furnished to do so, subject to the following conditions: |
|
14 ;;; |
|
15 ;;; The above copyright notice and this permission notice shall be |
|
16 ;;; included in all copies or substantial portions of the Software. |
|
17 ;;; |
|
18 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, |
|
19 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF |
|
20 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND |
|
21 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT |
|
22 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, |
|
23 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, |
|
24 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER |
|
25 ;;; DEALINGS IN THE SOFTWARE. |
|
26 ;;; |
|
27 |
|
28 (in-package #:cffi-tests) |
|
29 |
|
30 (defcfun "expect_char_sum" :int (f :pointer)) |
|
31 (defcfun "expect_unsigned_char_sum" :int (f :pointer)) |
|
32 (defcfun "expect_short_sum" :int (f :pointer)) |
|
33 (defcfun "expect_unsigned_short_sum" :int (f :pointer)) |
|
34 (defcfun "expect_int_sum" :int (f :pointer)) |
|
35 (defcfun "expect_unsigned_int_sum" :int (f :pointer)) |
|
36 (defcfun "expect_long_sum" :int (f :pointer)) |
|
37 (defcfun "expect_unsigned_long_sum" :int (f :pointer)) |
|
38 (defcfun "expect_float_sum" :int (f :pointer)) |
|
39 (defcfun "expect_double_sum" :int (f :pointer)) |
|
40 (defcfun "expect_pointer_sum" :int (f :pointer)) |
|
41 (defcfun "expect_strcat" :int (f :pointer)) |
|
42 |
|
43 #-cffi-sys::no-long-long |
|
44 (progn |
|
45 (defcfun "expect_long_long_sum" :int (f :pointer)) |
|
46 (defcfun "expect_unsigned_long_long_sum" :int (f :pointer))) |
|
47 |
|
48 #+(and scl long-float) |
|
49 (defcfun "expect_long_double_sum" :int (f :pointer)) |
|
50 |
|
51 (defcallback sum-char :char ((a :char) (b :char)) |
|
52 "Test if the named block is present and the docstring too." |
|
53 ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b) |
|
54 (return-from sum-char (+ a b))) |
|
55 |
|
56 (defcallback sum-unsigned-char :unsigned-char |
|
57 ((a :unsigned-char) (b :unsigned-char)) |
|
58 ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b) |
|
59 (+ a b)) |
|
60 |
|
61 (defcallback sum-short :short ((a :short) (b :short)) |
|
62 ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b) |
|
63 (+ a b)) |
|
64 |
|
65 (defcallback sum-unsigned-short :unsigned-short |
|
66 ((a :unsigned-short) (b :unsigned-short)) |
|
67 ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b) |
|
68 (+ a b)) |
|
69 |
|
70 (defcallback sum-int :int ((a :int) (b :int)) |
|
71 (+ a b)) |
|
72 |
|
73 (defcallback sum-unsigned-int :unsigned-int |
|
74 ((a :unsigned-int) (b :unsigned-int)) |
|
75 (+ a b)) |
|
76 |
|
77 (defcallback sum-long :long ((a :long) (b :long)) |
|
78 (+ a b)) |
|
79 |
|
80 (defcallback sum-unsigned-long :unsigned-long |
|
81 ((a :unsigned-long) (b :unsigned-long)) |
|
82 (+ a b)) |
|
83 |
|
84 #-cffi-sys::no-long-long |
|
85 (progn |
|
86 (defcallback sum-long-long :long-long |
|
87 ((a :long-long) (b :long-long)) |
|
88 (+ a b)) |
|
89 |
|
90 (defcallback sum-unsigned-long-long :unsigned-long-long |
|
91 ((a :unsigned-long-long) (b :unsigned-long-long)) |
|
92 (+ a b))) |
|
93 |
|
94 (defcallback sum-float :float ((a :float) (b :float)) |
|
95 ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b) |
|
96 (+ a b)) |
|
97 |
|
98 (defcallback sum-double :double ((a :double) (b :double)) |
|
99 ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b) |
|
100 (+ a b)) |
|
101 |
|
102 #+(and scl long-float) |
|
103 (defcallback sum-long-double :long-double ((a :long-double) (b :long-dou… |
|
104 ;(format t "~%}}} a: ~A, b: ~A {{{~%" a b) |
|
105 (+ a b)) |
|
106 |
|
107 (defcallback sum-pointer :pointer ((ptr :pointer) (offset :int)) |
|
108 (inc-pointer ptr offset)) |
|
109 |
|
110 (defcallback lisp-strcat :string ((a :string) (b :string)) |
|
111 (concatenate 'string a b)) |
|
112 |
|
113 (deftest callbacks.char |
|
114 (expect-char-sum (get-callback 'sum-char)) |
|
115 1) |
|
116 |
|
117 (deftest callbacks.unsigned-char |
|
118 (expect-unsigned-char-sum (get-callback 'sum-unsigned-char)) |
|
119 1) |
|
120 |
|
121 (deftest callbacks.short |
|
122 (expect-short-sum (callback sum-short)) |
|
123 1) |
|
124 |
|
125 (deftest callbacks.unsigned-short |
|
126 (expect-unsigned-short-sum (callback sum-unsigned-short)) |
|
127 1) |
|
128 |
|
129 (deftest callbacks.int |
|
130 (expect-int-sum (callback sum-int)) |
|
131 1) |
|
132 |
|
133 (deftest callbacks.unsigned-int |
|
134 (expect-unsigned-int-sum (callback sum-unsigned-int)) |
|
135 1) |
|
136 |
|
137 (deftest callbacks.long |
|
138 (expect-long-sum (callback sum-long)) |
|
139 1) |
|
140 |
|
141 (deftest callbacks.unsigned-long |
|
142 (expect-unsigned-long-sum (callback sum-unsigned-long)) |
|
143 1) |
|
144 |
|
145 #-cffi-sys::no-long-long |
|
146 (progn |
|
147 (deftest (callbacks.long-long :expected-to-fail (alexandria:featurep :… |
|
148 (expect-long-long-sum (callback sum-long-long)) |
|
149 1) |
|
150 |
|
151 (deftest callbacks.unsigned-long-long |
|
152 (expect-unsigned-long-long-sum (callback sum-unsigned-long-long)) |
|
153 1)) |
|
154 |
|
155 (deftest callbacks.float |
|
156 (expect-float-sum (callback sum-float)) |
|
157 1) |
|
158 |
|
159 (deftest callbacks.double |
|
160 (expect-double-sum (callback sum-double)) |
|
161 1) |
|
162 |
|
163 #+(and scl long-float) |
|
164 (deftest callbacks.long-double |
|
165 (expect-long-double-sum (callback sum-long-double)) |
|
166 1) |
|
167 |
|
168 (deftest callbacks.pointer |
|
169 (expect-pointer-sum (callback sum-pointer)) |
|
170 1) |
|
171 |
|
172 (deftest callbacks.string |
|
173 (expect-strcat (callback lisp-strcat)) |
|
174 1) |
|
175 |
|
176 #-cffi-sys::no-foreign-funcall |
|
177 (defcallback return-a-string-not-nil :string () |
|
178 "abc") |
|
179 |
|
180 #-cffi-sys::no-foreign-funcall |
|
181 (deftest callbacks.string-not-docstring |
|
182 (foreign-funcall-pointer (callback return-a-string-not-nil) () :stri… |
|
183 "abc") |
|
184 |
|
185 (defcallback check-for-nil :boolean ((pointer :pointer)) |
|
186 (null pointer)) |
|
187 |
|
188 #-cffi-sys::no-foreign-funcall |
|
189 (deftest callbacks.nil-for-null |
|
190 (foreign-funcall-pointer (callback check-for-nil) nil |
|
191 :pointer (null-pointer) :boolean) |
|
192 nil) |
|
193 |
|
194 ;;; This one tests mem-aref too. |
|
195 (defcfun "qsort" :void |
|
196 (base :pointer) |
|
197 (nmemb :int) |
|
198 (size :int) |
|
199 (fun-compar :pointer)) |
|
200 |
|
201 (defcallback < :int ((a :pointer) (b :pointer)) |
|
202 (let ((x (mem-ref a :int)) |
|
203 (y (mem-ref b :int))) |
|
204 (cond ((> x y) 1) |
|
205 ((< x y) -1) |
|
206 (t 0)))) |
|
207 |
|
208 (deftest callbacks.qsort |
|
209 (with-foreign-object (array :int 10) |
|
210 ;; Initialize array. |
|
211 (loop for i from 0 and n in '(7 2 10 4 3 5 1 6 9 8) |
|
212 do (setf (mem-aref array :int i) n)) |
|
213 ;; Sort it. |
|
214 (qsort array 10 (foreign-type-size :int) (callback <)) |
|
215 ;; Return it as a list. |
|
216 (loop for i from 0 below 10 |
|
217 collect (mem-aref array :int i))) |
|
218 (1 2 3 4 5 6 7 8 9 10)) |
|
219 |
|
220 ;;; void callback |
|
221 (defparameter *int* -1) |
|
222 |
|
223 (defcfun "pass_int_ref" :void (f :pointer)) |
|
224 |
|
225 ;;; CMUCL chokes on this one for some reason. |
|
226 #-(and darwin cmucl) |
|
227 (defcallback read-int-from-pointer :void ((a :pointer)) |
|
228 (setq *int* (mem-ref a :int))) |
|
229 |
|
230 #+(and darwin cmucl) |
|
231 (pushnew 'callbacks.void rt::*expected-failures*) |
|
232 |
|
233 (deftest callbacks.void |
|
234 (progn |
|
235 (pass-int-ref (callback read-int-from-pointer)) |
|
236 *int*) |
|
237 1984) |
|
238 |
|
239 ;;; test funcalling of a callback and also declarations inside |
|
240 ;;; callbacks. |
|
241 |
|
242 #-cffi-sys::no-foreign-funcall |
|
243 (progn |
|
244 (defcallback sum-2 :int ((a :int) (b :int) (c :int)) |
|
245 (declare (ignore c)) |
|
246 (+ a b)) |
|
247 |
|
248 (deftest callbacks.funcall.1 |
|
249 (foreign-funcall-pointer (callback sum-2) () :int 2 :int 3 :int 1 … |
|
250 5) |
|
251 |
|
252 (defctype foo-float :float) |
|
253 |
|
254 (defcallback sum-2f foo-float |
|
255 ((a foo-float) (b foo-float) (c foo-float) (d foo-float) (e foo-fl… |
|
256 "This one ignores the middle 3 arguments." |
|
257 (declare (ignore b c)) |
|
258 (declare (ignore d)) |
|
259 (+ a e)) |
|
260 |
|
261 (deftest callbacks.funcall.2 |
|
262 (foreign-funcall-pointer (callback sum-2f) () foo-float 1.0 foo-fl… |
|
263 foo-float 3.0 foo-float 4.0 foo-float 5.0 |
|
264 foo-float) |
|
265 6.0)) |
|
266 |
|
267 ;;; (cb-test :no-long-long t) |
|
268 |
|
269 (defcfun "call_sum_127_no_ll" :long (cb :pointer)) |
|
270 |
|
271 ;;; CMUCL and CCL choke on this one. |
|
272 #-(or cmucl clozure |
|
273 #.(cl:if (cl:>= cl:lambda-parameters-limit 127) '(:or) '(:and))) |
|
274 (defcallback sum-127-no-ll :long |
|
275 ((a1 :unsigned-long) (a2 :pointer) (a3 :long) (a4 :double) |
|
276 (a5 :unsigned-long) (a6 :float) (a7 :float) (a8 :int) (a9 :unsigned… |
|
277 (a10 :double) (a11 :double) (a12 :double) (a13 :pointer) |
|
278 (a14 :unsigned-short) (a15 :unsigned-short) (a16 :pointer) (a17 :lo… |
|
279 (a18 :long) (a19 :int) (a20 :short) (a21 :unsigned-short) |
|
280 (a22 :unsigned-short) (a23 :char) (a24 :long) (a25 :pointer) (a26 :… |
|
281 (a27 :char) (a28 :unsigned-char) (a29 :unsigned-long) (a30 :short) |
|
282 (a31 :int) (a32 :int) (a33 :unsigned-char) (a34 :short) (a35 :long) |
|
283 (a36 :long) (a37 :pointer) (a38 :unsigned-short) (a39 :char) (a40 :… |
|
284 (a41 :unsigned-short) (a42 :pointer) (a43 :short) (a44 :unsigned-lo… |
|
285 (a45 :unsigned-short) (a46 :float) (a47 :unsigned-char) (a48 :short) |
|
286 (a49 :float) (a50 :short) (a51 :char) (a52 :unsigned-long) |
|
287 (a53 :unsigned-long) (a54 :char) (a55 :float) (a56 :long) (a57 :poi… |
|
288 (a58 :short) (a59 :float) (a60 :unsigned-int) (a61 :float) |
|
289 (a62 :unsigned-int) (a63 :double) (a64 :unsigned-int) (a65 :unsigne… |
|
290 (a66 :int) (a67 :long) (a68 :char) (a69 :short) (a70 :double) (a71 … |
|
291 (a72 :pointer) (a73 :char) (a74 :unsigned-short) (a75 :pointer) |
|
292 (a76 :unsigned-short) (a77 :pointer) (a78 :unsigned-long) (a79 :dou… |
|
293 (a80 :pointer) (a81 :long) (a82 :float) (a83 :unsigned-short) |
|
294 (a84 :unsigned-short) (a85 :pointer) (a86 :float) (a87 :int) |
|
295 (a88 :unsigned-int) (a89 :double) (a90 :float) (a91 :long) (a92 :po… |
|
296 (a93 :unsigned-short) (a94 :float) (a95 :unsigned-char) (a96 :unsig… |
|
297 (a97 :float) (a98 :unsigned-int) (a99 :float) (a100 :unsigned-short) |
|
298 (a101 :double) (a102 :unsigned-short) (a103 :unsigned-long) |
|
299 (a104 :unsigned-int) (a105 :unsigned-long) (a106 :pointer) |
|
300 (a107 :unsigned-char) (a108 :char) (a109 :char) (a110 :unsigned-sho… |
|
301 (a111 :unsigned-long) (a112 :float) (a113 :short) (a114 :pointer) |
|
302 (a115 :long) (a116 :unsigned-short) (a117 :short) (a118 :double) |
|
303 (a119 :short) (a120 :int) (a121 :char) (a122 :unsigned-long) (a123 … |
|
304 (a124 :int) (a125 :pointer) (a126 :double) (a127 :unsigned-char)) |
|
305 (let ((args (list a1 (pointer-address a2) a3 (floor a4) a5 (floor a6) |
|
306 (floor a7) a8 a9 (floor a10) (floor a11) (floor a12) |
|
307 (pointer-address a13) a14 a15 (pointer-address a16) … |
|
308 a19 a20 a21 a22 a23 a24 (pointer-address a25) |
|
309 (pointer-address a26) a27 a28 a29 a30 a31 a32 a33 a3… |
|
310 a36 (pointer-address a37) a38 a39 (floor a40) a41 |
|
311 (pointer-address a42) a43 a44 a45 (floor a46) a47 a48 |
|
312 (floor a49) a50 a51 a52 a53 a54 (floor a55) a56 |
|
313 (pointer-address a57) a58 (floor a59) a60 (floor a61… |
|
314 (floor a63) a64 a65 a66 a67 a68 a69 (floor a70) a71 |
|
315 (pointer-address a72) a73 a74 (pointer-address a75) … |
|
316 (pointer-address a77) a78 (floor a79) (pointer-addre… |
|
317 a81 (floor a82) a83 a84 (pointer-address a85) (floor… |
|
318 a87 a88 (floor a89) (floor a90) a91 (pointer-address… |
|
319 a93 (floor a94) a95 a96 (floor a97) a98 (floor a99) … |
|
320 (floor a101) a102 a103 a104 a105 (pointer-address a1… |
|
321 a108 a109 a110 a111 (floor a112) a113 (pointer-addre… |
|
322 a115 a116 a117 (floor a118) a119 a120 a121 a122 a123… |
|
323 (pointer-address a125) (floor a126) a127))) |
|
324 #-(and) |
|
325 (loop for i from 1 and arg in args do |
|
326 (format t "a~A: ~A~%" i arg)) |
|
327 (reduce #'+ args))) |
|
328 |
|
329 #+(or openmcl cmucl (and darwin (or allegro lispworks))) |
|
330 (push 'callbacks.bff.1 regression-test::*expected-failures*) |
|
331 |
|
332 #+#.(cl:if (cl:>= cl:lambda-parameters-limit 127) '(:and) '(:or)) |
|
333 (deftest callbacks.bff.1 |
|
334 (call-sum-127-no-ll (callback sum-127-no-ll)) |
|
335 2008547941) |
|
336 |
|
337 ;;; (cb-test) |
|
338 |
|
339 #-(or cffi-sys::no-long-long |
|
340 #.(cl:if (cl:>= cl:lambda-parameters-limit 127) '(or) '(and))) |
|
341 (progn |
|
342 (defcfun "call_sum_127" :long-long (cb :pointer)) |
|
343 |
|
344 ;;; CMUCL and CCL choke on this one. |
|
345 #-(or cmucl clozure) |
|
346 (defcallback sum-127 :long-long |
|
347 ((a1 :short) (a2 :char) (a3 :pointer) (a4 :float) (a5 :long) (a6 :… |
|
348 (a7 :unsigned-long-long) (a8 :unsigned-short) (a9 :unsigned-char) |
|
349 (a10 :char) (a11 :char) (a12 :unsigned-short) (a13 :unsigned-long… |
|
350 (a14 :unsigned-short) (a15 :long-long) (a16 :unsigned-short) |
|
351 (a17 :unsigned-long-long) (a18 :unsigned-char) (a19 :unsigned-cha… |
|
352 (a20 :unsigned-long-long) (a21 :long-long) (a22 :char) (a23 :floa… |
|
353 (a24 :unsigned-int) (a25 :float) (a26 :float) (a27 :unsigned-int) |
|
354 (a28 :float) (a29 :char) (a30 :unsigned-char) (a31 :long) (a32 :l… |
|
355 (a33 :unsigned-char) (a34 :double) (a35 :long) (a36 :double) |
|
356 (a37 :unsigned-int) (a38 :unsigned-short) (a39 :long-long) |
|
357 (a40 :unsigned-int) (a41 :int) (a42 :unsigned-long-long) (a43 :lo… |
|
358 (a44 :short) (a45 :unsigned-int) (a46 :unsigned-int) |
|
359 (a47 :unsigned-long-long) (a48 :unsigned-int) (a49 :long) (a50 :p… |
|
360 (a51 :unsigned-char) (a52 :char) (a53 :long-long) (a54 :unsigned-… |
|
361 (a55 :unsigned-int) (a56 :float) (a57 :unsigned-char) (a58 :unsig… |
|
362 (a59 :long-long) (a60 :float) (a61 :long) (a62 :float) (a63 :int) |
|
363 (a64 :float) (a65 :unsigned-short) (a66 :unsigned-long-long) (a67… |
|
364 (a68 :unsigned-long) (a69 :long) (a70 :char) (a71 :unsigned-short) |
|
365 (a72 :long-long) (a73 :short) (a74 :double) (a75 :pointer) |
|
366 (a76 :unsigned-int) (a77 :char) (a78 :unsigned-int) (a79 :pointer) |
|
367 (a80 :pointer) (a81 :unsigned-char) (a82 :pointer) (a83 :unsigned… |
|
368 (a84 :unsigned-char) (a85 :long) (a86 :pointer) (a87 :char) (a88 … |
|
369 (a89 :unsigned-short) (a90 :unsigned-char) (a91 :double) |
|
370 (a92 :unsigned-long-long) (a93 :unsigned-short) (a94 :unsigned-sh… |
|
371 (a95 :unsigned-int) (a96 :long) (a97 :char) (a98 :long) (a99 :cha… |
|
372 (a100 :short) (a101 :unsigned-short) (a102 :unsigned-long) |
|
373 (a103 :unsigned-long) (a104 :short) (a105 :long-long) (a106 :long… |
|
374 (a107 :long-long) (a108 :double) (a109 :unsigned-short) |
|
375 (a110 :unsigned-char) (a111 :short) (a112 :unsigned-char) (a113 :… |
|
376 (a114 :long-long) (a115 :unsigned-long-long) (a116 :unsigned-int) |
|
377 (a117 :unsigned-long) (a118 :unsigned-char) (a119 :long-long) |
|
378 (a120 :unsigned-char) (a121 :unsigned-long-long) (a122 :double) |
|
379 (a123 :unsigned-char) (a124 :long-long) (a125 :unsigned-char) |
|
380 (a126 :char) (a127 :long-long)) |
|
381 (+ a1 a2 (pointer-address a3) (values (floor a4)) a5 (values (floor … |
|
382 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 |
|
383 (values (floor a23)) a24 (values (floor a25)) (values (floor a26)) |
|
384 a27 (values (floor a28)) a29 a30 a31 a32 a33 (values (floor a34)) |
|
385 a35 (values (floor a36)) a37 a38 a39 a40 a41 a42 a43 a44 a45 a46 … |
|
386 a48 a49 (pointer-address a50) a51 a52 a53 a54 a55 (values (floor … |
|
387 a57 a58 a59 (values (floor a60)) a61 (values (floor a62)) a63 |
|
388 (values (floor a64)) a65 a66 a67 a68 a69 a70 a71 a72 a73 |
|
389 (values (floor a74)) (pointer-address a75) a76 a77 a78 |
|
390 (pointer-address a79) (pointer-address a80) a81 (pointer-address … |
|
391 a83 a84 a85 (pointer-address a86) a87 a88 a89 a90 (values (floor … |
|
392 a92 a93 a94 a95 a96 a97 a98 a99 a100 a101 a102 a103 a104 a105 a10… |
|
393 (values (floor a108)) a109 a110 a111 a112 a113 a114 a115 a116 a11… |
|
394 a119 a120 a121 (values (floor a122)) a123 a124 a125 a126 a127)) |
|
395 |
|
396 #+(or openmcl cmucl) |
|
397 (push 'callbacks.bff.2 rt::*expected-failures*) |
|
398 |
|
399 (deftest callbacks.bff.2 |
|
400 (call-sum-127 (callback sum-127)) |
|
401 8166570665645582011)) |
|
402 |
|
403 ;;; regression test: (callback non-existant-callback) should throw an er… |
|
404 (deftest callbacks.non-existant |
|
405 (not (null (nth-value 1 (ignore-errors (callback doesnt-exist))))) |
|
406 t) |
|
407 |
|
408 ;;; Handling many arguments of type double. Many lisps (used to) fail |
|
409 ;;; this one on darwin/ppc. This test might be bogus due to floating |
|
410 ;;; point arithmetic rounding errors. |
|
411 ;;; |
|
412 ;;; CMUCL chokes on this one. |
|
413 #-(and darwin cmucl) |
|
414 (defcallback double26 :double |
|
415 ((a1 :double) (a2 :double) (a3 :double) (a4 :double) (a5 :double) |
|
416 (a6 :double) (a7 :double) (a8 :double) (a9 :double) (a10 :double) |
|
417 (a11 :double) (a12 :double) (a13 :double) (a14 :double) (a15 :doubl… |
|
418 (a16 :double) (a17 :double) (a18 :double) (a19 :double) (a20 :doubl… |
|
419 (a21 :double) (a22 :double) (a23 :double) (a24 :double) (a25 :doubl… |
|
420 (a26 :double)) |
|
421 (let ((args (list a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 |
|
422 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26))) |
|
423 #-(and) |
|
424 (loop for i from 1 and arg in args do |
|
425 (format t "a~A: ~A~%" i arg)) |
|
426 (reduce #'+ args))) |
|
427 |
|
428 (defcfun "call_double26" :double (f :pointer)) |
|
429 |
|
430 #+(and darwin (or allegro cmucl)) |
|
431 (pushnew 'callbacks.double26 rt::*expected-failures*) |
|
432 |
|
433 (deftest callbacks.double26 |
|
434 (call-double26 (callback double26)) |
|
435 81.64d0) |
|
436 |
|
437 #+(and darwin cmucl) |
|
438 (pushnew 'callbacks.double26.funcall rt::*expected-failures*) |
|
439 |
|
440 #-cffi-sys::no-foreign-funcall |
|
441 (deftest callbacks.double26.funcall |
|
442 (foreign-funcall-pointer |
|
443 (callback double26) () :double 3.14d0 :double 3.14d0 |
|
444 :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0 |
|
445 :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0 |
|
446 :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0 |
|
447 :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0 |
|
448 :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0 |
|
449 :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0 |
|
450 :double) |
|
451 81.64d0) |
|
452 |
|
453 ;;; Same as above, for floats. |
|
454 #-(and darwin cmucl) |
|
455 (defcallback float26 :float |
|
456 ((a1 :float) (a2 :float) (a3 :float) (a4 :float) (a5 :float) |
|
457 (a6 :float) (a7 :float) (a8 :float) (a9 :float) (a10 :float) |
|
458 (a11 :float) (a12 :float) (a13 :float) (a14 :float) (a15 :float) |
|
459 (a16 :float) (a17 :float) (a18 :float) (a19 :float) (a20 :float) |
|
460 (a21 :float) (a22 :float) (a23 :float) (a24 :float) (a25 :float) |
|
461 (a26 :float)) |
|
462 (let ((args (list a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 |
|
463 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26))) |
|
464 #-(and) |
|
465 (loop for i from 1 and arg in args do |
|
466 (format t "a~A: ~A~%" i arg)) |
|
467 (reduce #'+ args))) |
|
468 |
|
469 (defcfun "call_float26" :float (f :pointer)) |
|
470 |
|
471 #+(and darwin (or lispworks openmcl cmucl)) |
|
472 (pushnew 'callbacks.float26 regression-test::*expected-failures*) |
|
473 |
|
474 (deftest callbacks.float26 |
|
475 (call-float26 (callback float26)) |
|
476 130.0) |
|
477 |
|
478 #+(and darwin (or lispworks openmcl cmucl)) |
|
479 (pushnew 'callbacks.float26.funcall regression-test::*expected-failures*) |
|
480 |
|
481 #-cffi-sys::no-foreign-funcall |
|
482 (deftest callbacks.float26.funcall |
|
483 (foreign-funcall-pointer |
|
484 (callback float26) () :float 5.0 :float 5.0 |
|
485 :float 5.0 :float 5.0 :float 5.0 :float 5.0 |
|
486 :float 5.0 :float 5.0 :float 5.0 :float 5.0 |
|
487 :float 5.0 :float 5.0 :float 5.0 :float 5.0 |
|
488 :float 5.0 :float 5.0 :float 5.0 :float 5.0 |
|
489 :float 5.0 :float 5.0 :float 5.0 :float 5.0 |
|
490 :float 5.0 :float 5.0 :float 5.0 :float 5.0 |
|
491 :float) |
|
492 130.0) |
|
493 |
|
494 ;;; Defining a callback as a non-toplevel form. Not portable. Doesn't |
|
495 ;;; work for CMUCL or Allegro. |
|
496 #-(and) |
|
497 (let ((n 42)) |
|
498 (defcallback non-toplevel-cb :int () |
|
499 n)) |
|
500 |
|
501 #-(and) |
|
502 (deftest callbacks.non-toplevel |
|
503 (foreign-funcall (callback non-toplevel-cb) :int) |
|
504 42) |
|
505 |
|
506 ;;;# Stdcall |
|
507 |
|
508 #+(and x86 (not cffi-sys::no-stdcall)) |
|
509 (progn |
|
510 (defcallback (stdcall-cb :convention :stdcall) :int |
|
511 ((a :int) (b :int) (c :int)) |
|
512 (+ a b c)) |
|
513 |
|
514 (defcfun "call_stdcall_fun" :int |
|
515 (f :pointer)) |
|
516 |
|
517 (deftest callbacks.stdcall.1 |
|
518 (call-stdcall-fun (callback stdcall-cb)) |
|
519 42)) |
|
520 |
|
521 ;;; RT: many of the %DEFCALLBACK implementations wouldn't handle |
|
522 ;;; uninterned symbols. |
|
523 (deftest callbacks.uninterned |
|
524 (values (defcallback #1=#:foo :void ()) |
|
525 (pointerp (callback #1#))) |
|
526 #1# t) |
