misc-types.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
---
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 "foo")))
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 97))))
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)) v)
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-person))
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)