X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcallback.impure.lisp;h=d08bb700dff63ac34ee2b0126a2e40cd96078865;hb=b14aefb22fd710673b1a1005add3c0425713d2a0;hp=4918dd0baad9335c9bf328378033464ab076bf43;hpb=f2d8784d5142fd4a748b5eb968ec059df7aa6088;p=sbcl.git diff --git a/tests/callback.impure.lisp b/tests/callback.impure.lisp index 4918dd0..d08bb70 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) @@ -132,20 +134,29 @@ (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-ints* + (sb-alien::alien-callback (function int int int) #'+)) +(defvar *add-two-shorts* + (sb-alien::alien-callback (function short short short) #'+)) -(with-test (:name :sign-extension) - (assert (= (alien-funcall *add-two-ints* #x-80000000 1) -2147483647))) +;;; 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. -;;; 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 :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 :underflow-detection :fails-on :x86-64) +(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 @@ -237,46 +248,34 @@ (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 - :fails-on '(or :x86-64)) +(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 - :fails-on '(or :x86-64)) +(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 - :fails-on '(or :x86-64)) +(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 - :fails-on '(or :x86-64)) +(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 - :fails-on '(or :x86-64)) +(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 - :fails-on '(or :x86-64)) +(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 - :fails-on '(or :x86-64)) +(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 - :fails-on '(or :x86-64)) +(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 - :fails-on '(or :x86-64)) +(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 - :fails-on '(or :x86-64)) +(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 - :fails-on '(or :x86-64)) +(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 - :fails-on '(or :x86-64)) +(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) @@ -314,32 +313,24 @@ (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 - :fails-on '(or :x86-64)) +(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 - :fails-on '(or :x86-64)) +(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 - :fails-on '(or :x86-64)) +(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 - :fails-on '(or :x86-64)) +(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 - :fails-on '(or :x86-64)) +(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 - :fails-on '(or :x86-64)) +(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 - :fails-on '(or :x86-64)) +(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 - :fails-on '(or :x86-64)) +(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) @@ -377,32 +368,24 @@ (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 - :fails-on '(or :x86-64)) +(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 - :fails-on '(or :x86-64)) +(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 - :fails-on '(or :x86-64)) +(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 - :fails-on '(or :x86-64)) +(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 - :fails-on '(or :x86-64)) +(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 - :fails-on '(or :x86-64)) +(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 - :fails-on '(or :x86-64)) +(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 - :fails-on '(or :x86-64)) +(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)