X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcallback.impure.lisp;h=34bb23f6a6b94c3cacc16f3910a354bd8927a6d7;hb=eda073ca21407c12c30b5d27ab9dbdd5e446a4b8;hp=bda01b2bd9f2b8abad6ddc5f5136d9b64348b76f;hpb=adeddfb8570bb924b4899679912b4629008b7566;p=sbcl.git diff --git a/tests/callback.impure.lisp b/tests/callback.impure.lisp index bda01b2..34bb23f 100644 --- a/tests/callback.impure.lisp +++ b/tests/callback.impure.lisp @@ -14,7 +14,7 @@ (in-package :cl-user) ;;; callbacks only on a few platforms -#-(or (and ppc darwin) x86 x86-64) +#-alien-callbacks (quit :unix-status 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) @@ -148,109 +150,31 @@ (with-test (:name :underflow-detection :fails-on :x86-64) (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 +184,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)))