1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
3 ;;; foreign-globals.lisp --- Tests on foreign globals.
5 ;;; Copyright (C) 2005-2007, Luis Oliveira <loliveira(@)common-lisp.net>
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:
15 ;;; The above copyright notice and this permission notice shall be
16 ;;; included in all copies or substantial portions of the Software.
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.
28 (in-package #:cffi-tests
)
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
)
45 (deftest foreign-globals.ref.char
49 (deftest foreign-globals.ref.unsigned-char
53 (deftest foreign-globals.ref.short
57 (deftest foreign-globals.ref.unsigned-short
61 (deftest foreign-globals.ref.int
65 (deftest foreign-globals.ref.unsigned-int
69 (deftest foreign-globals.ref.long
73 (deftest foreign-globals.ref.unsigned-long
77 (deftest foreign-globals.ref.float
81 (deftest foreign-globals.ref.double
85 (deftest foreign-globals.ref.pointer
86 (null-pointer-p *var-pointer
*)
89 (deftest foreign-globals.ref.string
91 "Hello, foreign world!")
93 #+openmcl
(push 'foreign-globals.set.long-long rt
::*expected-failures
*)
95 (deftest foreign-globals.ref.long-long
99 (deftest foreign-globals.ref.unsigned-long-long
100 *var-unsigned-long-long
*
101 18446744073709551615)
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
))
110 (setq ,place
,old
)))))
112 (deftest foreign-globals.set.int
113 (with-old-value-restored (*var-int
*)
118 (deftest foreign-globals.set.string
119 (with-old-value-restored (*var-string
*)
120 (setq *var-string
* "Ehxosxangxo")
123 ;; free the string we just allocated
124 (foreign-free (mem-ref (get-var-pointer '*var-string
*) :pointer
))))
127 (deftest foreign-globals.set.long-long
128 (with-old-value-restored (*var-long-long
*)
129 (setq *var-long-long
* -
9223000000000005808)
131 -
9223000000000005808)
133 (deftest foreign-globals.get-var-pointer
.1
134 (pointerp (get-var-pointer '*char-var
*))
137 (deftest foreign-globals.get-var-pointer
.2
138 (mem-ref (get-var-pointer '*char-var
*) :char
)
143 (defcvar "UPPERCASEINT1" :int
)
144 (defcvar "UPPER_CASE_INT1" :int
)
145 (defcvar "MiXeDCaSeInT1" :int
)
146 (defcvar "MiXeD_CaSe_InT1" :int
)
148 (deftest foreign-globals.ref.uppercaseint1
152 (deftest foreign-globals.ref.upper-case-int1
156 (deftest foreign-globals.ref.mixedcaseint1
160 (deftest foreign-globals.ref.mixed-case-int1
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)"))))
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)"))))
192 (deftest foreign-globals.ref.uppercaseint2
196 (deftest foreign-globals.ref.upper-case-int2
200 (deftest foreign-globals.ref.mixedcaseint2
204 (deftest foreign-globals.ref.mixed-case-int2
208 (deftest foreign-globals.ref.uppercaseint3
212 (deftest foreign-globals.ref.upper-case-int3
216 (deftest foreign-globals.ref.mixedcaseint3
220 (deftest foreign-globals.ref.mixed-case-int3
225 ;;; gracefully accept symbols in defcvar
227 (defcvar *var-char
* :char
)
228 (defcvar var-char
:char
)
230 (deftest foreign-globals.symbol-name
231 (values *var-char
* var-char
)
236 #-cffi-features
:flat-namespace
238 (deftest foreign-globals.namespace
.1
240 (mem-ref (foreign-symbol-pointer "var_char" :library
'libtest
) :char
)
241 (foreign-symbol-pointer "var_char" :library
'libtest2
))
244 (deftest foreign-globals.namespace
.2
246 (mem-ref (foreign-symbol-pointer "ns_var" :library
'libtest
) :boolean
)
247 (mem-ref (foreign-symbol-pointer "ns_var" :library
'libtest2
) :boolean
))
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.
255 (pushnew 'foreign-globals.namespace
.3 regression-test
::*expected-failures
*)
257 (deftest foreign-globals.namespace
.3
259 (foreign-symbol-pointer "var_char" :library
'libtest2
)
260 (mem-ref (foreign-symbol-pointer "var_char") :char
))
263 (defcvar ("ns_var" *ns-var1
* :library libtest
) :boolean
)
264 (defcvar ("ns_var" *ns-var2
* :library libtest2
) :boolean
)
266 (deftest foreign-globals.namespace
.4
267 (values *ns-var1
* *ns-var2
*)
272 (defcvar ("var_char" *var-char-ro
* :read-only t
) :char
273 "Testing the docstring too.")
275 (deftest foreign-globals.read-only
.1
276 (values *var-char-ro
*
277 (ignore-errors (setf *var-char-ro
* 12)))