-;;;; 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.
;;; callbacks only on a few platforms
#-alien-callbacks
-(quit :unix-status 104)
+(exit :code 104)
;;; simple callback for a function
;;; actually using a callback with foreign code
+#+win32 (sb-alien:load-shared-object "ntdll.dll")
+
(define-alien-routine qsort void
(base (* t))
(nmemb int)
(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
(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)
(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)
(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)