callbacks.lisp - clic - Clic is an command line interactive client for gopher w… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
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-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) |