tests/callback.impure.lisp

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