misc-types.lisp - clic - Clic is an command line interactive client for gopher … | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
misc-types.lisp (8802B) | |
--- | |
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- | |
2 ;;; | |
3 ;;; misc-types.lisp --- Various tests on the type system. | |
4 ;;; | |
5 ;;; Copyright (C) 2005-2006, 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 (defcfun ("my_strdup" strdup) :string+ptr (str :string)) | |
31 | |
32 (defcfun ("my_strfree" strfree) :void (str :pointer)) | |
33 | |
34 (deftest misc-types.string+ptr | |
35 (destructuring-bind (string pointer) | |
36 (strdup "foo") | |
37 (strfree pointer) | |
38 string) | |
39 "foo") | |
40 | |
41 #-(and) | |
42 (deftest misc-types.string+ptr.ub8 | |
43 (destructuring-bind (string pointer) | |
44 (strdup (make-array 3 :element-type '(unsigned-byte 8) | |
45 :initial-contents (map 'list #'char-code "fo… | |
46 (strfree pointer) | |
47 string) | |
48 "foo") | |
49 | |
50 #-(and) | |
51 (deftest misc-types.string.ub8.1 | |
52 (let ((array (make-array 7 :element-type '(unsigned-byte 8) | |
53 :initial-contents '(84 117 114 97 110 103 9… | |
54 (with-foreign-string (foreign-string array) | |
55 (foreign-string-to-lisp foreign-string))) | |
56 "Turanga") | |
57 | |
58 #-(and) | |
59 (deftest misc-types.string.ub8.2 | |
60 (let ((str (foreign-string-alloc | |
61 (make-array 7 :element-type '(unsigned-byte 8) | |
62 :initial-contents '(84 117 114 97 110 103 97… | |
63 (prog1 (foreign-string-to-lisp str) | |
64 (foreign-string-free str))) | |
65 "Turanga") | |
66 | |
67 (defcfun "equalequal" :boolean | |
68 (a (:boolean :int)) | |
69 (b (:boolean :unsigned-int))) | |
70 | |
71 (defcfun "bool_and" (:boolean :char) | |
72 (a (:boolean :unsigned-char)) | |
73 (b (:boolean :char))) | |
74 | |
75 (defcfun "bool_xor" (:boolean :unsigned-long) | |
76 (a (:boolean :long)) | |
77 (b (:boolean :unsigned-long))) | |
78 | |
79 (deftest misc-types.boolean.1 | |
80 (list (equalequal nil nil) | |
81 (equalequal t t) | |
82 (equalequal t 23) | |
83 (bool-and 'a 'b) | |
84 (bool-and "foo" nil) | |
85 (bool-xor t nil) | |
86 (bool-xor nil nil)) | |
87 (t t t t nil t nil)) | |
88 | |
89 (defcfun "sizeof_bool" :unsigned-int) | |
90 | |
91 (deftest misc-types.sizeof.bool | |
92 (eql (sizeof-bool) (foreign-type-size :bool)) | |
93 t) | |
94 | |
95 (defcfun "bool_to_unsigned" :unsigned-int | |
96 (b :bool)) | |
97 | |
98 (defcfun "unsigned_to_bool" :bool | |
99 (u :unsigned-int)) | |
100 | |
101 (deftest misc-types.bool.convert-to-foreign.mem | |
102 (loop for v in '(nil t) | |
103 collect | |
104 (with-foreign-object (b :bool) | |
105 (setf (mem-ref b :bool) v) | |
106 (mem-ref b #.(cffi::canonicalize-foreign-type :bool)))) | |
107 (0 1)) | |
108 | |
109 (deftest misc-types.bool.convert-to-foreign.call | |
110 (mapcar #'bool-to-unsigned '(nil t)) | |
111 (0 1)) | |
112 | |
113 (deftest misc-types.bool.convert-from-foreign.mem | |
114 (loop for v in '(0 1 42) | |
115 collect | |
116 (with-foreign-object (b :bool) | |
117 (setf (mem-ref b #.(cffi::canonicalize-foreign-type :bool)) … | |
118 (mem-ref b :bool))) | |
119 (nil t t)) | |
120 | |
121 (deftest misc-types.bool.convert-from-foreign.call | |
122 (mapcar #'unsigned-to-bool '(0 1 42)) | |
123 (nil t t)) | |
124 | |
125 ;;; Regression test: boolean type only worked with canonicalized | |
126 ;;; built-in integer types. Should work for any type that canonicalizes | |
127 ;;; to a built-in integer type. | |
128 (defctype int-for-bool :int) | |
129 (defcfun ("equalequal" equalequal2) :boolean | |
130 (a (:boolean int-for-bool)) | |
131 (b (:boolean :uint))) | |
132 | |
133 (deftest misc-types.boolean.2 | |
134 (equalequal2 nil t) | |
135 nil) | |
136 | |
137 (defctype my-string :string+ptr) | |
138 | |
139 (defun funkify (str) | |
140 (concatenate 'string "MORE " (string-upcase str))) | |
141 | |
142 (defun 3rd-person (value) | |
143 (list (concatenate 'string "Strdup says: " (first value)) | |
144 (second value))) | |
145 | |
146 ;; (defctype funky-string | |
147 ;; (:wrapper my-string | |
148 ;; :to-c #'funkify | |
149 ;; :from-c (lambda (value) | |
150 ;; (list | |
151 ;; (concatenate 'string "Strdup says: " | |
152 ;; (first value)) | |
153 ;; (second value)))) | |
154 ;; "A useful type.") | |
155 | |
156 (defctype funky-string (:wrapper my-string :to-c funkify :from-c 3rd-per… | |
157 | |
158 (defcfun ("my_strdup" funky-strdup) funky-string | |
159 (str funky-string)) | |
160 | |
161 (deftest misc-types.wrapper | |
162 (destructuring-bind (string ptr) | |
163 (funky-strdup "code") | |
164 (strfree ptr) | |
165 string) | |
166 "Strdup says: MORE CODE") | |
167 | |
168 (deftest misc-types.sized-ints | |
169 (mapcar #'foreign-type-size | |
170 '(:int8 :uint8 :int16 :uint16 :int32 :uint32 :int64 :uint64)) | |
171 (1 1 2 2 4 4 8 8)) | |
172 | |
173 (define-foreign-type error-error () | |
174 () | |
175 (:actual-type :int) | |
176 (:simple-parser error-error)) | |
177 | |
178 (defmethod translate-to-foreign (value (type error-error)) | |
179 (declare (ignore value)) | |
180 (error "translate-to-foreign invoked.")) | |
181 | |
182 (defmethod translate-from-foreign (value (type error-error)) | |
183 (declare (ignore value)) | |
184 (error "translate-from-foreign invoked.")) | |
185 | |
186 (eval-when (:load-toplevel :compile-toplevel :execute) | |
187 (defmethod expand-to-foreign (value (type error-error)) | |
188 value) | |
189 | |
190 (defmethod expand-from-foreign (value (type error-error)) | |
191 value)) | |
192 | |
193 (defcfun ("abs" expand-abs) error-error | |
194 (n error-error)) | |
195 | |
196 (defcvar ("var_int" *expand-var-int*) error-error) | |
197 | |
198 (defcfun ("expect_int_sum" expand-expect-int-sum) :boolean | |
199 (cb :pointer)) | |
200 | |
201 (defcallback expand-int-sum error-error ((x error-error) (y error-error)) | |
202 (+ x y)) | |
203 | |
204 ;;; Ensure that macroexpansion-time translators are called where this | |
205 ;;; is guaranteed (defcfun, defcvar, foreign-funcall and defcallback) | |
206 (deftest misc-types.expand.1 | |
207 (expand-abs -1) | |
208 1) | |
209 | |
210 #-cffi-sys::no-foreign-funcall | |
211 (deftest misc-types.expand.2 | |
212 (foreign-funcall "abs" error-error -1 error-error) | |
213 1) | |
214 | |
215 (deftest misc-types.expand.3 | |
216 (let ((old (mem-ref (get-var-pointer '*expand-var-int*) :int))) | |
217 (unwind-protect | |
218 (progn | |
219 (setf *expand-var-int* 42) | |
220 *expand-var-int*) | |
221 (setf (mem-ref (get-var-pointer '*expand-var-int*) :int) old))) | |
222 42) | |
223 | |
224 (deftest misc-types.expand.4 | |
225 (expand-expect-int-sum (callback expand-int-sum)) | |
226 t) | |
227 | |
228 (define-foreign-type translate-tracker () | |
229 () | |
230 (:actual-type :int) | |
231 (:simple-parser translate-tracker)) | |
232 | |
233 (declaim (special .fto-called.)) | |
234 | |
235 (defmethod free-translated-object (value (type translate-tracker) param) | |
236 (declare (ignore value param)) | |
237 (setf .fto-called. t)) | |
238 | |
239 (define-foreign-type expand-tracker () | |
240 () | |
241 (:actual-type :int) | |
242 (:simple-parser expand-tracker)) | |
243 | |
244 (defmethod free-translated-object (value (type expand-tracker) param) | |
245 (declare (ignore value param)) | |
246 (setf .fto-called. t)) | |
247 | |
248 (eval-when (:compile-toplevel :load-toplevel :execute) | |
249 (defmethod expand-to-foreign (value (type expand-tracker)) | |
250 (declare (ignore value)) | |
251 (call-next-method))) | |
252 | |
253 (defcfun ("abs" ttracker-abs) :int | |
254 (n translate-tracker)) | |
255 | |
256 (defcfun ("abs" etracker-abs) :int | |
257 (n expand-tracker)) | |
258 | |
259 ;; free-translated-object must be called when there is no etf | |
260 (deftest misc-types.expand.5 | |
261 (let ((.fto-called. nil)) | |
262 (ttracker-abs -1) | |
263 .fto-called.) | |
264 t) | |
265 | |
266 ;; free-translated-object must be called when there is an etf, but | |
267 ;; they answer *runtime-translator-form* | |
268 (deftest misc-types.expand.6 | |
269 (let ((.fto-called. nil)) | |
270 (etracker-abs -1) | |
271 .fto-called.) | |
272 t) | |
273 | |
274 (define-foreign-type misc-type.expand.7 () | |
275 () | |
276 (:actual-type :int) | |
277 (:simple-parser misc-type.expand.7)) | |
278 | |
279 (defmethod translate-to-foreign (value (type misc-type.expand.7)) | |
280 (values value 'second-value)) | |
281 | |
282 ;; Auxiliary function to test CONVERT-TO-FOREIGN's compiler macro. | |
283 (defun misc-type.expand.7-aux () | |
284 (convert-to-foreign "foo" 'misc-type.expand.7)) | |
285 | |
286 ;; Checking that expand-to-foreign doesn't ignore the second value of | |
287 ;; translate-to-foreign. | |
288 (deftest misc-type.expand.7 | |
289 (misc-type.expand.7-aux) | |
290 "foo" second-value) | |
291 | |
292 ;; Like MISC-TYPE.EXPAND.7 but doesn't depend on compiler macros | |
293 ;; kicking in. | |
294 (deftest misc-type.expand.8 | |
295 (eval (expand-to-foreign "foo" (cffi::parse-type 'misc-type.expand.7… | |
296 "foo" second-value) |