external/cffi.darcs/_darcs/pristine/tests/foreign-globals.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; foreign-globals.lisp --- Tests on foreign globals.
   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 (defcvar ("var_char" *char-var*)  :char)
  31 (defcvar "var_unsigned_char"      :unsigned-char)
  32 (defcvar "var_short"              :short)
  33 (defcvar "var_unsigned_short"     :unsigned-short)
  34 (defcvar "var_int"                :int)
  35 (defcvar "var_unsigned_int"       :unsigned-int)
  36 (defcvar "var_long"               :long)
  37 (defcvar "var_unsigned_long"      :unsigned-long)
  38 (defcvar "var_float"              :float)
  39 (defcvar "var_double"             :double)
  40 (defcvar "var_pointer"            :pointer)
  41 (defcvar "var_string"             :string)
  42 (defcvar "var_long_long"          :long-long)
  43 (defcvar "var_unsigned_long_long" :unsigned-long-long)
  44
  45 (deftest foreign-globals.ref.char
  46     *char-var*
  47   -127)
  48
  49 (deftest foreign-globals.ref.unsigned-char
  50     *var-unsigned-char*
  51   255)
  52
  53 (deftest foreign-globals.ref.short
  54     *var-short*
  55   -32767)
  56
  57 (deftest foreign-globals.ref.unsigned-short
  58     *var-unsigned-short*
  59   65535)
  60
  61 (deftest foreign-globals.ref.int
  62     *var-int*
  63   -32767)
  64
  65 (deftest foreign-globals.ref.unsigned-int
  66     *var-unsigned-int*
  67   65535)
  68
  69 (deftest foreign-globals.ref.long
  70     *var-long*
  71   -2147483647)
  72
  73 (deftest foreign-globals.ref.unsigned-long
  74     *var-unsigned-long*
  75   4294967295)
  76
  77 (deftest foreign-globals.ref.float
  78     *var-float*
  79   42.0)
  80
  81 (deftest foreign-globals.ref.double
  82     *var-double*
  83   42.0d0)
  84
  85 (deftest foreign-globals.ref.pointer
  86     (null-pointer-p *var-pointer*)
  87   t)
  88
  89 (deftest foreign-globals.ref.string
  90     *var-string*
  91   "Hello, foreign world!")
  92
  93 #+openmcl (push 'foreign-globals.set.long-long rt::*expected-failures*)
  94
  95 (deftest foreign-globals.ref.long-long
  96     *var-long-long*
  97   -9223372036854775807)
  98
  99 (deftest foreign-globals.ref.unsigned-long-long
 100     *var-unsigned-long-long*
 101   18446744073709551615)
 102
 103 ;; The *.set.* tests restore the old values so that the *.ref.*
 104 ;; don't fail when re-run.
 105 (defmacro with-old-value-restored ((place) &body body)
 106   (let ((old (gensym)))
 107     `(let ((,old ,place))
 108        (prog1
 109            (progn ,@body)
 110          (setq ,place ,old)))))
 111
 112 (deftest foreign-globals.set.int
 113     (with-old-value-restored (*var-int*)
 114       (setq *var-int* 42)
 115       *var-int*)
 116   42)
 117
 118 (deftest foreign-globals.set.string
 119     (with-old-value-restored (*var-string*)
 120       (setq *var-string* "Ehxosxangxo")
 121       (prog1
 122           *var-string*
 123         ;; free the string we just allocated
 124         (foreign-free (mem-ref (get-var-pointer '*var-string*) :pointer))))
 125   "Ehxosxangxo")
 126
 127 (deftest foreign-globals.set.long-long
 128     (with-old-value-restored (*var-long-long*)
 129       (setq *var-long-long* -9223000000000005808)
 130       *var-long-long*)
 131   -9223000000000005808)
 132
 133 (deftest foreign-globals.get-var-pointer.1
 134     (pointerp (get-var-pointer '*char-var*))
 135   t)
 136
 137 (deftest foreign-globals.get-var-pointer.2
 138     (mem-ref (get-var-pointer '*char-var*) :char)
 139   -127)
 140
 141 ;;; Symbol case.
 142
 143 (defcvar "UPPERCASEINT1"     :int)
 144 (defcvar "UPPER_CASE_INT1"   :int)
 145 (defcvar "MiXeDCaSeInT1"     :int)
 146 (defcvar "MiXeD_CaSe_InT1"   :int)
 147
 148 (deftest foreign-globals.ref.uppercaseint1
 149     *uppercaseint1*
 150   12345)
 151
 152 (deftest foreign-globals.ref.upper-case-int1
 153     *upper-case-int1*
 154   23456)
 155
 156 (deftest foreign-globals.ref.mixedcaseint1
 157     *mixedcaseint1*
 158   34567)
 159
 160 (deftest foreign-globals.ref.mixed-case-int1
 161     *mixed-case-int1*
 162   45678)
 163
 164 (when (string= (symbol-name 'nil) "NIL")
 165   (let ((*readtable* (copy-readtable)))
 166     (setf (readtable-case *readtable*) :invert)
 167     (eval (read-from-string "(defcvar \"UPPERCASEINT2\"     :int)"))
 168     (eval (read-from-string "(defcvar \"UPPER_CASE_INT2\"   :int)"))
 169     (eval (read-from-string "(defcvar \"MiXeDCaSeInT2\"     :int)"))
 170     (eval (read-from-string "(defcvar \"MiXeD_CaSe_InT2\"   :int)"))
 171     (setf (readtable-case *readtable*) :preserve)
 172     (eval (read-from-string "(DEFCVAR \"UPPERCASEINT3\"     :INT)"))
 173     (eval (read-from-string "(DEFCVAR \"UPPER_CASE_INT3\"   :INT)"))
 174     (eval (read-from-string "(DEFCVAR \"MiXeDCaSeInT3\"     :INT)"))
 175     (eval (read-from-string "(DEFCVAR \"MiXeD_CaSe_InT3\"   :INT)"))))
 176
 177
 178 ;;; EVAL gets rid of SBCL's unreachable code warnings.
 179 (when (string= (symbol-name (eval nil)) "nil")
 180   (let ((*readtable* (copy-readtable)))
 181     (setf (readtable-case *readtable*) :invert)
 182     (eval (read-from-string "(DEFCVAR \"UPPERCASEINT2\"     :INT)"))
 183     (eval (read-from-string "(DEFCVAR \"UPPER_CASE_INT2\"   :INT)"))
 184     (eval (read-from-string "(DEFCVAR \"MiXeDCaSeInT2\"     :INT)"))
 185     (eval (read-from-string "(DEFCVAR \"MiXeD_CaSe_InT2\"   :INT)"))
 186     (setf (readtable-case *readtable*) :downcase)
 187     (eval (read-from-string "(defcvar \"UPPERCASEINT3\"     :int)"))
 188     (eval (read-from-string "(defcvar \"UPPER_CASE_INT3\"   :int)"))
 189     (eval (read-from-string "(defcvar \"MiXeDCaSeInT3\"     :int)"))
 190     (eval (read-from-string "(defcvar \"MiXeD_CaSe_InT3\"   :int)"))))
 191
 192 (deftest foreign-globals.ref.uppercaseint2
 193     *uppercaseint2*
 194   12345)
 195
 196 (deftest foreign-globals.ref.upper-case-int2
 197     *upper-case-int2*
 198   23456)
 199
 200 (deftest foreign-globals.ref.mixedcaseint2
 201     *mixedcaseint2*
 202   34567)
 203
 204 (deftest foreign-globals.ref.mixed-case-int2
 205     *mixed-case-int2*
 206   45678)
 207
 208 (deftest foreign-globals.ref.uppercaseint3
 209     *uppercaseint3*
 210   12345)
 211
 212 (deftest foreign-globals.ref.upper-case-int3
 213     *upper-case-int3*
 214   23456)
 215
 216 (deftest foreign-globals.ref.mixedcaseint3
 217     *mixedcaseint3*
 218   34567)
 219
 220 (deftest foreign-globals.ref.mixed-case-int3
 221     *mixed-case-int3*
 222   45678)
 223
 224 ;;; regression test:
 225 ;;; gracefully accept symbols in defcvar
 226
 227 (defcvar *var-char* :char)
 228 (defcvar var-char :char)
 229
 230 (deftest foreign-globals.symbol-name
 231     (values *var-char* var-char)
 232   -127 -127)
 233
 234 ;;;# Namespace
 235
 236 #-cffi-features:flat-namespace
 237 (progn
 238   (deftest foreign-globals.namespace.1
 239       (values
 240        (mem-ref (foreign-symbol-pointer "var_char" :library 'libtest) :char)
 241        (foreign-symbol-pointer "var_char" :library 'libtest2))
 242     -127 nil)
 243
 244   (deftest foreign-globals.namespace.2
 245       (values
 246        (mem-ref (foreign-symbol-pointer "ns_var" :library 'libtest) :boolean)
 247        (mem-ref (foreign-symbol-pointer "ns_var" :library 'libtest2) :boolean))
 248     t nil)
 249
 250   ;; For its "default" module, Lispworks seems to cache lookups from
 251   ;; the newest module tried.  If a lookup happens to have failed
 252   ;; subsequent lookups will fail even the symbol exists in other
 253   ;; modules.  So this test fails.
 254   #+lispworks
 255   (pushnew 'foreign-globals.namespace.3 regression-test::*expected-failures*)
 256
 257   (deftest foreign-globals.namespace.3
 258       (values
 259        (foreign-symbol-pointer "var_char" :library 'libtest2)
 260        (mem-ref (foreign-symbol-pointer "var_char") :char))
 261     nil -127)
 262
 263   (defcvar ("ns_var" *ns-var1* :library libtest) :boolean)
 264   (defcvar ("ns_var" *ns-var2* :library libtest2) :boolean)
 265
 266   (deftest foreign-globals.namespace.4
 267       (values *ns-var1* *ns-var2*)
 268     t nil))
 269
 270 ;;;# Read-only
 271
 272 (defcvar ("var_char" *var-char-ro* :read-only t) :char
 273   "Testing the docstring too.")
 274
 275 (deftest foreign-globals.read-only.1
 276     (values *var-char-ro*
 277             (ignore-errors (setf *var-char-ro* 12)))
 278   -127 nil)