tests/callback.impure.lisp

   1 ;;;; callback tests with side effects
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (in-package :cl-user)
  15
  16 ;;; callbacks only on a few platforms
  17 #-alien-callbacks
  18 (exit :code 104)
  19
  20 ;;; simple callback for a function
  21
  22 (defun thunk ()
  23   (write-string "hi"))
  24
  25 (defvar *thunk*
  26   (sb-alien::alien-callback (function c-string) #'thunk))
  27
  28 (with-test (:name (:callback :c-string)
  29             ;; The whole file is broken, report one test
  30             ;; and skip the rest.
  31             :broken-on :interpreter)
  32   (assert (equal (with-output-to-string (*standard-output*)
  33                    (alien-funcall *thunk*))
  34                  "hi")))
  35
  36 ;; WITH-ALIEN is broken when interpreted, e.g.
  37 ;; (with-alien ((x int 10)) x), see lp#992362, lp#1731556
  38 (when (eq sb-ext:*evaluator-mode* :interpret)
  39   (invoke-restart 'run-tests::skip-file))
  40
  41 ;;; simple callback for a symbol
  42
  43 (defun add-two-ints (arg1 arg2)
  44   (+ arg1 arg2))
  45
  46 (defvar *add-two-ints*
  47   (sb-alien::alien-callback (function int int int) 'add-two-ints))
  48
  49 (assert (= (alien-funcall *add-two-ints* 555 444444) 444999))
  50
  51 ;;; actually using a callback with foreign code
  52
  53 #+win32 (sb-alien:load-shared-object "ntdll.dll")
  54
  55 (define-alien-routine qsort void
  56   (base (* t))
  57   (nmemb int)
  58   (size int)
  59   (compar (function int (* double) (* double))))
  60
  61 (sb-alien::define-alien-callback double*-cmp int ((arg1 (* double)) (arg2 (* double)))
  62   (let ((a1 (deref arg1))
  63         (a2 (deref arg2)))
  64     (cond ((= a1 a2) 0)
  65           ((< a1 a2) -1)
  66           (t 1))))
  67
  68 (let* ((vector (coerce '(0.1d0 0.5d0 0.2d0 1.2d0 1.5d0 2.5d0 0.0d0 0.1d0 0.2d0 0.3d0)
  69                        '(vector double-float)))
  70        (sorted (sort (copy-seq vector) #'<)))
  71   (gc :full t)
  72   (sb-sys:with-pinned-objects (vector)
  73     (qsort (sb-sys:vector-sap vector)
  74            (length vector)
  75            (alien-size double :bytes)
  76            double*-cmp))
  77   (assert (equalp vector sorted)))
  78
  79 ;;; returning floats
  80
  81 (sb-alien::define-alien-callback redefined-fun int ()
  82     0)
  83
  84 (eval
  85  '(sb-alien::define-alien-callback redefined-fun int ()
  86    42))
  87
  88 (assert (= 42 (alien-funcall redefined-fun)))
  89
  90 (sb-alien::define-alien-callback return-single float ((x float))
  91   x)
  92
  93 (sb-alien::define-alien-callback return-double double ((x double))
  94   x)
  95
  96 (defconstant spi (coerce pi 'single-float))
  97
  98 (assert (= spi (alien-funcall return-single spi)))
  99 (assert (= pi (alien-funcall return-double pi)))
 100
 101 ;;; invalidation
 102
 103 (sb-alien::define-alien-callback to-be-invalidated int ()
 104   5)
 105
 106 (assert (= 5 (alien-funcall to-be-invalidated)))
 107
 108 (multiple-value-bind (p valid) (sb-alien::alien-callback-p to-be-invalidated)
 109   (assert p)
 110   (assert valid))
 111
 112 (sb-alien::invalidate-alien-callback to-be-invalidated)
 113
 114 (multiple-value-bind (p valid) (sb-alien::alien-callback-p to-be-invalidated)
 115   (assert p)
 116   (assert (not valid)))
 117
 118 (multiple-value-bind (res err)
 119     (ignore-errors (alien-funcall to-be-invalidated))
 120   (assert (and (not res) (typep err 'error))))
 121
 122 ;;; getting and setting the underlying function
 123
 124 (sb-alien::define-alien-callback foo int ()
 125   13)
 126
 127 (defvar *foo* #'foo)
 128
 129 (assert (eq #'foo (sb-alien::alien-callback-function foo)))
 130
 131 (defun bar ()
 132   26)
 133
 134 (setf (sb-alien::alien-callback-function foo) #'bar)
 135
 136 (assert (eq #'bar (sb-alien::alien-callback-function foo)))
 137
 138 (assert (= 26 (alien-funcall foo)))
 139
 140 ;;; callbacks with void return values
 141
 142 (with-test (:name :void-return)
 143   (sb-alien::alien-lambda void ()
 144     (values)))
 145
 146 ;;; tests for integer-width problems in callback result handling
 147
 148 (defvar *add-two-ints*
 149   (sb-alien::alien-callback (function int int int) #'+))
 150 (defvar *add-two-shorts*
 151   (sb-alien::alien-callback (function short short short) #'+))
 152
 153 ;;; The original test cases here were what are now (:int-result
 154 ;;; :sign-extension) and (:int-result :underflow-detection), the latter
 155 ;;; of which would fail on 64-bit platforms.  Upon further investigation,
 156 ;;; it turned out that the same tests with a SHORT return type instead of
 157 ;;; an INT return type would also fail on 32-bit platforms.
 158
 159 (with-test (:name (:short-result :sign-extension))
 160   (assert (= (alien-funcall *add-two-shorts* #x-8000 1) -32767)))
 161
 162 (with-test (:name (:short-result :underflow-detection))
 163   (assert-error (alien-funcall *add-two-shorts* #x-8000 -1)))
 164
 165 (with-test (:name (:int-result :sign-extension))
 166   (assert (= (alien-funcall *add-two-ints* #x-80000000 1) -2147483647)))
 167
 168 (with-test (:name (:int-result :underflow-detection))
 169   (assert-error (alien-funcall *add-two-ints* #x-80000000 -1)))
 170
 171 ;;; tests for handling 64-bit arguments - this was causing problems on
 172 ;;; ppc - CLH, 2005-12-01
 173
 174 (defvar *add-two-long-longs*
 175   (sb-alien::alien-callback
 176    (function (integer 64) (integer 64) (integer 64)) 'add-two-ints))
 177 (with-test (:name :long-long-callback-arg)
 178   (assert (= (alien-funcall *add-two-long-longs*
 179                             (ash 1 60)
 180                             (- (ash 1 59)))
 181              (ash 1 59))))
 182
 183 (defvar *add-two-unsigned-long-longs*
 184   (sb-alien::alien-callback
 185    (function (unsigned 64) (unsigned 64) (unsigned 64))
 186    'add-two-ints))
 187 (with-test (:name :unsigned-long-long-callback-arg)
 188   (assert (= (alien-funcall *add-two-unsigned-long-longs*
 189                             (ash 1 62)
 190                             (ash 1 62))
 191              (ash 1 63))))
 192
 193 ;;; test for callbacks of various arities
 194 ;;; CLH 2005-12-21
 195
 196 (defmacro alien-apply-form (f args)
 197   `(let ((a ,args))
 198      `(alien-funcall ,,f ,@a)))
 199
 200 (defmacro alien-apply (f &rest args)
 201   `(eval (alien-apply-form ,f ,@args)))
 202
 203 (defun iota (x) (if (equalp x 1) (list x) (cons x (iota (1- x)))))
 204
 205 (defparameter *type-abbreviations*
 206   '((sb-alien:char . "c")
 207     (sb-alien:unsigned-char . "uc")
 208     (sb-alien:short . "h")
 209     (sb-alien:unsigned-short . "uh")
 210     (sb-alien:int . "i")
 211     (sb-alien:unsigned-int . "ui")
 212     ((sb-alien:integer 64) . "l")
 213     ((sb-alien:unsigned 64) . "ul")
 214     (sb-alien:long-long . "ll")
 215     (sb-alien:unsigned-long-long . "ull")
 216     (sb-alien:float . "f")
 217     (sb-alien:double . "d")))
 218
 219 (defun parse-callback-arg-spec (spec)
 220   (let ((l (coerce spec 'list)))
 221     (loop for g in l by #'cddr
 222        collect (car (rassoc (string-downcase g) *type-abbreviations* :test #'equal)))))
 223
 224 (defmacro define-callback-adder (&rest types)
 225   (let ((fname (format nil "*add-~{~A~^-~}*"
 226                        (mapcar
 227                         #'(lambda (x)
 228                             (cdr (assoc x *type-abbreviations*)))
 229                         (mapcar
 230                          #'(lambda (y) (find-symbol (string-upcase y) 'sb-alien))
 231                          (cdr types))))))
 232     `(progn
 233       (defparameter ,(intern
 234                       (string-upcase fname))
 235         (sb-alien::alien-callback (function ,@types) '+)))))
 236
 237 (with-test (:name :define-2-int-callback)
 238   (define-callback-adder int int int))
 239 (with-test (:name :call-2-int-callback)
 240   (assert (= (alien-apply *add-i-i* (iota 2)) 3)))
 241
 242 (with-test (:name :define-3-int-callback)
 243   (define-callback-adder int int int int))
 244 (with-test (:name :call-3-int-callback)
 245   (assert (= (alien-apply *add-i-i-i* (iota 3)) 6)))
 246
 247 (with-test (:name :define-4-int-callback)
 248   (define-callback-adder int int int int int))
 249 (with-test (:name :call-4-int-callback)
 250   (assert (= (alien-apply *add-i-i-i-i* (iota 4)) 10)))
 251
 252 (with-test (:name :define-5-int-callback)
 253   (define-callback-adder int int int int int int))
 254 (with-test (:name :call-5-int-callback)
 255   (assert (= (alien-apply *add-i-i-i-i-i* (iota 5)) 15)))
 256
 257 (with-test (:name :define-6-int-callback)
 258   (define-callback-adder int int int int int int int))
 259 (with-test (:name :call-6-int-callback)
 260   (assert (= (alien-apply *add-i-i-i-i-i-i* (iota 6)) 21)))
 261
 262 (with-test (:name :define-7-int-callback)
 263   (define-callback-adder int int int int int int int int))
 264 (with-test (:name :call-7-int-callback)
 265   (assert (= (alien-apply *add-i-i-i-i-i-i-i* (iota 7)) 28)))
 266
 267 (with-test (:name :define-8-int-callback)
 268   (define-callback-adder int int int int int int int int int))
 269 (with-test (:name :call-8-int-callback)
 270   (assert (= (alien-apply *add-i-i-i-i-i-i-i-i* (iota 8)) 36)))
 271
 272 (with-test (:name :define-9-int-callback)
 273   (define-callback-adder int int int int int int int int int int))
 274 (with-test (:name :call-9-int-callback)
 275   (assert (= (alien-apply *add-i-i-i-i-i-i-i-i-i* (iota 9)) 45)))
 276
 277 (with-test (:name :define-10-int-callback)
 278   (define-callback-adder int int int int int int int int int int int))
 279 (with-test (:name :call-10-int-callback)
 280   (assert (= (alien-apply *add-i-i-i-i-i-i-i-i-i-i* (iota 10)) 55)))
 281
 282 (with-test (:name :define-11-int-callback)
 283   (define-callback-adder int int int int int int int int int int int int))
 284 (with-test (:name :call-11-int-callback)
 285   (assert (= (alien-apply *add-i-i-i-i-i-i-i-i-i-i-i* (iota 11)) 66)))
 286
 287 (with-test (:name :define-12-int-callback)
 288   (define-callback-adder int int int int int int int int int int int int int))
 289 (with-test (:name :call-12-int-callback)
 290   (assert (= (alien-apply *add-i-i-i-i-i-i-i-i-i-i-i-i* (iota 12)) 78)))
 291
 292 (with-test (:name :define-2-float-callback)
 293   (define-callback-adder float float float))
 294 (with-test (:name :call-2-float-callback)
 295   (assert (= (alien-apply *add-f-f* (iota 2.0s0)) 3.0s0)))
 296
 297 (with-test (:name :define-3-float-callback)
 298   (define-callback-adder float float float float))
 299 (with-test (:name :call-3-float-callback)
 300   (assert (= (alien-apply *add-f-f-f* (iota 3.0s0)) 6.0s0)))
 301
 302 (with-test (:name :define-4-float-callback)
 303   (define-callback-adder float float float float float))
 304 (with-test (:name :call-4-float-callback)
 305   (assert (= (alien-apply *add-f-f-f-f* (iota 4.0s0)) 10.0s0)))
 306
 307 (with-test (:name :define-5-float-callback)
 308   (define-callback-adder float float float float float float))
 309 (with-test (:name :call-5-float-callback)
 310   (assert (= (alien-apply *add-f-f-f-f-f* (iota 5.0s0)) 15.0s0)))
 311
 312 (with-test (:name :define-6-float-callback)
 313   (define-callback-adder float float float float float float float))
 314 (with-test (:name :call-6-float-callback)
 315   (assert (= (alien-apply *add-f-f-f-f-f-f* (iota 6.0s0)) 21.0s0)))
 316
 317 (with-test (:name :define-7-float-callback)
 318   (define-callback-adder float float float float float float float float))
 319 (with-test (:name :call-7-float-callback)
 320   (assert (= (alien-apply *add-f-f-f-f-f-f-f* (iota 7.0s0)) 28.0s0)))
 321
 322 (with-test (:name :define-8-float-callback)
 323   (define-callback-adder float float float float float float float float float))
 324 (with-test (:name :call-8-float-callback)
 325   (assert (= (alien-apply *add-f-f-f-f-f-f-f-f* (iota 8.0s0)) 36.0s0)))
 326
 327 (with-test (:name :define-9-float-callback)
 328   (define-callback-adder float float float float float float float float float float))
 329 (with-test (:name :call-9-float-callback)
 330   (assert (= (alien-apply *add-f-f-f-f-f-f-f-f-f* (iota 9.0s0)) 45.0s0)))
 331
 332 (with-test (:name :define-10-float-callback)
 333   (define-callback-adder float float float float float float float float float float float))
 334 (with-test (:name :call-10-float-callback)
 335   (assert (= (alien-apply *add-f-f-f-f-f-f-f-f-f-f* (iota 10.0s0)) 55.0s0)))
 336
 337 (with-test (:name :define-11-float-callback)
 338   (define-callback-adder float float float float float float float float float float float float))
 339 (with-test (:name :call-11-float-callback)
 340   (assert (= (alien-apply *add-f-f-f-f-f-f-f-f-f-f-f* (iota 11.0s0)) 66.0s0)))
 341
 342 (with-test (:name :define-12-float-callback)
 343   (define-callback-adder float float float float float float float float float float float float float))
 344 (with-test (:name :call-12-float-callback)
 345   (assert (= (alien-apply *add-f-f-f-f-f-f-f-f-f-f-f-f* (iota 12.0s0)) 78.0s0)))
 346
 347 (with-test (:name :define-2-double-callback)
 348   (define-callback-adder double double double))
 349 (with-test (:name :call-2-double-callback)
 350   (assert (= (alien-apply *add-d-d* (iota 2.0d0)) 3.0d0)))
 351
 352 (with-test (:name :define-3-double-callback)
 353   (define-callback-adder double double double double))
 354 (with-test (:name :call-3-double-callback)
 355   (assert (= (alien-apply *add-d-d-d* (iota 3.0d0)) 6.0d0)))
 356
 357 (with-test (:name :define-4-double-callback)
 358   (define-callback-adder double double double double double))
 359 (with-test (:name :call-4-double-callback)
 360   (assert (= (alien-apply *add-d-d-d-d* (iota 4.0d0)) 10.0d0)))
 361
 362 (with-test (:name :define-5-double-callback)
 363   (define-callback-adder double double double double double double))
 364 (with-test (:name :call-5-double-callback)
 365   (assert (= (alien-apply *add-d-d-d-d-d* (iota 5.0d0)) 15.0d0)))
 366
 367 (with-test (:name :define-6-double-callback)
 368   (define-callback-adder double double double double double double double))
 369 (with-test (:name :call-6-double-callback)
 370   (assert (= (alien-apply *add-d-d-d-d-d-d* (iota 6.0d0)) 21.0d0)))
 371
 372 (with-test (:name :define-7-double-callback)
 373   (define-callback-adder double double double double double double double double))
 374 (with-test (:name :call-7-double-callback)
 375   (assert (= (alien-apply *add-d-d-d-d-d-d-d* (iota 7.0d0)) 28.0d0)))
 376
 377 (with-test (:name :define-8-double-callback)
 378   (define-callback-adder double double double double double double double double double))
 379 (with-test (:name :call-8-double-callback)
 380   (assert (= (alien-apply *add-d-d-d-d-d-d-d-d* (iota 8.0d0)) 36.0d0)))
 381
 382 (with-test (:name :define-9-double-callback)
 383   (define-callback-adder double double double double double double double double double double))
 384 (with-test (:name :call-9-double-callback)
 385   (assert (= (alien-apply *add-d-d-d-d-d-d-d-d-d* (iota 9.0d0)) 45.0d0)))
 386
 387 (with-test (:name :define-10-double-callback)
 388   (define-callback-adder double double double double double double double double double double double))
 389 (with-test (:name :call-10-double-callback)
 390   (assert (= (alien-apply *add-d-d-d-d-d-d-d-d-d-d* (iota 10.0d0)) 55.0d0)))
 391
 392 (with-test (:name :define-11-double-callback)
 393   (define-callback-adder double double double double double double double double double double double double))
 394 (with-test (:name :call-11-double-callback)
 395   (assert (= (alien-apply *add-d-d-d-d-d-d-d-d-d-d-d* (iota 11.0d0)) 66.0d0)))
 396
 397 (with-test (:name :define-12-double-callback)
 398   (define-callback-adder double double double double double double double double double double double double double))
 399 (with-test (:name :call-12-double-callback)
 400   (assert (= (alien-apply *add-d-d-d-d-d-d-d-d-d-d-d-d* (iota 12.0d0)) 78.0d0)))
 401
 402 (with-test (:name :define-int-float-callback)
 403   (define-callback-adder float int float))
 404 (with-test (:name :call-int-float-callback)
 405   (assert (= (alien-funcall *add-i-f* 1 2.0s0) 3.0s0)))
 406
 407 (with-test (:name :define-float-int-callback)
 408   (define-callback-adder float float int))
 409 (with-test (:name :call-float-int-callback)
 410   (assert (= (alien-funcall *add-f-i* 2.0s0 1) 3.0s0)))
 411
 412 (with-test (:name :define-int-double-callback)
 413   (define-callback-adder double int double))
 414 (with-test (:name :call-int-double-callback)
 415   (assert (= (alien-funcall *add-i-d* 1 2.0d0) 3.0d0)))
 416
 417 (with-test (:name :define-double-int-callback)
 418   (define-callback-adder double double int))
 419 (with-test (:name :call-double-int-callback)
 420   (assert (= (alien-funcall *add-d-i* 2.0d0 1) 3.0d0)))
 421
 422 (with-test (:name :define-double-float-callback)
 423   (define-callback-adder double double float))
 424 (with-test (:name :call-double-float-callback)
 425   (assert (= (alien-funcall *add-d-f* 2.0d0 1.0s0) 3.0d0)))
 426
 427 (with-test (:name :define-float-double-callback)
 428   (define-callback-adder double float double))
 429 (with-test (:name :call-float-double-callback)
 430   (assert (= (alien-funcall *add-f-d* 1.0s0 2.0d0) 3.0d0)))
 431
 432 (with-test (:name :define-double-float-int-callback)
 433   (define-callback-adder double double float int))
 434 (with-test (:name :call-double-float-int-callback)
 435   (assert (= (alien-funcall *add-d-f-i* 2.0d0 1.0s0 1) 4.0d0)))
 436
 437 (with-test (:name :define-float-float-double-callback)
 438   (define-callback-adder double float float double))
 439 (with-test (:name :call-float-float-double-callback)
 440   (assert (= (alien-funcall *add-f-f-d* 2.0s0 1.0s0 3.0d0) 6.0d0)))
 441
 442 (with-test (:name :define-int-float-double-callback)
 443   (define-callback-adder double int float double))
 444 (with-test (:name :call-int-float-double-callback)
 445   (assert (= (alien-funcall *add-i-f-d* 1 1.0s0 2.0d0) 4.0d0)))
 446
 447 (with-test (:name :define-int-ulonglong-callback)
 448   (define-callback-adder unsigned-long-long int unsigned-long-long))
 449 (with-test (:name :call-int-ulonglong-callback)
 450   (assert (= (alien-funcall *add-i-ull* 1 #x200000003) #x200000004)))
 451
 452 (with-test (:name :define-int-int-int-int-int-ulonglong-callback)
 453   (define-callback-adder unsigned-long-long int int int int int unsigned-long-long))
 454 (with-test (:name :call-int-int-int-int-int-ulonglong-callback)
 455   (assert (= (alien-funcall *add-i-i-i-i-i-ull* 0 0 0 0 1 #x200000003) #x200000004)))