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 #-(or (and ppc darwin) x86 x86-64)
  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