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