;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
-;;;;
+;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
(in-package :cl-user)
-(defun alien-callback (type fun)
- (sb-alien-internals:alien-callback type fun))
+;;; callbacks only on a few platforms
+#-(or (and ppc darwin) x86 x86-64)
+(quit :unix-status 104)
+
+;;; simple callback for a function
(defun thunk ()
(write-string "hi"))
-(defvar *thunk* (alien-callback '(function c-string) #'thunk))
+(defvar *thunk*
+ (sb-alien::alien-callback (function c-string) #'thunk))
(assert (equal (with-output-to-string (*standard-output*)
- (alien-funcall *thunk*))
- "hi"))
+ (alien-funcall *thunk*))
+ "hi"))
+
+;;; simple callback for a symbol
(defun add-two-ints (arg1 arg2)
(+ arg1 arg2))
-(defvar *add-two-ints* (alien-callback '(function int int int) 'add-two-ints))
+(defvar *add-two-ints*
+ (sb-alien::alien-callback (function int int int) 'add-two-ints))
(assert (= (alien-funcall *add-two-ints* 555 444444) 444999))
+;;; actually using a callback with foreign code
+
(define-alien-routine qsort void
(base (* t))
(nmemb int)
(sb-alien::define-alien-callback double*-cmp int ((arg1 (* double)) (arg2 (* double)))
(let ((a1 (deref arg1))
- (a2 (deref arg2)))
+ (a2 (deref arg2)))
(cond ((= a1 a2) 0)
- ((< a1 a2) -1)
- (t 1))))
+ ((< a1 a2) -1)
+ (t 1))))
(let* ((vector (coerce '(0.1d0 0.5d0 0.2d0 1.2d0 1.5d0 2.5d0 0.0d0 0.1d0 0.2d0 0.3d0)
- '(vector double-float)))
+ '(vector double-float)))
(sorted (sort (copy-seq vector) #'<)))
(gc :full t)
(sb-sys:with-pinned-objects (vector)
(qsort (sb-sys:vector-sap vector)
- (length vector)
- (alien-size double :bytes)
- double*-cmp))
+ (length vector)
+ (alien-size double :bytes)
+ double*-cmp))
(assert (equalp vector sorted)))
+;;; returning floats
(sb-alien::define-alien-callback redefined-fun int ()
0)
(assert (= spi (alien-funcall return-single spi)))
(assert (= pi (alien-funcall return-double pi)))
-(quit :unix-status 104)
+;;; invalidation
+
+(sb-alien::define-alien-callback to-be-invalidated int ()
+ 5)
+
+(assert (= 5 (alien-funcall to-be-invalidated)))
+
+(multiple-value-bind (p valid) (sb-alien::alien-callback-p to-be-invalidated)
+ (assert p)
+ (assert valid))
+
+(sb-alien::invalidate-alien-callback to-be-invalidated)
+
+(multiple-value-bind (p valid) (sb-alien::alien-callback-p to-be-invalidated)
+ (assert p)
+ (assert (not valid)))
+
+(multiple-value-bind (res err)
+ (ignore-errors (alien-funcall to-be-invalidated))
+ (assert (and (not res) (typep err 'error))))
+
+;;; getting and setting the underlying function
+
+(sb-alien::define-alien-callback foo int ()
+ 13)
+
+(defvar *foo* #'foo)
+
+(assert (eq #'foo (sb-alien::alien-callback-function foo)))
+
+(defun bar ()
+ 26)
+
+(setf (sb-alien::alien-callback-function foo) #'bar)
+
+(assert (eq #'bar (sb-alien::alien-callback-function foo)))
+
+(assert (= 26 (alien-funcall foo)))
+
+;;; callbacks with void return values
+
+(with-test (:name void-return)
+ (sb-alien::alien-lambda void ()
+ (values)))
+
+;;; tests for a sign extension problem in callback argument handling on x86-64
+
+(with-test (:name sign-extension)
+ (let ((*add-two-ints*
+ (sb-alien::alien-callback (function int int int) #'+)))
+ (assert (= (alien-funcall *add-two-ints* #x-80000000 1)
+ -2147483647))
+ (assert (= (alien-funcall *add-two-ints* #x-80000000 -1)
+ #x7fffffff))))
+