1 ;;;; package lock tests with side effects
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
16 ;;; callbacks only on a few platforms
18 (quit :unix-status 104)
20 ;;; simple callback for a function
26 (sb-alien::alien-callback (function c-string) #'thunk))
28 (assert (equal (with-output-to-string (*standard-output*)
29 (alien-funcall *thunk*))
32 ;;; simple callback for a symbol
34 (defun add-two-ints (arg1 arg2)
37 (defvar *add-two-ints*
38 (sb-alien::alien-callback (function int int int) 'add-two-ints))
40 (assert (= (alien-funcall *add-two-ints* 555 444444) 444999))
42 ;;; actually using a callback with foreign code
44 (define-alien-routine qsort void
48 (compar (function int (* double) (* double))))
50 (sb-alien::define-alien-callback double*-cmp int ((arg1 (* double)) (arg2 (* double)))
51 (let ((a1 (deref arg1))
57 (let* ((vector (coerce '(0.1d0 0.5d0 0.2d0 1.2d0 1.5d0 2.5d0 0.0d0 0.1d0 0.2d0 0.3d0)
58 '(vector double-float)))
59 (sorted (sort (copy-seq vector) #'<)))
61 (sb-sys:with-pinned-objects (vector)
62 (qsort (sb-sys:vector-sap vector)
64 (alien-size double :bytes)
66 (assert (equalp vector sorted)))
70 (sb-alien::define-alien-callback redefined-fun int ()
74 '(sb-alien::define-alien-callback redefined-fun int ()
77 (assert (= 42 (alien-funcall redefined-fun)))
79 (sb-alien::define-alien-callback return-single float ((x float))
82 (sb-alien::define-alien-callback return-double double ((x double))
85 (defconstant spi (coerce pi 'single-float))
87 (assert (= spi (alien-funcall return-single spi)))
88 (assert (= pi (alien-funcall return-double pi)))
92 (sb-alien::define-alien-callback to-be-invalidated int ()
95 (assert (= 5 (alien-funcall to-be-invalidated)))
97 (multiple-value-bind (p valid) (sb-alien::alien-callback-p to-be-invalidated)
101 (sb-alien::invalidate-alien-callback to-be-invalidated)
103 (multiple-value-bind (p valid) (sb-alien::alien-callback-p to-be-invalidated)
105 (assert (not valid)))
107 (multiple-value-bind (res err)
108 (ignore-errors (alien-funcall to-be-invalidated))
109 (assert (and (not res) (typep err 'error))))
111 ;;; getting and setting the underlying function
113 (sb-alien::define-alien-callback foo int ()
118 (assert (eq #'foo (sb-alien::alien-callback-function foo)))
123 (setf (sb-alien::alien-callback-function foo) #'bar)
125 (assert (eq #'bar (sb-alien::alien-callback-function foo)))
127 (assert (= 26 (alien-funcall foo)))
129 ;;; callbacks with void return values
131 (with-test (:name void-return)
132 (sb-alien::alien-lambda void ()
135 ;;; tests for a sign extension problem in callback argument handling on x86-64
137 (defvar *add-two-ints* (sb-alien::alien-callback (function int int int) #'+))
139 (with-test (:name :sign-extension)
140 (assert (= (alien-funcall *add-two-ints* #x-80000000 1) -2147483647)))
142 ;;; On x86 This'll signal a TYPE-ERROR "The value -2147483649 is not of type
143 ;;; (SIGNED-BYTE 32)". On x86-64 it'll wrap around to 2147483647, probably
144 ;;; due to the sign-extension done by the (INTEGER :NATURALIZE-GEN)
145 ;;; alien-type-method. I believe the former behaviour is the one we want.
146 ;;; -- JES, 2005-10-16
148 (with-test (:name :underflow-detection :fails-on :x86-64)
149 (assert (raises-error? (alien-funcall *add-two-ints* #x-80000000 -1))))
151 ;;; tests for handling 64-bit arguments - this was causing problems on
152 ;;; ppc - CLH, 2005-12-01
154 (defvar *add-two-long-longs*
155 (sb-alien::alien-callback
156 (function (integer 64) (integer 64) (integer 64)) 'add-two-ints))
157 (with-test (:name :long-long-callback-arg)
158 (assert (= (alien-funcall *add-two-long-longs*
163 (defvar *add-two-unsigned-long-longs*
164 (sb-alien::alien-callback
165 (function (unsigned 64) (unsigned 64) (unsigned 64))
167 (with-test (:name :unsigned-long-long-callback-arg)
168 (assert (= (alien-funcall *add-two-unsigned-long-longs*
173 ;;; test for callbacks of various arities
176 (defmacro alien-apply-form (f args)
178 `(alien-funcall ,,f ,@a)))
180 (defmacro alien-apply (f &rest args)
181 `(eval (alien-apply-form ,f ,@args)))
183 (defun iota (x) (if (equalp x 1) (list x) (cons x (iota (1- x)))))
185 (defparameter *type-abbreviations*
186 '((sb-alien:char . "c")
187 (sb-alien:unsigned-char . "uc")
188 (sb-alien:short . "h")
189 (sb-alien:unsigned-short . "uh")
191 (sb-alien:unsigned-int . "ui")
192 ((sb-alien:integer 64) . "l")
193 ((sb-alien:unsigned 64) . "ul")
194 (sb-alien:float . "f")
195 (sb-alien:double . "d")))
197 (defun parse-callback-arg-spec (spec)
198 (let ((l (coerce spec 'list)))
199 (loop for g in l by #'cddr
200 collect (car (rassoc (string-downcase g) *type-abbreviations* :test #'equal)))))
202 (defmacro define-callback-adder (&rest types)
203 (let ((fname (format nil "*add-~{~A~^-~}*"
206 (cdr (assoc x *type-abbreviations*)))
208 #'(lambda (y) (find-symbol (string-upcase y) 'sb-alien))
211 (defparameter ,(intern
212 (string-upcase fname))
213 (sb-alien::alien-callback (function ,@types) '+)))))
215 (with-test (:name :define-2-int-callback)
216 (define-callback-adder int int int))
217 (with-test (:name :call-2-int-callback)
218 (assert (= (alien-apply *add-i-i* (iota 2)) 3)))
220 (with-test (:name :define-3-int-callback)
221 (define-callback-adder int int int int))
222 (with-test (:name :call-3-int-callback)
223 (assert (= (alien-apply *add-i-i-i* (iota 3)) 6)))
225 (with-test (:name :define-4-int-callback)
226 (define-callback-adder int int int int int))
227 (with-test (:name :call-4-int-callback)
228 (assert (= (alien-apply *add-i-i-i-i* (iota 4)) 10)))
230 (with-test (:name :define-5-int-callback)
231 (define-callback-adder int int int int int int))
232 (with-test (:name :call-5-int-callback)
233 (assert (= (alien-apply *add-i-i-i-i-i* (iota 5)) 15)))
235 (with-test (:name :define-6-int-callback)
236 (define-callback-adder int int int int int int int))
237 (with-test (:name :call-6-int-callback)
238 (assert (= (alien-apply *add-i-i-i-i-i-i* (iota 6)) 21)))
240 (with-test (:name :define-7-int-callback)
241 (define-callback-adder int int int int int int int int))
242 (with-test (:name :call-7-int-callback)
243 (assert (= (alien-apply *add-i-i-i-i-i-i-i* (iota 7)) 28)))
245 (with-test (:name :define-8-int-callback)
246 (define-callback-adder int int int int int int int int int))
247 (with-test (:name :call-8-int-callback)
248 (assert (= (alien-apply *add-i-i-i-i-i-i-i-i* (iota 8)) 36)))
250 (with-test (:name :define-9-int-callback)
251 (define-callback-adder int int int int int int int int int int))
252 (with-test (:name :call-9-int-callback)
253 (assert (= (alien-apply *add-i-i-i-i-i-i-i-i-i* (iota 9)) 45)))
255 (with-test (:name :define-10-int-callback)
256 (define-callback-adder int int int int int int int int int int int))
257 (with-test (:name :call-10-int-callback)
258 (assert (= (alien-apply *add-i-i-i-i-i-i-i-i-i-i* (iota 10)) 55)))
260 (with-test (:name :define-11-int-callback)
261 (define-callback-adder int int int int int int int int int int int int))
262 (with-test (:name :call-11-int-callback)
263 (assert (= (alien-apply *add-i-i-i-i-i-i-i-i-i-i-i* (iota 11)) 66)))
265 (with-test (:name :define-12-int-callback)
266 (define-callback-adder int int int int int int int int int int int int int))
267 (with-test (:name :call-12-int-callback)
268 (assert (= (alien-apply *add-i-i-i-i-i-i-i-i-i-i-i-i* (iota 12)) 78)))
270 (with-test (:name :define-2-float-callback)
271 (define-callback-adder float float float))
272 (with-test (:name :call-2-float-callback)
273 (assert (= (alien-apply *add-f-f* (iota 2.0s0)) 3.0s0)))
275 (with-test (:name :define-3-float-callback)
276 (define-callback-adder float float float float))
277 (with-test (:name :call-3-float-callback)
278 (assert (= (alien-apply *add-f-f-f* (iota 3.0s0)) 6.0s0)))
280 (with-test (:name :define-4-float-callback)
281 (define-callback-adder float float float float float))
282 (with-test (:name :call-4-float-callback)
283 (assert (= (alien-apply *add-f-f-f-f* (iota 4.0s0)) 10.0s0)))
285 (with-test (:name :define-5-float-callback)
286 (define-callback-adder float float float float float float))
287 (with-test (:name :call-5-float-callback)
288 (assert (= (alien-apply *add-f-f-f-f-f* (iota 5.0s0)) 15.0s0)))
290 (with-test (:name :define-6-float-callback)
291 (define-callback-adder float float float float float float float))
292 (with-test (:name :call-6-float-callback)
293 (assert (= (alien-apply *add-f-f-f-f-f-f* (iota 6.0s0)) 21.0s0)))
295 (with-test (:name :define-7-float-callback)
296 (define-callback-adder float float float float float float float float))
297 (with-test (:name :call-7-float-callback)
298 (assert (= (alien-apply *add-f-f-f-f-f-f-f* (iota 7.0s0)) 28.0s0)))
300 (with-test (:name :define-8-float-callback)
301 (define-callback-adder float float float float float float float float float))
302 (with-test (:name :call-8-float-callback)
303 (assert (= (alien-apply *add-f-f-f-f-f-f-f-f* (iota 8.0s0)) 36.0s0)))
305 (with-test (:name :define-9-float-callback)
306 (define-callback-adder float float float float float float float float float float))
307 (with-test (:name :call-9-float-callback)
308 (assert (= (alien-apply *add-f-f-f-f-f-f-f-f-f* (iota 9.0s0)) 45.0s0)))
310 (with-test (:name :define-10-float-callback)
311 (define-callback-adder float float float float float float float float float float float))
312 (with-test (:name :call-10-float-callback)
313 (assert (= (alien-apply *add-f-f-f-f-f-f-f-f-f-f* (iota 10.0s0)) 55.0s0)))
315 (with-test (:name :define-11-float-callback)
316 (define-callback-adder float float float float float float float float float float float float))
317 (with-test (:name :call-11-float-callback)
318 (assert (= (alien-apply *add-f-f-f-f-f-f-f-f-f-f-f* (iota 11.0s0)) 66.0s0)))
320 (with-test (:name :define-12-float-callback)
321 (define-callback-adder float float float float float float float float float float float float float))
322 (with-test (:name :call-12-float-callback)
323 (assert (= (alien-apply *add-f-f-f-f-f-f-f-f-f-f-f-f* (iota 12.0s0)) 78.0s0)))
325 (with-test (:name :define-2-double-callback)
326 (define-callback-adder double double double))
327 (with-test (:name :call-2-double-callback)
328 (assert (= (alien-apply *add-d-d* (iota 2.0d0)) 3.0d0)))
330 (with-test (:name :define-3-double-callback)
331 (define-callback-adder double double double double))
332 (with-test (:name :call-3-double-callback)
333 (assert (= (alien-apply *add-d-d-d* (iota 3.0d0)) 6.0d0)))
335 (with-test (:name :define-4-double-callback)
336 (define-callback-adder double double double double double))
337 (with-test (:name :call-4-double-callback)
338 (assert (= (alien-apply *add-d-d-d-d* (iota 4.0d0)) 10.0d0)))
340 (with-test (:name :define-5-double-callback)
341 (define-callback-adder double double double double double double))
342 (with-test (:name :call-5-double-callback)
343 (assert (= (alien-apply *add-d-d-d-d-d* (iota 5.0d0)) 15.0d0)))
345 (with-test (:name :define-6-double-callback)
346 (define-callback-adder double double double double double double double))
347 (with-test (:name :call-6-double-callback)
348 (assert (= (alien-apply *add-d-d-d-d-d-d* (iota 6.0d0)) 21.0d0)))
350 (with-test (:name :define-7-double-callback)
351 (define-callback-adder double double double double double double double double))
352 (with-test (:name :call-7-double-callback)
353 (assert (= (alien-apply *add-d-d-d-d-d-d-d* (iota 7.0d0)) 28.0d0)))
355 (with-test (:name :define-8-double-callback)
356 (define-callback-adder double double double double double double double double double))
357 (with-test (:name :call-8-double-callback)
358 (assert (= (alien-apply *add-d-d-d-d-d-d-d-d* (iota 8.0d0)) 36.0d0)))
360 (with-test (:name :define-9-double-callback)
361 (define-callback-adder double double double double double double double double double double))
362 (with-test (:name :call-9-double-callback)
363 (assert (= (alien-apply *add-d-d-d-d-d-d-d-d-d* (iota 9.0d0)) 45.0d0)))
365 (with-test (:name :define-10-double-callback)
366 (define-callback-adder double double double double double double double double double double double))
367 (with-test (:name :call-10-double-callback)
368 (assert (= (alien-apply *add-d-d-d-d-d-d-d-d-d-d* (iota 10.0d0)) 55.0d0)))
370 (with-test (:name :define-11-double-callback)
371 (define-callback-adder double double double double double double double double double double double double))
372 (with-test (:name :call-11-double-callback)
373 (assert (= (alien-apply *add-d-d-d-d-d-d-d-d-d-d-d* (iota 11.0d0)) 66.0d0)))
375 (with-test (:name :define-12-double-callback)
376 (define-callback-adder double double double double double double double double double double double double double))
377 (with-test (:name :call-12-double-callback)
378 (assert (= (alien-apply *add-d-d-d-d-d-d-d-d-d-d-d-d* (iota 12.0d0)) 78.0d0)))
380 (with-test (:name :define-int-float-callback)
381 (define-callback-adder float int float))
382 (with-test (:name :call-int-float-callback)
383 (assert (= (alien-funcall *add-i-f* 1 2.0s0) 3.0s0)))
385 (with-test (:name :define-float-int-callback)
386 (define-callback-adder float float int))
387 (with-test (:name :call-float-int-callback)
388 (assert (= (alien-funcall *add-f-i* 2.0s0 1) 3.0s0)))
390 (with-test (:name :define-int-double-callback)
391 (define-callback-adder double int double))
392 (with-test (:name :call-int-double-callback)
393 (assert (= (alien-funcall *add-i-d* 1 2.0d0) 3.0d0)))
395 (with-test (:name :define-double-int-callback)
396 (define-callback-adder double double int))
397 (with-test (:name :call-double-int-callback)
398 (assert (= (alien-funcall *add-d-i* 2.0d0 1) 3.0d0)))
400 (with-test (:name :define-double-float-callback)
401 (define-callback-adder double double float))
402 (with-test (:name :call-double-float-callback)
403 (assert (= (alien-funcall *add-d-f* 2.0d0 1.0s0) 3.0d0)))
405 (with-test (:name :define-float-double-callback)
406 (define-callback-adder double float double))
407 (with-test (:name :call-double-float-callback)
408 (assert (= (alien-funcall *add-f-d* 1.0s0 2.0d0) 3.0d0)))
410 (with-test (:name :define-double-float-int-callback)
411 (define-callback-adder double double float int))
412 (with-test (:name :call-double-float-int-callback)
413 (assert (= (alien-funcall *add-d-f-i* 2.0d0 1.0s0 1) 4.0d0)))