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
)
43 #-cffi-features
:no-long-long
45 (defcvar "var_long_long" :long-long
)
46 (defcvar "var_unsigned_long_long" :unsigned-long-long
))
48 (deftest foreign-globals.ref.char
52 (deftest foreign-globals.ref.unsigned-char
56 (deftest foreign-globals.ref.short
60 (deftest foreign-globals.ref.unsigned-short
64 (deftest foreign-globals.ref.int
68 (deftest foreign-globals.ref.unsigned-int
72 (deftest foreign-globals.ref.long
76 (deftest foreign-globals.ref.unsigned-long
80 (deftest foreign-globals.ref.float
84 (deftest foreign-globals.ref.double
88 (deftest foreign-globals.ref.pointer
89 (null-pointer-p *var-pointer
*)
92 (deftest foreign-globals.ref.string
94 "Hello, foreign world!")
96 #-cffi-features
:no-long-long
98 #+openmcl
(push 'foreign-globals.set.long-long rt
::*expected-failures
*)
100 (deftest foreign-globals.ref.long-long
102 -
9223372036854775807)
104 (deftest foreign-globals.ref.unsigned-long-long
105 *var-unsigned-long-long
*
106 18446744073709551615))
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
))
115 (setq ,place
,old
)))))
117 (deftest foreign-globals.set.int
118 (with-old-value-restored (*var-int
*)
123 (deftest foreign-globals.set.string
124 (with-old-value-restored (*var-string
*)
125 (setq *var-string
* "Ehxosxangxo")
128 ;; free the string we just allocated
129 (foreign-free (mem-ref (get-var-pointer '*var-string
*) :pointer
))))
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)
137 -
9223000000000005808)
139 (deftest foreign-globals.get-var-pointer
.1
140 (pointerp (get-var-pointer '*char-var
*))
143 (deftest foreign-globals.get-var-pointer
.2
144 (mem-ref (get-var-pointer '*char-var
*) :char
)
149 (defcvar "UPPERCASEINT1" :int
)
150 (defcvar "UPPER_CASE_INT1" :int
)
151 (defcvar "MiXeDCaSeInT1" :int
)
152 (defcvar "MiXeD_CaSe_InT1" :int
)
154 (deftest foreign-globals.ref.uppercaseint1
158 (deftest foreign-globals.ref.upper-case-int1
162 (deftest foreign-globals.ref.mixedcaseint1
166 (deftest foreign-globals.ref.mixed-case-int1
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)"))))
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)"))))
198 (deftest foreign-globals.ref.uppercaseint2
202 (deftest foreign-globals.ref.upper-case-int2
206 (deftest foreign-globals.ref.mixedcaseint2
210 (deftest foreign-globals.ref.mixed-case-int2
214 (deftest foreign-globals.ref.uppercaseint3
218 (deftest foreign-globals.ref.upper-case-int3
222 (deftest foreign-globals.ref.mixedcaseint3
226 (deftest foreign-globals.ref.mixed-case-int3
231 ;;; gracefully accept symbols in defcvar
233 (defcvar *var-char
* :char
)
234 (defcvar var-char
:char
)
236 (deftest foreign-globals.symbol-name
237 (values *var-char
* var-char
)
242 #-cffi-features
:flat-namespace
244 (deftest foreign-globals.namespace
.1
246 (mem-ref (foreign-symbol-pointer "var_char" :library
'libtest
) :char
)
247 (foreign-symbol-pointer "var_char" :library
'libtest2
))
250 (deftest foreign-globals.namespace
.2
252 (mem-ref (foreign-symbol-pointer "ns_var" :library
'libtest
) :boolean
)
253 (mem-ref (foreign-symbol-pointer "ns_var" :library
'libtest2
) :boolean
))
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.
261 (pushnew 'foreign-globals.namespace
.3 regression-test
::*expected-failures
*)
263 (deftest foreign-globals.namespace
.3
265 (foreign-symbol-pointer "var_char" :library
'libtest2
)
266 (mem-ref (foreign-symbol-pointer "var_char") :char
))
269 (defcvar ("ns_var" *ns-var1
* :library libtest
) :boolean
)
270 (defcvar ("ns_var" *ns-var2
* :library libtest2
) :boolean
)
272 (deftest foreign-globals.namespace
.4
273 (values *ns-var1
* *ns-var2
*)
278 (defcvar ("var_char" *var-char-ro
* :read-only t
) :char
279 "Testing the docstring too.")
281 (deftest foreign-globals.read-only
.1
282 (values *var-char-ro
*
283 (ignore-errors (setf *var-char-ro
* 12)))