X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcallback.impure.lisp;h=bb62a6808ea8334ea16795216b0fab3f910adf8d;hb=31f68584d0732dc0d17f379773e5f87f1e5a78ad;hp=d2440b4e4675dbba2c5475031859be8bd2861c9e;hpb=b4a85c101536166d4b6521d3a28d5cef5937dc6b;p=sbcl.git diff --git a/tests/callback.impure.lisp b/tests/callback.impure.lisp index d2440b4..bb62a68 100644 --- a/tests/callback.impure.lisp +++ b/tests/callback.impure.lisp @@ -1,4 +1,4 @@ -;;;; package lock tests with side effects +;;;; callback tests with side effects ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -14,8 +14,8 @@ (in-package :cl-user) ;;; callbacks only on a few platforms -#-(or (and ppc darwin) x86 x86-64) -(quit :unix-status 104) +#-alien-callbacks +(exit :code 104) ;;; simple callback for a function @@ -41,6 +41,8 @@ ;;; actually using a callback with foreign code +#+win32 (sb-alien:load-shared-object "ntdll.dll") + (define-alien-routine qsort void (base (* t)) (nmemb int) @@ -126,3 +128,297 @@ (assert (= 26 (alien-funcall foo))) +;;; callbacks with void return values + +(with-test (:name :void-return) + (sb-alien::alien-lambda void () + (values))) + +;;; tests for integer-width problems in callback result handling + +(defvar *add-two-ints* + (sb-alien::alien-callback (function int int int) #'+)) +(defvar *add-two-shorts* + (sb-alien::alien-callback (function short short short) #'+)) + +;;; The original test cases here were what are now (:int-result +;;; :sign-extension) and (:int-result :underflow-detection), the latter +;;; of which would fail on 64-bit platforms. Upon further investigation, +;;; it turned out that the same tests with a SHORT return type instead of +;;; an INT return type would also fail on 32-bit platforms. + +(with-test (:name (:short-result :sign-extension)) + (assert (= (alien-funcall *add-two-shorts* #x-8000 1) -32767))) + +(with-test (:name (:short-result :underflow-detection)) + (assert (raises-error? (alien-funcall *add-two-shorts* #x-8000 -1)))) + +(with-test (:name (:int-result :sign-extension)) + (assert (= (alien-funcall *add-two-ints* #x-80000000 1) -2147483647))) + +(with-test (:name (:int-result :underflow-detection)) + (assert (raises-error? (alien-funcall *add-two-ints* #x-80000000 -1)))) + +;;; tests for handling 64-bit arguments - this was causing problems on +;;; ppc - CLH, 2005-12-01 + +(defvar *add-two-long-longs* + (sb-alien::alien-callback + (function (integer 64) (integer 64) (integer 64)) 'add-two-ints)) +(with-test (:name :long-long-callback-arg) + (assert (= (alien-funcall *add-two-long-longs* + (ash 1 60) + (- (ash 1 59))) + (ash 1 59)))) + +(defvar *add-two-unsigned-long-longs* + (sb-alien::alien-callback + (function (unsigned 64) (unsigned 64) (unsigned 64)) + 'add-two-ints)) +(with-test (:name :unsigned-long-long-callback-arg) + (assert (= (alien-funcall *add-two-unsigned-long-longs* + (ash 1 62) + (ash 1 62)) + (ash 1 63)))) + +;;; test for callbacks of various arities +;;; CLH 2005-12-21 + +(defmacro alien-apply-form (f args) + `(let ((a ,args)) + `(alien-funcall ,,f ,@a))) + +(defmacro alien-apply (f &rest args) + `(eval (alien-apply-form ,f ,@args))) + +(defun iota (x) (if (equalp x 1) (list x) (cons x (iota (1- x))))) + +(defparameter *type-abbreviations* + '((sb-alien:char . "c") + (sb-alien:unsigned-char . "uc") + (sb-alien:short . "h") + (sb-alien:unsigned-short . "uh") + (sb-alien:int . "i") + (sb-alien:unsigned-int . "ui") + ((sb-alien:integer 64) . "l") + ((sb-alien:unsigned 64) . "ul") + (sb-alien:float . "f") + (sb-alien:double . "d"))) + +(defun parse-callback-arg-spec (spec) + (let ((l (coerce spec 'list))) + (loop for g in l by #'cddr + collect (car (rassoc (string-downcase g) *type-abbreviations* :test #'equal))))) + +(defmacro define-callback-adder (&rest types) + (let ((fname (format nil "*add-~{~A~^-~}*" + (mapcar + #'(lambda (x) + (cdr (assoc x *type-abbreviations*))) + (mapcar + #'(lambda (y) (find-symbol (string-upcase y) 'sb-alien)) + (cdr types)))))) + `(progn + (defparameter ,(intern + (string-upcase fname)) + (sb-alien::alien-callback (function ,@types) '+))))) + +(with-test (:name :define-2-int-callback) + (define-callback-adder int int int)) +(with-test (:name :call-2-int-callback) + (assert (= (alien-apply *add-i-i* (iota 2)) 3))) + +(with-test (:name :define-3-int-callback) + (define-callback-adder int int int int)) +(with-test (:name :call-3-int-callback) + (assert (= (alien-apply *add-i-i-i* (iota 3)) 6))) + +(with-test (:name :define-4-int-callback) + (define-callback-adder int int int int int)) +(with-test (:name :call-4-int-callback) + (assert (= (alien-apply *add-i-i-i-i* (iota 4)) 10))) + +(with-test (:name :define-5-int-callback) + (define-callback-adder int int int int int int)) +(with-test (:name :call-5-int-callback) + (assert (= (alien-apply *add-i-i-i-i-i* (iota 5)) 15))) + +(with-test (:name :define-6-int-callback) + (define-callback-adder int int int int int int int)) +(with-test (:name :call-6-int-callback) + (assert (= (alien-apply *add-i-i-i-i-i-i* (iota 6)) 21))) + +(with-test (:name :define-7-int-callback) + (define-callback-adder int int int int int int int int)) +(with-test (:name :call-7-int-callback) + (assert (= (alien-apply *add-i-i-i-i-i-i-i* (iota 7)) 28))) + +(with-test (:name :define-8-int-callback) + (define-callback-adder int int int int int int int int int)) +(with-test (:name :call-8-int-callback) + (assert (= (alien-apply *add-i-i-i-i-i-i-i-i* (iota 8)) 36))) + +(with-test (:name :define-9-int-callback) + (define-callback-adder int int int int int int int int int int)) +(with-test (:name :call-9-int-callback) + (assert (= (alien-apply *add-i-i-i-i-i-i-i-i-i* (iota 9)) 45))) + +(with-test (:name :define-10-int-callback) + (define-callback-adder int int int int int int int int int int int)) +(with-test (:name :call-10-int-callback) + (assert (= (alien-apply *add-i-i-i-i-i-i-i-i-i-i* (iota 10)) 55))) + +(with-test (:name :define-11-int-callback) + (define-callback-adder int int int int int int int int int int int int)) +(with-test (:name :call-11-int-callback) + (assert (= (alien-apply *add-i-i-i-i-i-i-i-i-i-i-i* (iota 11)) 66))) + +(with-test (:name :define-12-int-callback) + (define-callback-adder int int int int int int int int int int int int int)) +(with-test (:name :call-12-int-callback) + (assert (= (alien-apply *add-i-i-i-i-i-i-i-i-i-i-i-i* (iota 12)) 78))) + +(with-test (:name :define-2-float-callback) + (define-callback-adder float float float)) +(with-test (:name :call-2-float-callback) + (assert (= (alien-apply *add-f-f* (iota 2.0s0)) 3.0s0))) + +(with-test (:name :define-3-float-callback) + (define-callback-adder float float float float)) +(with-test (:name :call-3-float-callback) + (assert (= (alien-apply *add-f-f-f* (iota 3.0s0)) 6.0s0))) + +(with-test (:name :define-4-float-callback) + (define-callback-adder float float float float float)) +(with-test (:name :call-4-float-callback) + (assert (= (alien-apply *add-f-f-f-f* (iota 4.0s0)) 10.0s0))) + +(with-test (:name :define-5-float-callback) + (define-callback-adder float float float float float float)) +(with-test (:name :call-5-float-callback) + (assert (= (alien-apply *add-f-f-f-f-f* (iota 5.0s0)) 15.0s0))) + +(with-test (:name :define-6-float-callback) + (define-callback-adder float float float float float float float)) +(with-test (:name :call-6-float-callback) + (assert (= (alien-apply *add-f-f-f-f-f-f* (iota 6.0s0)) 21.0s0))) + +(with-test (:name :define-7-float-callback) + (define-callback-adder float float float float float float float float)) +(with-test (:name :call-7-float-callback) + (assert (= (alien-apply *add-f-f-f-f-f-f-f* (iota 7.0s0)) 28.0s0))) + +(with-test (:name :define-8-float-callback) + (define-callback-adder float float float float float float float float float)) +(with-test (:name :call-8-float-callback) + (assert (= (alien-apply *add-f-f-f-f-f-f-f-f* (iota 8.0s0)) 36.0s0))) + +(with-test (:name :define-9-float-callback) + (define-callback-adder float float float float float float float float float float)) +(with-test (:name :call-9-float-callback) + (assert (= (alien-apply *add-f-f-f-f-f-f-f-f-f* (iota 9.0s0)) 45.0s0))) + +(with-test (:name :define-10-float-callback) + (define-callback-adder float float float float float float float float float float float)) +(with-test (:name :call-10-float-callback) + (assert (= (alien-apply *add-f-f-f-f-f-f-f-f-f-f* (iota 10.0s0)) 55.0s0))) + +(with-test (:name :define-11-float-callback) + (define-callback-adder float float float float float float float float float float float float)) +(with-test (:name :call-11-float-callback) + (assert (= (alien-apply *add-f-f-f-f-f-f-f-f-f-f-f* (iota 11.0s0)) 66.0s0))) + +(with-test (:name :define-12-float-callback) + (define-callback-adder float float float float float float float float float float float float float)) +(with-test (:name :call-12-float-callback) + (assert (= (alien-apply *add-f-f-f-f-f-f-f-f-f-f-f-f* (iota 12.0s0)) 78.0s0))) + +(with-test (:name :define-2-double-callback) + (define-callback-adder double double double)) +(with-test (:name :call-2-double-callback) + (assert (= (alien-apply *add-d-d* (iota 2.0d0)) 3.0d0))) + +(with-test (:name :define-3-double-callback) + (define-callback-adder double double double double)) +(with-test (:name :call-3-double-callback) + (assert (= (alien-apply *add-d-d-d* (iota 3.0d0)) 6.0d0))) + +(with-test (:name :define-4-double-callback) + (define-callback-adder double double double double double)) +(with-test (:name :call-4-double-callback) + (assert (= (alien-apply *add-d-d-d-d* (iota 4.0d0)) 10.0d0))) + +(with-test (:name :define-5-double-callback) + (define-callback-adder double double double double double double)) +(with-test (:name :call-5-double-callback) + (assert (= (alien-apply *add-d-d-d-d-d* (iota 5.0d0)) 15.0d0))) + +(with-test (:name :define-6-double-callback) + (define-callback-adder double double double double double double double)) +(with-test (:name :call-6-double-callback) + (assert (= (alien-apply *add-d-d-d-d-d-d* (iota 6.0d0)) 21.0d0))) + +(with-test (:name :define-7-double-callback) + (define-callback-adder double double double double double double double double)) +(with-test (:name :call-7-double-callback) + (assert (= (alien-apply *add-d-d-d-d-d-d-d* (iota 7.0d0)) 28.0d0))) + +(with-test (:name :define-8-double-callback) + (define-callback-adder double double double double double double double double double)) +(with-test (:name :call-8-double-callback) + (assert (= (alien-apply *add-d-d-d-d-d-d-d-d* (iota 8.0d0)) 36.0d0))) + +(with-test (:name :define-9-double-callback) + (define-callback-adder double double double double double double double double double double)) +(with-test (:name :call-9-double-callback) + (assert (= (alien-apply *add-d-d-d-d-d-d-d-d-d* (iota 9.0d0)) 45.0d0))) + +(with-test (:name :define-10-double-callback) + (define-callback-adder double double double double double double double double double double double)) +(with-test (:name :call-10-double-callback) + (assert (= (alien-apply *add-d-d-d-d-d-d-d-d-d-d* (iota 10.0d0)) 55.0d0))) + +(with-test (:name :define-11-double-callback) + (define-callback-adder double double double double double double double double double double double double)) +(with-test (:name :call-11-double-callback) + (assert (= (alien-apply *add-d-d-d-d-d-d-d-d-d-d-d* (iota 11.0d0)) 66.0d0))) + +(with-test (:name :define-12-double-callback) + (define-callback-adder double double double double double double double double double double double double double)) +(with-test (:name :call-12-double-callback) + (assert (= (alien-apply *add-d-d-d-d-d-d-d-d-d-d-d-d* (iota 12.0d0)) 78.0d0))) + +(with-test (:name :define-int-float-callback) + (define-callback-adder float int float)) +(with-test (:name :call-int-float-callback) + (assert (= (alien-funcall *add-i-f* 1 2.0s0) 3.0s0))) + +(with-test (:name :define-float-int-callback) + (define-callback-adder float float int)) +(with-test (:name :call-float-int-callback) + (assert (= (alien-funcall *add-f-i* 2.0s0 1) 3.0s0))) + +(with-test (:name :define-int-double-callback) + (define-callback-adder double int double)) +(with-test (:name :call-int-double-callback) + (assert (= (alien-funcall *add-i-d* 1 2.0d0) 3.0d0))) + +(with-test (:name :define-double-int-callback) + (define-callback-adder double double int)) +(with-test (:name :call-double-int-callback) + (assert (= (alien-funcall *add-d-i* 2.0d0 1) 3.0d0))) + +(with-test (:name :define-double-float-callback) + (define-callback-adder double double float)) +(with-test (:name :call-double-float-callback) + (assert (= (alien-funcall *add-d-f* 2.0d0 1.0s0) 3.0d0))) + +(with-test (:name :define-float-double-callback) + (define-callback-adder double float double)) +(with-test (:name :call-double-float-callback) + (assert (= (alien-funcall *add-f-d* 1.0s0 2.0d0) 3.0d0))) + +(with-test (:name :define-double-float-int-callback) + (define-callback-adder double double float int)) +(with-test (:name :call-double-float-int-callback) + (assert (= (alien-funcall *add-d-f-i* 2.0d0 1.0s0 1) 4.0d0)))