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