3rdparties/software/cffi_0.21.0/tests/foreign-globals.lisp (9271 bytes)
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 rt::*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)