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 (defun alien-callback (type fun)
  17   (sb-alien-internals:alien-callback type fun))
  18
  19 (defun thunk ()
  20   (write-string "hi"))
  21
  22 (defvar *thunk* (alien-callback '(function c-string) #'thunk))
  23
  24 (assert (equal (with-output-to-string (*standard-output*)
  25                  (alien-funcall *thunk*))
  26                "hi"))
  27
  28 (defun add-two-ints (arg1 arg2)
  29   (+ arg1 arg2))
  30
  31 (defvar *add-two-ints* (alien-callback '(function int int int) 'add-two-ints))
  32
  33 (assert (= (alien-funcall *add-two-ints* 555 444444) 444999))
  34
  35 (define-alien-routine qsort void
  36   (base (* t))
  37   (nmemb int)
  38   (size int)
  39   (compar (function int (* double) (* double))))
  40
  41 (sb-alien::define-alien-callback double*-cmp int ((arg1 (* double)) (arg2 (* double)))
  42   (let ((a1 (deref arg1))
  43         (a2 (deref arg2)))
  44     (cond ((= a1 a2) 0)
  45           ((< a1 a2) -1)
  46           (t 1))))
  47
  48 (let* ((vector (coerce '(0.1d0 0.5d0 0.2d0 1.2d0 1.5d0 2.5d0 0.0d0 0.1d0 0.2d0 0.3d0)
  49                        '(vector double-float)))
  50        (sorted (sort (copy-seq vector) #'<)))
  51   (gc :full t)
  52   (sb-sys:with-pinned-objects (vector)
  53     (qsort (sb-sys:vector-sap vector)
  54            (length vector)
  55            (alien-size double :bytes)
  56            double*-cmp))
  57   (assert (equalp vector sorted)))
  58
  59
  60 (sb-alien::define-alien-callback redefined-fun int ()
  61     0)
  62
  63 (eval
  64  '(sb-alien::define-alien-callback redefined-fun int ()
  65    42))
  66
  67 (assert (= 42 (alien-funcall redefined-fun)))
  68
  69 (sb-alien::define-alien-callback return-single float ((x float))
  70   x)
  71
  72 (sb-alien::define-alien-callback return-double double ((x double))
  73   x)
  74
  75 (defconstant spi (coerce pi 'single-float))
  76
  77 (assert (= spi (alien-funcall return-single spi)))
  78 (assert (= pi (alien-funcall return-double pi)))
  79
  80 (quit :unix-status 104)