foreign-globals.lisp - clic - Clic is an command line interactive client for go… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
foreign-globals.lisp (9271B) | |
--- | |
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) :c… | |
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) :boo… | |
261 (mem-ref (foreign-symbol-pointer "ns_var" :library 'libtest2) :bo… | |
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-failu… | |
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) |