callbacks.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
callbacks.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-double))
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 :openmcl))
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) () :string)
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 :int)
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-float))
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-float 2.0
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-int)
277 (a10 :double) (a11 :double) (a12 :double) (a13 :pointer)
278 (a14 :unsigned-short) (a15 :unsigned-short) (a16 :pointer) (a17 :long)
279 (a18 :long) (a19 :int) (a20 :short) (a21 :unsigned-short)
280 (a22 :unsigned-short) (a23 :char) (a24 :long) (a25 :pointer) (a26 :pointer)
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 :double)
284 (a41 :unsigned-short) (a42 :pointer) (a43 :short) (a44 :unsigned-long)
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 :pointer)
288 (a58 :short) (a59 :float) (a60 :unsigned-int) (a61 :float)
289 (a62 :unsigned-int) (a63 :double) (a64 :unsigned-int) (a65 :unsigned-char)
290 (a66 :int) (a67 :long) (a68 :char) (a69 :short) (a70 :double) (a71 :int)
291 (a72 :pointer) (a73 :char) (a74 :unsigned-short) (a75 :pointer)
292 (a76 :unsigned-short) (a77 :pointer) (a78 :unsigned-long) (a79 :double)
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 :pointer)
296 (a93 :unsigned-short) (a94 :float) (a95 :unsigned-char) (a96 :unsigned-char)
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-short)
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 :long)
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) a17 a18
308 a19 a20 a21 a22 a23 a24 (pointer-address a25)
309 (pointer-address a26) a27 a28 a29 a30 a31 a32 a33 a34 a35
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) a62
314 (floor a63) a64 a65 a66 a67 a68 a69 (floor a70) a71
315 (pointer-address a72) a73 a74 (pointer-address a75) a76
316 (pointer-address a77) a78 (floor a79) (pointer-address a80)
317 a81 (floor a82) a83 a84 (pointer-address a85) (floor a86)
318 a87 a88 (floor a89) (floor a90) a91 (pointer-address a92)
319 a93 (floor a94) a95 a96 (floor a97) a98 (floor a99) a100
320 (floor a101) a102 a103 a104 a105 (pointer-address a106) a107
321 a108 a109 a110 a111 (floor a112) a113 (pointer-address a114)
322 a115 a116 a117 (floor a118) a119 a120 a121 a122 a123 a124
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 :double)
348 (a7 :unsigned-long-long) (a8 :unsigned-short) (a9 :unsigned-char)
349 (a10 :char) (a11 :char) (a12 :unsigned-short) (a13 :unsigned-long-long)
350 (a14 :unsigned-short) (a15 :long-long) (a16 :unsigned-short)
351 (a17 :unsigned-long-long) (a18 :unsigned-char) (a19 :unsigned-char)
352 (a20 :unsigned-long-long) (a21 :long-long) (a22 :char) (a23 :float)
353 (a24 :unsigned-int) (a25 :float) (a26 :float) (a27 :unsigned-int)
354 (a28 :float) (a29 :char) (a30 :unsigned-char) (a31 :long) (a32 :long-long)
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 :long)
358 (a44 :short) (a45 :unsigned-int) (a46 :unsigned-int)
359 (a47 :unsigned-long-long) (a48 :unsigned-int) (a49 :long) (a50 :pointer)
360 (a51 :unsigned-char) (a52 :char) (a53 :long-long) (a54 :unsigned-short)
361 (a55 :unsigned-int) (a56 :float) (a57 :unsigned-char) (a58 :unsigned-long)
362 (a59 :long-long) (a60 :float) (a61 :long) (a62 :float) (a63 :int)
363 (a64 :float) (a65 :unsigned-short) (a66 :unsigned-long-long) (a67 :short)
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-short)
368 (a84 :unsigned-char) (a85 :long) (a86 :pointer) (a87 :char) (a88 :long)
369 (a89 :unsigned-short) (a90 :unsigned-char) (a91 :double)
370 (a92 :unsigned-long-long) (a93 :unsigned-short) (a94 :unsigned-short)
371 (a95 :unsigned-int) (a96 :long) (a97 :char) (a98 :long) (a99 :char)
372 (a100 :short) (a101 :unsigned-short) (a102 :unsigned-long)
373 (a103 :unsigned-long) (a104 :short) (a105 :long-long) (a106 :long-long)
374 (a107 :long-long) (a108 :double) (a109 :unsigned-short)
375 (a110 :unsigned-char) (a111 :short) (a112 :unsigned-char) (a113 :long)
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 a6))
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 a47
386 a48 a49 (pointer-address a50) a51 a52 a53 a54 a55 (values (floor a56))
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 a82)
391 a83 a84 a85 (pointer-address a86) a87 a88 a89 a90 (values (floor a91))
392 a92 a93 a94 a95 a96 a97 a98 a99 a100 a101 a102 a103 a104 a105 a106 a107
393 (values (floor a108)) a109 a110 a111 a112 a113 a114 a115 a116 a117 a118
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 error
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 :double)
418 (a16 :double) (a17 :double) (a18 :double) (a19 :double) (a20 :double)
419 (a21 :double) (a22 :double) (a23 :double) (a24 :double) (a25 :double)
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)