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