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))))
152 ;;; test for callbacks of various arities
155 (defparameter *type-abbreviations*
156 '((sb-alien:int . "i")
157 (sb-alien:float . "f")
158 (sb-alien:double . "d")
159 (sb-alien:short . "h")
160 (sb-alien:char . "c")))
162 (defun parse-callback-arg-spec (spec)
163 (let ((l (coerce spec 'list)))
164 (loop for g in l by #'cddr
165 collect (car (rassoc (string-downcase g) *type-abbreviations* :test #'equal)))))
167 (macrolet ((define-callback-adder2 (return-type spec)
168 (let ((fname (format nil "*add-~A*" spec))
169 (l (parse-callback-arg-spec spec)))
171 (defparameter ,(intern (string-upcase fname))
172 (sb-alien::alien-callback
173 (function ,return-type
175 (define-callback-adder2 int "i-i"))
177 (macrolet ((define-callback-adder (&rest types)
178 (let ((fname (format nil "*add-~{~A~^-~}*"
181 (cdr (assoc x *type-abbreviations*)))
183 #'(lambda (y) (find-symbol (string-upcase y) 'sb-alien))
187 (defparameter ,(intern
188 (string-upcase fname))
189 (sb-alien::alien-callback (function ,@types) '+))))))
191 (define-callback-adder int int int)
192 (define-callback-adder int int int int)
193 (define-callback-adder int int int int int)
194 (define-callback-adder int int int int int int)
195 (define-callback-adder int int int int int int int)
196 (define-callback-adder int int int int int int int int)
197 (define-callback-adder int int int int int int int int int)
198 (define-callback-adder int int int int int int int int int int)
199 (define-callback-adder int int int int int int int int int int int)
200 (define-callback-adder int int int int int int int int int int int int)
201 (define-callback-adder int int int int int int int int int int int int int)
203 (define-callback-adder float float float)
204 (define-callback-adder float float float float)
205 (define-callback-adder float float float float float)
206 (define-callback-adder float float float float float float)
207 (define-callback-adder float float float float float float float)
208 (define-callback-adder float float float float float float float float)
209 (define-callback-adder float float float float float float float float float)
210 (define-callback-adder float float float float float float float float float float)
211 (define-callback-adder float float float float float float float float float float float)
212 (define-callback-adder float float float float float float float float float float float float)
213 (define-callback-adder float float float float float float float float float float float float float)
215 (define-callback-adder double double double)
216 (define-callback-adder double double double double double)
217 (define-callback-adder double double double double double double)
218 (define-callback-adder double double double double double double double)
219 (define-callback-adder double double double double double double double double)
220 (define-callback-adder double double double double double double double double double)
221 (define-callback-adder double double double double double double double double double double)
222 (define-callback-adder double double double double double double double double double double double)
223 (define-callback-adder double double double double double double double double double double double double)
224 (define-callback-adder double double double double double double double double double double double double double)
226 (define-callback-adder float int float)
227 (define-callback-adder float float int)
228 (define-callback-adder float float int int int)
230 (define-callback-adder double double int)
231 (define-callback-adder double int double)
233 (define-callback-adder double double float)
234 (define-callback-adder double float double)
236 (define-callback-adder double double float int)
237 (define-callback-adder double int float double)
238 (define-callback-adder double int float double double)
240 (define-callback-adder double double int int int)
241 (define-callback-adder double double int int int double int int int)
243 (define-callback-adder double double double int int int int int int)
245 (define-callback-adder double double double int int)
247 (define-callback-adder double int double int double int double int double int double)
249 (define-callback-adder double short double)
251 (define-callback-adder double char double))
254 (defmacro alien-apply-form (f args)
256 `(alien-funcall ,,f ,@a)))
258 (defmacro alien-apply (f &rest args)
259 `(eval (alien-apply-form ,f ,@args)))
261 (defun iota (x) (if (equalp x 1) (list x) (cons x (iota (1- x)))))
263 (alien-funcall *add-i-i* 1 2)
264 (alien-funcall *add-f-f* 1.0s0 2.0s0)
265 (alien-funcall *add-d-d* 2.0d0 4.0d0)
267 (assert (= (alien-apply *add-i-i-i-i-i-i-i-i* (iota 8)) 36))
268 (assert (= (alien-apply *add-i-i-i-i-i-i-i-i-i-i* (iota 10)) 55))
269 (assert (= (alien-apply *add-i-i-i-i-i-i-i-i-i-i-i-i* (iota 12)) 78))
271 (assert (= (alien-apply *add-f-f-f-f-f-f-f-f* (iota 8s0)) 36s0))
272 (assert (= (alien-apply *add-f-f-f-f-f-f-f-f-f-f* (iota 10.0s0)) 55s0))
274 (assert (= (alien-apply *add-d-d-d-d-d-d-d-d* (iota 8d0)) 36d0))
275 (assert (= (alien-apply *add-d-d-d-d-d-d-d-d-d-d* (iota 10d0)) 55d0))
277 (assert (= (alien-funcall *add-i-i* 2 3) 5))
278 (assert (= (alien-funcall *add-d-d* 2d0 3d0) 5d0))
279 (assert (= (alien-funcall *add-i-d* 2 3d0) 5d0))
280 (assert (= (alien-funcall *add-d-i* 2d0 3) 5d0))
281 (assert (= (alien-funcall *add-d-f* 2d0 3s0) 5d0))
282 (assert (= (alien-funcall *add-f-d* 2s0 3d0) 5d0))
284 (assert (= (alien-funcall *add-d-i-i-i-d-i-i-i* 1d0 2 3 4 5d0 6 7 8) 36d0))
286 (assert (= (alien-apply *add-i-d-i-d-i-d-i-d-i-d*
287 (mapcan #'(lambda (x y) (list x y)) (iota 5) (iota 5.0d0)))