1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
3 ;;; struct.lisp --- Foreign structure type tests.
5 ;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
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
)
34 (defparameter *timeval-size
* (* 2 (max (foreign-type-size :long
)
35 (foreign-type-alignment :long
))))
37 ;;;# Basic Structure Tests
40 (- (foreign-type-size 'timeval
) *timeval-size
*)
44 (with-foreign-object (tv 'timeval
)
45 (setf (foreign-slot-value tv
'timeval
'tv-secs
) 0)
46 (setf (foreign-slot-value tv
'timeval
'tv-usecs
) 1)
47 (values (foreign-slot-value tv
'timeval
'tv-secs
)
48 (foreign-slot-value tv
'timeval
'tv-usecs
)))
52 (with-foreign-object (tv 'timeval
)
53 (with-foreign-slots ((tv-secs tv-usecs
) tv timeval
)
54 (setf tv-secs
100 tv-usecs
200)
55 (values tv-secs tv-usecs
)))
58 ;; regression test: accessing a struct through a typedef
60 (defctype xpto timeval
)
63 (with-foreign-object (tv 'xpto
)
64 (setf (foreign-slot-value tv
'xpto
'tv-usecs
) 1)
65 (values (foreign-slot-value tv
'xpto
'tv-usecs
)
66 (foreign-slot-value tv
'timeval
'tv-usecs
)))
70 (sort (foreign-slot-names 'xpto
) #'<
71 :key
(lambda (x) (foreign-slot-offset 'xpto x
)))
74 ;; regression test: compiler macro not quoting the type in the
75 ;; resulting mem-ref form. The compiler macro on foreign-slot-value
76 ;; is not guaranteed to be expanded though.
78 (defctype my-int
:int
)
79 (defcstruct s5
(a my-int
))
82 (with-foreign-object (s 's5
)
83 (setf (foreign-slot-value s
's5
'a
) 42)
84 (foreign-slot-value s
's5
'a
))
87 ;;;# Structs with type translators
89 (defcstruct struct-string
92 (deftest struct.string
.1
93 (with-foreign-object (ptr 'struct-string
)
94 (with-foreign-slots ((s) ptr struct-string
)
95 (setf s
"So long and thanks for all the fish!")
97 "So long and thanks for all the fish!")
99 (deftest struct.string
.2
100 (with-foreign-object (ptr 'struct-string
)
101 (setf (foreign-slot-value ptr
'struct-string
's
) "Cha")
102 (foreign-slot-value ptr
'struct-string
's
))
105 ;;;# Structure Alignment Tests
107 ;;; See libtest.c and types.lisp for some comments about alignments.
116 (defcvar "the_s_s_ch" s-s-ch
)
118 (deftest struct.alignment
.1
119 (list 'a-char
(foreign-slot-value
120 (foreign-slot-value *the-s-s-ch
* 's-s-ch
'a-s-ch
)
122 'another-char
(foreign-slot-value *the-s-s-ch
* 's-s-ch
'another-char
))
123 (a-char 1 another-char
2))
131 (defcstruct s-s-short
132 (yet-another-char :char
)
135 (defcvar "the_s_s_short" s-s-short
)
137 (deftest struct.alignment
.2
138 (with-foreign-slots ((yet-another-char a-s-short
) *the-s-s-short
* s-s-short
)
139 (with-foreign-slots ((a-char another-char a-short
) a-s-short s-short
)
141 'another-char another-char
143 'yet-another-char yet-another-char
)))
144 (a-char 1 another-char
2 a-short
3 yet-another-char
4))
150 (another-char :char
))
152 (defcstruct s-s-double
153 (yet-another-char :char
)
154 (a-s-double s-double
)
157 (defcvar "the_s_s_double" s-s-double
)
159 (deftest struct.alignment
.3
161 ((yet-another-char a-s-double a-short
) *the-s-s-double
* s-s-double
)
162 (with-foreign-slots ((a-char a-double another-char
) a-s-double s-double
)
165 'another-char another-char
166 'yet-another-char yet-another-char
168 (a-char 1 a-double
2.0d0 another-char
3 yet-another-char
4 a-short
5))
171 (defcstruct s-s-s-double
172 (another-short :short
)
173 (a-s-s-double s-s-double
)
176 (defcvar "the_s_s_s_double" s-s-s-double
)
178 (deftest struct.alignment
.4
180 ((another-short a-s-s-double last-char
) *the-s-s-s-double
* s-s-s-double
)
182 ((yet-another-char a-s-double a-short
) a-s-s-double s-s-double
)
183 (with-foreign-slots ((a-char a-double another-char
) a-s-double s-double
)
186 'another-char another-char
187 'yet-another-char yet-another-char
189 'another-short another-short
190 'last-char last-char
))))
191 (a-char 1 a-double
2.0d0 another-char
3 yet-another-char
4 a-short
5
192 another-short
6 last-char
7))
195 (defcstruct s-double2
199 (defcstruct s-s-double2
201 (a-s-double2 s-double2
)
202 (another-short :short
))
204 (defcvar "the_s_s_double2" s-s-double2
)
206 (deftest struct.alignment
.5
208 ((a-char a-s-double2 another-short
) *the-s-s-double2
* s-s-double2
)
209 (with-foreign-slots ((a-double a-short
) a-s-double2 s-double2
)
210 (list 'a-double a-double
213 'another-short another-short
)))
214 (a-double 1.0d0 a-short
2 a-char
3 another-short
4))
216 (defcstruct s-long-long
217 (a-long-long :long-long
)
220 (defcstruct s-s-long-long
222 (a-s-long-long s-long-long
)
223 (another-short :short
))
225 (defcvar "the_s_s_long_long" s-s-long-long
)
227 (deftest struct.alignment
.6
229 ((a-char a-s-long-long another-short
) *the-s-s-long-long
* s-s-long-long
)
230 (with-foreign-slots ((a-long-long a-short
) a-s-long-long s-long-long
)
231 (list 'a-long-long a-long-long
234 'another-short another-short
)))
235 (a-long-long 1 a-short
2 a-char
3 another-short
4))
237 (defcstruct s-s-double3
238 (a-s-double2 s-double2
)
239 (another-short :short
))
241 (defcstruct s-s-s-double3
242 (a-s-s-double3 s-s-double3
)
245 (defcvar "the_s_s_s_double3" s-s-s-double3
)
247 (deftest struct.alignment
.7
248 (with-foreign-slots ((a-s-s-double3 a-char
) *the-s-s-s-double3
* s-s-s-double3
)
249 (with-foreign-slots ((a-s-double2 another-short
) a-s-s-double3 s-s-double3
)
250 (with-foreign-slots ((a-double a-short
) a-s-double2 s-double2
)
251 (list 'a-double a-double
253 'another-short another-short
255 (a-double 1.0d0 a-short
2 another-short
3 a-char
4))
258 (defcstruct empty-struct
)
260 (defcstruct with-empty-struct
264 ;; commented out this test because an empty struct is not valid/standard C
265 ;; left the struct declarations anyway because they should be handled
268 ; (defcvar "the_with_empty_struct" with-empty-struct)
270 ; (deftest struct.alignment.5
271 ; (with-foreign-slots ((foo an-int) *the-with-empty-struct* with-empty-struct)
276 ;; regression test, setf-ing nested foreign-slot-value forms
277 ;; the setf expander used to return a bogus getter
285 (deftest struct.nested-setf
286 (with-foreign-object (an-s2 's2
)
287 (setf (foreign-slot-value (foreign-slot-value an-s2
's2
'an-s1
)
290 (foreign-slot-value (foreign-slot-value an-s2
's2
'an-s1
)
294 ;; regression test, some Lisps were returning 4 instead of 8 for
295 ;; (foreign-type-alignment :unsigned-long-long) on darwin/ppc32
297 (defcstruct s-unsigned-long-long
298 (an-unsigned-long-long :unsigned-long-long
)
301 (defcstruct s-s-unsigned-long-long
303 (a-s-unsigned-long-long s-unsigned-long-long
)
304 (another-short :short
))
306 (defcvar "the_s_s_unsigned_long_long" s-s-unsigned-long-long
)
308 (deftest struct.alignment
.8
310 ((a-char a-s-unsigned-long-long another-short
)
311 *the-s-s-unsigned-long-long
* s-s-unsigned-long-long
)
312 (with-foreign-slots ((an-unsigned-long-long a-short
)
313 a-s-unsigned-long-long s-unsigned-long-long
)
314 (list 'an-unsigned-long-long an-unsigned-long-long
317 'another-short another-short
)))
318 (an-unsigned-long-long 1 a-short
2 a-char
3 another-short
4))
320 ;;;# C Struct Wrappers
322 (define-c-struct-wrapper timeval
())
324 (define-c-struct-wrapper (timeval2 timeval
) ()
327 (defmacro with-example-timeval
(var &body body
)
328 `(with-foreign-object (,var
'timeval
)
329 (with-foreign-slots ((tv-secs tv-usecs
) ,var timeval
)
330 (setf tv-secs
42 tv-usecs
1984)
333 (deftest struct-wrapper
.1
334 (with-example-timeval ptr
335 (let ((obj (make-instance 'timeval
:pointer ptr
)))
336 (values (timeval-tv-secs obj
)
337 (timeval-tv-usecs obj
))))
340 (deftest struct-wrapper
.2
341 (with-example-timeval ptr
342 (let ((obj (make-instance 'timeval2
:pointer ptr
)))
343 (timeval2-tv-secs obj
)))