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 ppc/darwin currently
  17 #-darwin (quit :unix-status 104)
  18
  19 ;;; simple callback for a function
  20
  21 (defun thunk ()
  22   (write-string "hi"))
  23
  24 (defvar *thunk*
  25   (sb-alien::alien-callback (function c-string) #'thunk))
  26
  27 (assert (equal (with-output-to-string (*standard-output*)
  28                  (alien-funcall *thunk*))
  29                "hi"))
  30
  31 ;;; simple callback for a symbol
  32
  33 (defun add-two-ints (arg1 arg2)
  34   (+ arg1 arg2))
  35
  36 (defvar *add-two-ints*
  37   (sb-alien::alien-callback (function int int int) 'add-two-ints))
  38
  39 (assert (= (alien-funcall *add-two-ints* 555 444444) 444999))
  40
  41 ;;; actually using a callback with foreign code
  42
  43 (define-alien-routine qsort void
  44   (base (* t))
  45   (nmemb int)
  46   (size int)
  47   (compar (function int (* double) (* double))))
  48
  49 (sb-alien::define-alien-callback double*-cmp int ((arg1 (* double)) (arg2 (* double)))
  50   (let ((a1 (deref arg1))
  51         (a2 (deref arg2)))
  52     (cond ((= a1 a2) 0)
  53           ((< a1 a2) -1)
  54           (t 1))))
  55
  56 (let* ((vector (coerce '(0.1d0 0.5d0 0.2d0 1.2d0 1.5d0 2.5d0 0.0d0 0.1d0 0.2d0 0.3d0)
  57                        '(vector double-float)))
  58        (sorted (sort (copy-seq vector) #'<)))
  59   (gc :full t)
  60   (sb-sys:with-pinned-objects (vector)
  61     (qsort (sb-sys:vector-sap vector)
  62            (length vector)
  63            (alien-size double :bytes)
  64            double*-cmp))
  65   (assert (equalp vector sorted)))
  66
  67 ;;; returning floats
  68
  69 (sb-alien::define-alien-callback redefined-fun int ()
  70     0)
  71
  72 (eval
  73  '(sb-alien::define-alien-callback redefined-fun int ()
  74    42))
  75
  76 (assert (= 42 (alien-funcall redefined-fun)))
  77
  78 (sb-alien::define-alien-callback return-single float ((x float))
  79   x)
  80
  81 (sb-alien::define-alien-callback return-double double ((x double))
  82   x)
  83
  84 (defconstant spi (coerce pi 'single-float))
  85
  86 (assert (= spi (alien-funcall return-single spi)))
  87 (assert (= pi (alien-funcall return-double pi)))
  88
  89 ;;; invalidation
  90
  91 (sb-alien::define-alien-callback to-be-invalidated int ()
  92   5)
  93
  94 (assert (= 5 (alien-funcall to-be-invalidated)))
  95
  96 (multiple-value-bind (p valid) (sb-alien::alien-callback-p to-be-invalidated)
  97   (assert p)
  98   (assert valid))
  99
 100 (sb-alien::invalidate-alien-callback to-be-invalidated)
 101
 102 (multiple-value-bind (p valid) (sb-alien::alien-callback-p to-be-invalidated)
 103   (assert p)
 104   (assert (not valid)))
 105
 106 (multiple-value-bind (res err)
 107     (ignore-errors (alien-funcall to-be-invalidated))
 108   (assert (and (not res) (typep err 'error))))
 109
 110 ;;; getting and setting the underlying function
 111
 112 (sb-alien::define-alien-callback foo int ()
 113   13)
 114
 115 (defvar *foo* #'foo)
 116
 117 (assert (eq #'foo (sb-alien::alien-callback-function foo)))
 118
 119 (defun bar ()
 120   26)
 121
 122 (setf (sb-alien::alien-callback-function foo) #'bar)
 123
 124 (assert (eq #'bar (sb-alien::alien-callback-function foo)))
 125
 126 (assert (= 26 (alien-funcall foo)))
 127
 128 (quit :unix-status 104)