foreign-globals.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) 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) :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)