Clean up listify-rest-args VOP on x86-64.
[sbcl.git] / tests / callback.impure.lisp
1 ;;;; callback tests with side effects
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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
8 ;;;; from CMU CL.
9 ;;;;
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.
13
14 (in-package :cl-user)
15
16 ;;; callbacks only on a few platforms
17 #-alien-callbacks
18 (exit :code 104)
19
20 ;;; simple callback for a function
21
22 (defun thunk ()
23   (write-string "hi"))
24
25 (defvar *thunk*
26   (sb-alien::alien-callback (function c-string) #'thunk))
27
28 (assert (equal (with-output-to-string (*standard-output*)
29                  (alien-funcall *thunk*))
30                "hi"))
31
32 ;;; simple callback for a symbol
33
34 (defun add-two-ints (arg1 arg2)
35   (+ arg1 arg2))
36
37 (defvar *add-two-ints*
38   (sb-alien::alien-callback (function int int int) 'add-two-ints))
39
40 (assert (= (alien-funcall *add-two-ints* 555 444444) 444999))
41
42 ;;; actually using a callback with foreign code
43
44 #+win32 (sb-alien:load-shared-object "ntdll.dll")
45
46 (define-alien-routine qsort void
47   (base (* t))
48   (nmemb int)
49   (size int)
50   (compar (function int (* double) (* double))))
51
52 (sb-alien::define-alien-callback double*-cmp int ((arg1 (* double)) (arg2 (* double)))
53   (let ((a1 (deref arg1))
54         (a2 (deref arg2)))
55     (cond ((= a1 a2) 0)
56           ((< a1 a2) -1)
57           (t 1))))
58
59 (let* ((vector (coerce '(0.1d0 0.5d0 0.2d0 1.2d0 1.5d0 2.5d0 0.0d0 0.1d0 0.2d0 0.3d0)
60                        '(vector double-float)))
61        (sorted (sort (copy-seq vector) #'<)))
62   (gc :full t)
63   (sb-sys:with-pinned-objects (vector)
64     (qsort (sb-sys:vector-sap vector)
65            (length vector)
66            (alien-size double :bytes)
67            double*-cmp))
68   (assert (equalp vector sorted)))
69
70 ;;; returning floats
71
72 (sb-alien::define-alien-callback redefined-fun int ()
73     0)
74
75 (eval
76  '(sb-alien::define-alien-callback redefined-fun int ()
77    42))
78
79 (assert (= 42 (alien-funcall redefined-fun)))
80
81 (sb-alien::define-alien-callback return-single float ((x float))
82   x)
83
84 (sb-alien::define-alien-callback return-double double ((x double))
85   x)
86
87 (defconstant spi (coerce pi 'single-float))
88
89 (assert (= spi (alien-funcall return-single spi)))
90 (assert (= pi (alien-funcall return-double pi)))
91
92 ;;; invalidation
93
94 (sb-alien::define-alien-callback to-be-invalidated int ()
95   5)
96
97 (assert (= 5 (alien-funcall to-be-invalidated)))
98
99 (multiple-value-bind (p valid) (sb-alien::alien-callback-p to-be-invalidated)
100   (assert p)
101   (assert valid))
102
103 (sb-alien::invalidate-alien-callback to-be-invalidated)
104
105 (multiple-value-bind (p valid) (sb-alien::alien-callback-p to-be-invalidated)
106   (assert p)
107   (assert (not valid)))
108
109 (multiple-value-bind (res err)
110     (ignore-errors (alien-funcall to-be-invalidated))
111   (assert (and (not res) (typep err 'error))))
112
113 ;;; getting and setting the underlying function
114
115 (sb-alien::define-alien-callback foo int ()
116   13)
117
118 (defvar *foo* #'foo)
119
120 (assert (eq #'foo (sb-alien::alien-callback-function foo)))
121
122 (defun bar ()
123   26)
124
125 (setf (sb-alien::alien-callback-function foo) #'bar)
126
127 (assert (eq #'bar (sb-alien::alien-callback-function foo)))
128
129 (assert (= 26 (alien-funcall foo)))
130
131 ;;; callbacks with void return values
132
133 (with-test (:name void-return)
134   (sb-alien::alien-lambda void ()
135     (values)))
136
137 ;;; tests for integer-width problems in callback result handling
138
139 (defvar *add-two-ints*
140   (sb-alien::alien-callback (function int int int) #'+))
141 (defvar *add-two-shorts*
142   (sb-alien::alien-callback (function short short short) #'+))
143
144 ;;; The original test cases here were what are now (:int-result
145 ;;; :sign-extension) and (:int-result :underflow-detection), the latter
146 ;;; of which would fail on 64-bit platforms.  Upon further investigation,
147 ;;; it turned out that the same tests with a SHORT return type instead of
148 ;;; an INT return type would also fail on 32-bit platforms.
149
150 (with-test (:name (:short-result :sign-extension))
151   (assert (= (alien-funcall *add-two-shorts* #x-8000 1) -32767)))
152
153 (with-test (:name (:short-result :underflow-detection))
154   (assert (raises-error? (alien-funcall *add-two-shorts* #x-8000 -1))))
155
156 (with-test (:name (:int-result :sign-extension))
157   (assert (= (alien-funcall *add-two-ints* #x-80000000 1) -2147483647)))
158
159 (with-test (:name (:int-result :underflow-detection))
160   (assert (raises-error? (alien-funcall *add-two-ints* #x-80000000 -1))))
161
162 ;;; tests for handling 64-bit arguments - this was causing problems on
163 ;;; ppc - CLH, 2005-12-01
164
165 (defvar *add-two-long-longs*
166   (sb-alien::alien-callback
167    (function (integer 64) (integer 64) (integer 64)) 'add-two-ints))
168 (with-test (:name :long-long-callback-arg)
169   (assert (= (alien-funcall *add-two-long-longs*
170                             (ash 1 60)
171                             (- (ash 1 59)))
172              (ash 1 59))))
173
174 (defvar *add-two-unsigned-long-longs*
175   (sb-alien::alien-callback
176    (function (unsigned 64) (unsigned 64) (unsigned 64))
177    'add-two-ints))
178 (with-test (:name :unsigned-long-long-callback-arg)
179   (assert (= (alien-funcall *add-two-unsigned-long-longs*
180                             (ash 1 62)
181                             (ash 1 62))
182              (ash 1 63))))
183
184 ;;; test for callbacks of various arities
185 ;;; CLH 2005-12-21
186
187 (defmacro alien-apply-form (f args)
188   `(let ((a ,args))
189      `(alien-funcall ,,f ,@a)))
190
191 (defmacro alien-apply (f &rest args)
192   `(eval (alien-apply-form ,f ,@args)))
193
194 (defun iota (x) (if (equalp x 1) (list x) (cons x (iota (1- x)))))
195
196 (defparameter *type-abbreviations*
197   '((sb-alien:char . "c")
198     (sb-alien:unsigned-char . "uc")
199     (sb-alien:short . "h")
200     (sb-alien:unsigned-short . "uh")
201     (sb-alien:int . "i")
202     (sb-alien:unsigned-int . "ui")
203     ((sb-alien:integer 64) . "l")
204     ((sb-alien:unsigned 64) . "ul")
205     (sb-alien:float . "f")
206     (sb-alien:double . "d")))
207
208 (defun parse-callback-arg-spec (spec)
209   (let ((l (coerce spec 'list)))
210     (loop for g in l by #'cddr
211        collect (car (rassoc (string-downcase g) *type-abbreviations* :test #'equal)))))
212
213 (defmacro define-callback-adder (&rest types)
214   (let ((fname (format nil "*add-~{~A~^-~}*"
215                        (mapcar
216                         #'(lambda (x)
217                             (cdr (assoc x *type-abbreviations*)))
218                         (mapcar
219                          #'(lambda (y) (find-symbol (string-upcase y) 'sb-alien))
220                          (cdr types))))))
221     `(progn
222       (defparameter ,(intern
223                       (string-upcase fname))
224         (sb-alien::alien-callback (function ,@types) '+)))))
225
226 (with-test (:name :define-2-int-callback)
227   (define-callback-adder int int int))
228 (with-test (:name :call-2-int-callback)
229   (assert (= (alien-apply *add-i-i* (iota 2)) 3)))
230
231 (with-test (:name :define-3-int-callback)
232   (define-callback-adder int int int int))
233 (with-test (:name :call-3-int-callback)
234   (assert (= (alien-apply *add-i-i-i* (iota 3)) 6)))
235
236 (with-test (:name :define-4-int-callback)
237   (define-callback-adder int int int int int))
238 (with-test (:name :call-4-int-callback)
239   (assert (= (alien-apply *add-i-i-i-i* (iota 4)) 10)))
240
241 (with-test (:name :define-5-int-callback)
242   (define-callback-adder int int int int int int))
243 (with-test (:name :call-5-int-callback)
244   (assert (= (alien-apply *add-i-i-i-i-i* (iota 5)) 15)))
245
246 (with-test (:name :define-6-int-callback)
247   (define-callback-adder int int int int int int int))
248 (with-test (:name :call-6-int-callback)
249   (assert (= (alien-apply *add-i-i-i-i-i-i* (iota 6)) 21)))
250
251 (with-test (:name :define-7-int-callback)
252   (define-callback-adder int int int int int int int int))
253 (with-test (:name :call-7-int-callback)
254   (assert (= (alien-apply *add-i-i-i-i-i-i-i* (iota 7)) 28)))
255
256 (with-test (:name :define-8-int-callback)
257   (define-callback-adder int int int int int int int int int))
258 (with-test (:name :call-8-int-callback)
259   (assert (= (alien-apply *add-i-i-i-i-i-i-i-i* (iota 8)) 36)))
260
261 (with-test (:name :define-9-int-callback)
262   (define-callback-adder int int int int int int int int int int))
263 (with-test (:name :call-9-int-callback)
264   (assert (= (alien-apply *add-i-i-i-i-i-i-i-i-i* (iota 9)) 45)))
265
266 (with-test (:name :define-10-int-callback)
267   (define-callback-adder int int int int int int int int int int int))
268 (with-test (:name :call-10-int-callback)
269   (assert (= (alien-apply *add-i-i-i-i-i-i-i-i-i-i* (iota 10)) 55)))
270
271 (with-test (:name :define-11-int-callback)
272   (define-callback-adder int int int int int int int int int int int int))
273 (with-test (:name :call-11-int-callback)
274   (assert (= (alien-apply *add-i-i-i-i-i-i-i-i-i-i-i* (iota 11)) 66)))
275
276 (with-test (:name :define-12-int-callback)
277   (define-callback-adder int int int int int int int int int int int int int))
278 (with-test (:name :call-12-int-callback)
279   (assert (= (alien-apply *add-i-i-i-i-i-i-i-i-i-i-i-i* (iota 12)) 78)))
280
281 (with-test (:name :define-2-float-callback)
282   (define-callback-adder float float float))
283 (with-test (:name :call-2-float-callback)
284   (assert (= (alien-apply *add-f-f* (iota 2.0s0)) 3.0s0)))
285
286 (with-test (:name :define-3-float-callback)
287   (define-callback-adder float float float float))
288 (with-test (:name :call-3-float-callback)
289   (assert (= (alien-apply *add-f-f-f* (iota 3.0s0)) 6.0s0)))
290
291 (with-test (:name :define-4-float-callback)
292   (define-callback-adder float float float float float))
293 (with-test (:name :call-4-float-callback)
294   (assert (= (alien-apply *add-f-f-f-f* (iota 4.0s0)) 10.0s0)))
295
296 (with-test (:name :define-5-float-callback)
297   (define-callback-adder float float float float float float))
298 (with-test (:name :call-5-float-callback)
299   (assert (= (alien-apply *add-f-f-f-f-f* (iota 5.0s0)) 15.0s0)))
300
301 (with-test (:name :define-6-float-callback)
302   (define-callback-adder float float float float float float float))
303 (with-test (:name :call-6-float-callback)
304   (assert (= (alien-apply *add-f-f-f-f-f-f* (iota 6.0s0)) 21.0s0)))
305
306 (with-test (:name :define-7-float-callback)
307   (define-callback-adder float float float float float float float float))
308 (with-test (:name :call-7-float-callback)
309   (assert (= (alien-apply *add-f-f-f-f-f-f-f* (iota 7.0s0)) 28.0s0)))
310
311 (with-test (:name :define-8-float-callback)
312   (define-callback-adder float float float float float float float float float))
313 (with-test (:name :call-8-float-callback)
314   (assert (= (alien-apply *add-f-f-f-f-f-f-f-f* (iota 8.0s0)) 36.0s0)))
315
316 (with-test (:name :define-9-float-callback)
317   (define-callback-adder float float float float float float float float float float))
318 (with-test (:name :call-9-float-callback)
319   (assert (= (alien-apply *add-f-f-f-f-f-f-f-f-f* (iota 9.0s0)) 45.0s0)))
320
321 (with-test (:name :define-10-float-callback)
322   (define-callback-adder float float float float float float float float float float float))
323 (with-test (:name :call-10-float-callback)
324   (assert (= (alien-apply *add-f-f-f-f-f-f-f-f-f-f* (iota 10.0s0)) 55.0s0)))
325
326 (with-test (:name :define-11-float-callback)
327   (define-callback-adder float float float float float float float float float float float float))
328 (with-test (:name :call-11-float-callback)
329   (assert (= (alien-apply *add-f-f-f-f-f-f-f-f-f-f-f* (iota 11.0s0)) 66.0s0)))
330
331 (with-test (:name :define-12-float-callback)
332   (define-callback-adder float float float float float float float float float float float float float))
333 (with-test (:name :call-12-float-callback)
334   (assert (= (alien-apply *add-f-f-f-f-f-f-f-f-f-f-f-f* (iota 12.0s0)) 78.0s0)))
335
336 (with-test (:name :define-2-double-callback)
337   (define-callback-adder double double double))
338 (with-test (:name :call-2-double-callback)
339   (assert (= (alien-apply *add-d-d* (iota 2.0d0)) 3.0d0)))
340
341 (with-test (:name :define-3-double-callback)
342   (define-callback-adder double double double double))
343 (with-test (:name :call-3-double-callback)
344   (assert (= (alien-apply *add-d-d-d* (iota 3.0d0)) 6.0d0)))
345
346 (with-test (:name :define-4-double-callback)
347   (define-callback-adder double double double double double))
348 (with-test (:name :call-4-double-callback)
349   (assert (= (alien-apply *add-d-d-d-d* (iota 4.0d0)) 10.0d0)))
350
351 (with-test (:name :define-5-double-callback)
352   (define-callback-adder double double double double double double))
353 (with-test (:name :call-5-double-callback)
354   (assert (= (alien-apply *add-d-d-d-d-d* (iota 5.0d0)) 15.0d0)))
355
356 (with-test (:name :define-6-double-callback)
357   (define-callback-adder double double double double double double double))
358 (with-test (:name :call-6-double-callback)
359   (assert (= (alien-apply *add-d-d-d-d-d-d* (iota 6.0d0)) 21.0d0)))
360
361 (with-test (:name :define-7-double-callback)
362   (define-callback-adder double double double double double double double double))
363 (with-test (:name :call-7-double-callback)
364   (assert (= (alien-apply *add-d-d-d-d-d-d-d* (iota 7.0d0)) 28.0d0)))
365
366 (with-test (:name :define-8-double-callback)
367   (define-callback-adder double double double double double double double double double))
368 (with-test (:name :call-8-double-callback)
369   (assert (= (alien-apply *add-d-d-d-d-d-d-d-d* (iota 8.0d0)) 36.0d0)))
370
371 (with-test (:name :define-9-double-callback)
372   (define-callback-adder double double double double double double double double double double))
373 (with-test (:name :call-9-double-callback)
374   (assert (= (alien-apply *add-d-d-d-d-d-d-d-d-d* (iota 9.0d0)) 45.0d0)))
375
376 (with-test (:name :define-10-double-callback)
377   (define-callback-adder double double double double double double double double double double double))
378 (with-test (:name :call-10-double-callback)
379   (assert (= (alien-apply *add-d-d-d-d-d-d-d-d-d-d* (iota 10.0d0)) 55.0d0)))
380
381 (with-test (:name :define-11-double-callback)
382   (define-callback-adder double double double double double double double double double double double double))
383 (with-test (:name :call-11-double-callback)
384   (assert (= (alien-apply *add-d-d-d-d-d-d-d-d-d-d-d* (iota 11.0d0)) 66.0d0)))
385
386 (with-test (:name :define-12-double-callback)
387   (define-callback-adder double double double double double double double double double double double double double))
388 (with-test (:name :call-12-double-callback)
389   (assert (= (alien-apply *add-d-d-d-d-d-d-d-d-d-d-d-d* (iota 12.0d0)) 78.0d0)))
390
391 (with-test (:name :define-int-float-callback)
392   (define-callback-adder float int float))
393 (with-test (:name :call-int-float-callback)
394   (assert (= (alien-funcall *add-i-f* 1 2.0s0) 3.0s0)))
395
396 (with-test (:name :define-float-int-callback)
397   (define-callback-adder float float int))
398 (with-test (:name :call-float-int-callback)
399   (assert (= (alien-funcall *add-f-i* 2.0s0 1) 3.0s0)))
400
401 (with-test (:name :define-int-double-callback)
402   (define-callback-adder double int double))
403 (with-test (:name :call-int-double-callback)
404   (assert (= (alien-funcall *add-i-d* 1 2.0d0) 3.0d0)))
405
406 (with-test (:name :define-double-int-callback)
407   (define-callback-adder double double int))
408 (with-test (:name :call-double-int-callback)
409   (assert (= (alien-funcall *add-d-i* 2.0d0 1) 3.0d0)))
410
411 (with-test (:name :define-double-float-callback)
412   (define-callback-adder double double float))
413 (with-test (:name :call-double-float-callback)
414   (assert (= (alien-funcall *add-d-f* 2.0d0 1.0s0) 3.0d0)))
415
416 (with-test (:name :define-float-double-callback)
417   (define-callback-adder double float double))
418 (with-test (:name :call-double-float-callback)
419   (assert (= (alien-funcall *add-f-d* 1.0s0 2.0d0) 3.0d0)))
420
421 (with-test (:name :define-double-float-int-callback)
422   (define-callback-adder double double float int))
423 (with-test (:name :call-double-float-int-callback)
424   (assert (= (alien-funcall *add-d-f-i* 2.0d0 1.0s0 1) 4.0d0)))