X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcallback.impure.lisp;h=bb62a6808ea8334ea16795216b0fab3f910adf8d;hb=a189a69454ef7635149319ae213b337f17c50d20;hp=7db8a106872c0199023e4020015927e2131b73a3;hpb=93be0089fe7b2a9e34bf1cb6da9fe6e902769f5e;p=sbcl.git diff --git a/tests/callback.impure.lisp b/tests/callback.impure.lisp index 7db8a10..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. @@ -15,7 +15,7 @@ ;;; callbacks only on a few platforms #-alien-callbacks -(quit :unix-status 104) +(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) @@ -128,129 +130,60 @@ ;;; callbacks with void return values -(with-test (:name void-return) +(with-test (:name :void-return) (sb-alien::alien-lambda void () (values))) -;;; tests for a sign extension problem in callback argument handling on x86-64 +;;; 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) #'+)) -(defvar *add-two-ints* (sb-alien::alien-callback (function int int int) #'+)) +;;; 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 :sign-extension) - (assert (= (alien-funcall *add-two-ints* #x-80000000 1) -2147483647))) +(with-test (:name (:short-result :sign-extension)) + (assert (= (alien-funcall *add-two-shorts* #x-8000 1) -32767))) -;;; On x86 This'll signal a TYPE-ERROR "The value -2147483649 is not of type -;;; (SIGNED-BYTE 32)". On x86-64 it'll wrap around to 2147483647, probably -;;; due to the sign-extension done by the (INTEGER :NATURALIZE-GEN) -;;; alien-type-method. I believe the former behaviour is the one we want. -;;; -- JES, 2005-10-16 +(with-test (:name (:short-result :underflow-detection)) + (assert (raises-error? (alien-funcall *add-two-shorts* #x-8000 -1)))) -(with-test (:name :underflow-detection :fails-on :x86-64) +(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 -(defparameter *type-abbreviations* - '((sb-alien:int . "i") - (sb-alien:float . "f") - (sb-alien:double . "d") - (sb-alien:short . "h") - (sb-alien:char . "c"))) - -(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))))) - -(macrolet ((define-callback-adder2 (return-type spec) - (let ((fname (format nil "*add-~A*" spec)) - (l (parse-callback-arg-spec spec))) - `(progn - (defparameter ,(intern (string-upcase fname)) - (sb-alien::alien-callback - (function ,return-type - ,@l) '+)))))) - (define-callback-adder2 int "i-i")) - -(macrolet ((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 - (print ,fname) - (defparameter ,(intern - (string-upcase fname)) - (sb-alien::alien-callback (function ,@types) '+)))))) - - (define-callback-adder int int int) - (define-callback-adder int int int int) - (define-callback-adder int int int int int) - (define-callback-adder int int int int int int) - (define-callback-adder int int int int int int int) - (define-callback-adder int int int int int int int int) - (define-callback-adder int int int int int int int int int) - (define-callback-adder int int int int int int int int int int) - (define-callback-adder int int int int int int int int int int int) - (define-callback-adder int int int int int int int int int int int int) - (define-callback-adder int int int int int int int int int int int int int) - - (define-callback-adder float float float) - (define-callback-adder float float float float) - (define-callback-adder float float float float float) - (define-callback-adder float float float float float float) - (define-callback-adder float float float float float float float) - (define-callback-adder float float float float float float float float) - (define-callback-adder float float float float float float float float float) - (define-callback-adder float float float float float float float float float float) - (define-callback-adder float float float float float float float float float float float) - (define-callback-adder float float float float float float float float float float float float) - (define-callback-adder float float float float float float float float float float float float float) - - (define-callback-adder double double double) - (define-callback-adder double double double double double) - (define-callback-adder double double double double double double) - (define-callback-adder double double double double double double double) - (define-callback-adder double double double double double double double double) - (define-callback-adder double double double double double double double double double) - (define-callback-adder double double double double double double double double double double) - (define-callback-adder double double double double double double double double double double double) - (define-callback-adder double double double double double double double double double double double double) - (define-callback-adder double double double double double double double double double double double double double) - - (define-callback-adder float int float) - (define-callback-adder float float int) - (define-callback-adder float float int int int) - - (define-callback-adder double double int) - (define-callback-adder double int double) - - (define-callback-adder double double float) - (define-callback-adder double float double) - - (define-callback-adder double double float int) - (define-callback-adder double int float double) - (define-callback-adder double int float double double) - - (define-callback-adder double double int int int) - (define-callback-adder double double int int int double int int int) - - (define-callback-adder double double double int int int int int int) - - (define-callback-adder double double double int int) - - (define-callback-adder double int double int double int double int double int double) - - (define-callback-adder double short double) - - (define-callback-adder double char double)) - - (defmacro alien-apply-form (f args) `(let ((a ,args)) `(alien-funcall ,,f ,@a))) @@ -260,30 +193,232 @@ (defun iota (x) (if (equalp x 1) (list x) (cons x (iota (1- x))))) -(alien-funcall *add-i-i* 1 2) -(alien-funcall *add-f-f* 1.0s0 2.0s0) -(alien-funcall *add-d-d* 2.0d0 4.0d0) - -(assert (= (alien-apply *add-i-i-i-i-i-i-i-i* (iota 8)) 36)) -(assert (= (alien-apply *add-i-i-i-i-i-i-i-i-i-i* (iota 10)) 55)) -(assert (= (alien-apply *add-i-i-i-i-i-i-i-i-i-i-i-i* (iota 12)) 78)) - -(assert (= (alien-apply *add-f-f-f-f-f-f-f-f* (iota 8s0)) 36s0)) -(assert (= (alien-apply *add-f-f-f-f-f-f-f-f-f-f* (iota 10.0s0)) 55s0)) - -(assert (= (alien-apply *add-d-d-d-d-d-d-d-d* (iota 8d0)) 36d0)) -(assert (= (alien-apply *add-d-d-d-d-d-d-d-d-d-d* (iota 10d0)) 55d0)) - -(assert (= (alien-funcall *add-i-i* 2 3) 5)) -(assert (= (alien-funcall *add-d-d* 2d0 3d0) 5d0)) -(assert (= (alien-funcall *add-i-d* 2 3d0) 5d0)) -(assert (= (alien-funcall *add-d-i* 2d0 3) 5d0)) -(assert (= (alien-funcall *add-d-f* 2d0 3s0) 5d0)) -(assert (= (alien-funcall *add-f-d* 2s0 3d0) 5d0)) - -(assert (= (alien-funcall *add-d-i-i-i-d-i-i-i* 1d0 2 3 4 5d0 6 7 8) 36d0)) +(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"))) -(assert (= (alien-apply *add-i-d-i-d-i-d-i-d-i-d* - (mapcan #'(lambda (x y) (list x y)) (iota 5) (iota 5.0d0))) - 30d0)) +(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)))