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
17 #-
(or (and ppc darwin
) x86 x86-64
)
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))))