tests/bindings.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; libtest.lisp --- Setup CFFI bindings for libtest.
   4 ;;;
   5 ;;; Copyright (C) 2005-2007, Luis Oliveira  <loliveira(@)common-lisp.net>
   6 ;;;
   7 ;;; Permission is hereby granted, free of charge, to any person
   8 ;;; obtaining a copy of this software and associated documentation
   9 ;;; files (the "Software"), to deal in the Software without
  10 ;;; restriction, including without limitation the rights to use, copy,
  11 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
  12 ;;; of the Software, and to permit persons to whom the Software is
  13 ;;; furnished to do so, subject to the following conditions:
  14 ;;;
  15 ;;; The above copyright notice and this permission notice shall be
  16 ;;; included in all copies or substantial portions of the Software.
  17 ;;;
  18 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  19 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  20 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  21 ;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  22 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  23 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  24 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  25 ;;; DEALINGS IN THE SOFTWARE.
  26 ;;;
  27
  28 (in-package #:cffi-tests)
  29
  30 (define-foreign-library (libtest :type :test)
  31   (:darwin (:or "libtest.dylib" "libtest32.dylib"))
  32   (:unix (:or "libtest.so" "libtest32.so"))
  33   (:windows "libtest.dll")
  34   (t (:default "libtest")))
  35
  36 (define-foreign-library (libtest2 :type :test)
  37   (:darwin (:or "libtest2.dylib" "libtest2_32.dylib"))
  38   (:unix (:or "libtest2.so" "libtest2_32.so"))
  39   (t (:default "libtest2")))
  40
  41 (define-foreign-library (libfsbv :type :test)
  42   (:darwin (:or "libfsbv.dylib" "libfsbv32.dylib"))
  43   (:unix (:or "libfsbv.so" "libfsbv_32.so"))
  44   (:windows "libfsbv.dll")
  45   (t (:default "libfsbv")))
  46
  47 (define-foreign-library libc
  48   (:windows "msvcrt.dll"))
  49
  50 (define-foreign-library libm
  51   #+(and lispworks darwin) ; not sure why the full path is necessary
  52   (:darwin "/usr/lib/libm.dylib")
  53   (t (:default "libm")))
  54
  55 (defmacro deftest (name &rest body)
  56   (destructuring-bind (name &key expected-to-fail)
  57       (alexandria:ensure-list name)
  58     (let ((result `(rtest:deftest ,name ,@body)))
  59       (when expected-to-fail
  60         (setf result `(progn
  61                         (when ,expected-to-fail
  62                           (pushnew ',name rtest::*expected-failures*))
  63                         ,result)))
  64       result)))
  65
  66 (defun call-within-new-thread (fn &rest args)
  67   (let (result
  68         error
  69         (cv (bordeaux-threads:make-condition-variable))
  70         (lock (bordeaux-threads:make-lock)))
  71     (bordeaux-threads:with-lock-held (lock)
  72       (bordeaux-threads:make-thread
  73        (lambda ()
  74          (multiple-value-setq (result error)
  75            (ignore-errors (apply fn args)))
  76          (bordeaux-threads:with-lock-held (lock)
  77            (bordeaux-threads:condition-notify cv))))
  78       (bordeaux-threads:condition-wait cv lock)
  79       (values result error))))
  80
  81 ;;; As of OSX 10.6.6, loading CoreFoundation on something other than
  82 ;;; the initial thread results in a crash.
  83 (deftest load-core-foundation
  84     (progn
  85       #+bordeaux-threads
  86       (call-within-new-thread 'load-foreign-library
  87                               '(:framework "CoreFoundation"))
  88       t)
  89   t)
  90
  91 ;;; Return the directory containing the source when compiling or
  92 ;;; loading this file.  We don't use *LOAD-TRUENAME* because the fasl
  93 ;;; file may be in a different directory than the source with certain
  94 ;;; ASDF extensions loaded.
  95 (defun load-directory ()
  96   (let ((here #.(or *compile-file-truename* *load-truename*)))
  97     (make-pathname :name nil :type nil :version nil
  98                    :defaults here)))
  99
 100 (defun load-test-libraries ()
 101   (let ((*foreign-library-directories* (list (load-directory))))
 102     (load-foreign-library 'libtest)
 103     (load-foreign-library 'libtest2)
 104     (load-foreign-library 'libfsbv)
 105     (load-foreign-library 'libc)
 106     #+(or abcl lispworks) (load-foreign-library 'libm)))
 107
 108 #-(:and :ecl (:not :dffi))
 109 (load-test-libraries)
 110
 111 #+(:and :ecl (:not :dffi))
 112 (ffi:load-foreign-library
 113  #.(make-pathname :name "libtest" :type "so"
 114                   :defaults (or *compile-file-truename* *load-truename*)))
 115
 116 ;;; check libtest version
 117 (defparameter *required-dll-version* "20120107")
 118
 119 (defcvar "dll_version" :string)
 120
 121 (unless (string= *dll-version* *required-dll-version*)
 122   (error "version check failed: expected ~s but libtest reports ~s"
 123          *required-dll-version*
 124          *dll-version*))
 125
 126 ;;; The maximum and minimum values for single and double precision C
 127 ;;; floating point values, which may be quite different from the
 128 ;;; corresponding Lisp versions.
 129 (defcvar "float_max" :float)
 130 (defcvar "float_min" :float)
 131 (defcvar "double_max" :double)
 132 (defcvar "double_min" :double)
 133
 134 (defun run-cffi-tests (&key (compiled nil))
 135   (let ((regression-test::*compile-tests* compiled)
 136         (*package* (find-package '#:cffi-tests)))
 137     (format t "~&;;; running tests (~Acompiled)" (if compiled "" "un"))
 138     (do-tests)
 139     (set-difference (regression-test:pending-tests)
 140                     regression-test::*expected-failures*)))
 141
 142 (defun run-all-cffi-tests ()
 143   (let ((unexpected-failures
 144           (append (run-cffi-tests :compiled nil)
 145                   (run-cffi-tests :compiled t))))
 146     (format t "~%~%Overall unexpected failures: ~{~%  ~A~}~%" unexpected-failures)
 147     unexpected-failures))
 148
 149 (defmacro expecting-error (&body body)
 150   `(handler-case (progn ,@body :no-error)
 151      (error () :error)))