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))
217 #-cffi-features
:no-long-long
219 (defcstruct s-long-long
220 (a-long-long :long-long
)
223 (defcstruct s-s-long-long
225 (a-s-long-long s-long-long
)
226 (another-short :short
))
228 (defcvar "the_s_s_long_long" s-s-long-long
)
230 (deftest struct.alignment
.6
232 ((a-char a-s-long-long another-short
) *the-s-s-long-long
* s-s-long-long
)
233 (with-foreign-slots ((a-long-long a-short
) a-s-long-long s-long-long
)
234 (list 'a-long-long a-long-long
237 'another-short another-short
)))
238 (a-long-long 1 a-short
2 a-char
3 another-short
4)))
241 (defcstruct s-s-double3
242 (a-s-double2 s-double2
)
243 (another-short :short
))
245 (defcstruct s-s-s-double3
246 (a-s-s-double3 s-s-double3
)
249 (defcvar "the_s_s_s_double3" s-s-s-double3
)
251 (deftest struct.alignment
.7
252 (with-foreign-slots ((a-s-s-double3 a-char
) *the-s-s-s-double3
* s-s-s-double3
)
253 (with-foreign-slots ((a-s-double2 another-short
) a-s-s-double3 s-s-double3
)
254 (with-foreign-slots ((a-double a-short
) a-s-double2 s-double2
)
255 (list 'a-double a-double
257 'another-short another-short
259 (a-double 1.0d0 a-short
2 another-short
3 a-char
4))
262 (defcstruct empty-struct
)
264 (defcstruct with-empty-struct
268 ;; commented out this test because an empty struct is not valid/standard C
269 ;; left the struct declarations anyway because they should be handled
272 ; (defcvar "the_with_empty_struct" with-empty-struct)
274 ; (deftest struct.alignment.5
275 ; (with-foreign-slots ((foo an-int) *the-with-empty-struct* with-empty-struct)
280 ;; regression test, setf-ing nested foreign-slot-value forms
281 ;; the setf expander used to return a bogus getter
289 (deftest struct.nested-setf
290 (with-foreign-object (an-s2 's2
)
291 (setf (foreign-slot-value (foreign-slot-value an-s2
's2
'an-s1
)
294 (foreign-slot-value (foreign-slot-value an-s2
's2
'an-s1
)
298 ;; regression test, some Lisps were returning 4 instead of 8 for
299 ;; (foreign-type-alignment :unsigned-long-long) on darwin/ppc32
301 #-cffi-features
:no-long-long
303 (defcstruct s-unsigned-long-long
304 (an-unsigned-long-long :unsigned-long-long
)
307 (defcstruct s-s-unsigned-long-long
309 (a-s-unsigned-long-long s-unsigned-long-long
)
310 (another-short :short
))
312 (defcvar "the_s_s_unsigned_long_long" s-s-unsigned-long-long
)
314 (deftest struct.alignment
.8
316 ((a-char a-s-unsigned-long-long another-short
)
317 *the-s-s-unsigned-long-long
* s-s-unsigned-long-long
)
318 (with-foreign-slots ((an-unsigned-long-long a-short
)
319 a-s-unsigned-long-long s-unsigned-long-long
)
320 (list 'an-unsigned-long-long an-unsigned-long-long
323 'another-short another-short
)))
324 (an-unsigned-long-long 1 a-short
2 a-char
3 another-short
4)))