Add support for ECL long double
[cffi.git] / tests / struct.lisp
blob1fd73ba0ab9f0f62a94eb30bbca43b624c04ac1a
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; struct.lisp --- Foreign structure type tests.
4 ;;;
5 ;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
6 ;;; Copyright (C) 2005-2011, Luis Oliveira <loliveira@common-lisp.net>
7 ;;;
8 ;;; Permission is hereby granted, free of charge, to any person
9 ;;; obtaining a copy of this software and associated documentation
10 ;;; files (the "Software"), to deal in the Software without
11 ;;; restriction, including without limitation the rights to use, copy,
12 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
13 ;;; of the Software, and to permit persons to whom the Software is
14 ;;; furnished to do so, subject to the following conditions:
15 ;;;
16 ;;; The above copyright notice and this permission notice shall be
17 ;;; included in all copies or substantial portions of the Software.
18 ;;;
19 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
20 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
21 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
22 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
23 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
24 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
25 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
26 ;;; DEALINGS IN THE SOFTWARE.
27 ;;;
29 (in-package #:cffi-tests)
31 (defcstruct timeval
32 (tv-secs :long)
33 (tv-usecs :long))
35 (defparameter *timeval-size* (* 2 (max (foreign-type-size :long)
36 (foreign-type-alignment :long))))
38 ;;;# Basic Structure Tests
40 (deftest struct.1
41 (- (foreign-type-size 'timeval) *timeval-size*)
44 (deftest struct.2
45 (with-foreign-object (tv 'timeval)
46 (setf (foreign-slot-value tv 'timeval 'tv-secs) 0)
47 (setf (foreign-slot-value tv 'timeval 'tv-usecs) 1)
48 (values (foreign-slot-value tv 'timeval 'tv-secs)
49 (foreign-slot-value tv 'timeval 'tv-usecs)))
50 0 1)
52 (deftest struct.3
53 (with-foreign-object (tv 'timeval)
54 (with-foreign-slots ((tv-secs tv-usecs) tv timeval)
55 (setf tv-secs 100 tv-usecs 200)
56 (values tv-secs tv-usecs)))
57 100 200)
59 ;; regression test: accessing a struct through a typedef
61 (defctype xpto (:struct timeval))
63 (deftest struct.4
64 (with-foreign-object (tv 'xpto)
65 (setf (foreign-slot-value tv 'xpto 'tv-usecs) 1)
66 (values (foreign-slot-value tv 'xpto 'tv-usecs)
67 (foreign-slot-value tv 'timeval 'tv-usecs)))
68 1 1)
70 (deftest struct.names
71 (sort (foreign-slot-names 'xpto) #'<
72 :key (lambda (x) (foreign-slot-offset 'xpto x)))
73 (tv-secs tv-usecs))
75 ;; regression test: compiler macro not quoting the type in the
76 ;; resulting mem-ref form. The compiler macro on foreign-slot-value
77 ;; is not guaranteed to be expanded though.
79 (defctype my-int :int)
80 (defcstruct s5 (a my-int))
82 (deftest struct.5
83 (with-foreign-object (s 's5)
84 (setf (foreign-slot-value s 's5 'a) 42)
85 (foreign-slot-value s 's5 'a))
86 42)
88 ;;;# Structs with type translators
90 (defcstruct struct-string
91 (s :string))
93 (deftest struct.string.1
94 (with-foreign-object (ptr 'struct-string)
95 (with-foreign-slots ((s) ptr struct-string)
96 (setf s "So long and thanks for all the fish!")
97 s))
98 "So long and thanks for all the fish!")
100 (deftest struct.string.2
101 (with-foreign-object (ptr 'struct-string)
102 (setf (foreign-slot-value ptr 'struct-string 's) "Cha")
103 (foreign-slot-value ptr 'struct-string 's))
104 "Cha")
106 ;;;# Structure Alignment Tests
108 ;;; See libtest.c and types.lisp for some comments about alignments.
110 (defcstruct s-ch
111 (a-char :char))
113 (defctype s-ch (:struct s-ch))
115 (defcstruct s-s-ch
116 (another-char :char)
117 (a-s-ch s-ch))
119 (defctype s-s-ch (:struct s-s-ch))
121 (defcvar "the_s_s_ch" s-s-ch)
123 (deftest struct.alignment.1
124 (list 'a-char (foreign-slot-value
125 (foreign-slot-pointer *the-s-s-ch* 's-s-ch 'a-s-ch)
126 's-ch 'a-char)
127 'another-char (foreign-slot-value *the-s-s-ch* 's-s-ch 'another-char))
128 (a-char 1 another-char 2))
131 (defcstruct s-short
132 (a-char :char)
133 (another-char :char)
134 (a-short :short))
136 (defctype s-short (:struct s-short))
138 (defcstruct s-s-short
139 (yet-another-char :char)
140 (a-s-short s-short))
142 (defctype s-s-short (:struct s-s-short))
144 (defcvar "the_s_s_short" s-s-short)
146 (deftest struct.alignment.2
147 (with-foreign-slots ((yet-another-char a-s-short) *the-s-s-short* s-s-short)
148 (with-foreign-slots ((a-char another-char a-short) a-s-short s-short)
149 (list 'a-char a-char
150 'another-char another-char
151 'a-short a-short
152 'yet-another-char yet-another-char)))
153 (a-char 1 another-char 2 a-short 3 yet-another-char 4))
156 (defcstruct s-double
157 (a-char :char)
158 (a-double :double)
159 (another-char :char))
161 (defctype s-double (:struct s-double))
163 (defcstruct s-s-double
164 (yet-another-char :char)
165 (a-s-double s-double)
166 (a-short :short))
168 (defctype s-s-double (:struct s-s-double))
170 (defcvar "the_s_s_double" s-s-double)
172 (deftest struct.alignment.3
173 (with-foreign-slots
174 ((yet-another-char a-s-double a-short) *the-s-s-double* s-s-double)
175 (with-foreign-slots ((a-char a-double another-char) a-s-double s-double)
176 (list 'a-char a-char
177 'a-double a-double
178 'another-char another-char
179 'yet-another-char yet-another-char
180 'a-short a-short)))
181 (a-char 1 a-double 2.0d0 another-char 3 yet-another-char 4 a-short 5))
184 (defcstruct s-s-s-double
185 (another-short :short)
186 (a-s-s-double s-s-double)
187 (last-char :char))
189 (defctype s-s-s-double (:struct s-s-s-double))
191 (defcvar "the_s_s_s_double" s-s-s-double)
193 (deftest struct.alignment.4
194 (with-foreign-slots
195 ((another-short a-s-s-double last-char) *the-s-s-s-double* s-s-s-double)
196 (with-foreign-slots
197 ((yet-another-char a-s-double a-short) a-s-s-double s-s-double)
198 (with-foreign-slots ((a-char a-double another-char) a-s-double s-double)
199 (list 'a-char a-char
200 'a-double a-double
201 'another-char another-char
202 'yet-another-char yet-another-char
203 'a-short a-short
204 'another-short another-short
205 'last-char last-char))))
206 (a-char 1 a-double 2.0d0 another-char 3 yet-another-char 4 a-short 5
207 another-short 6 last-char 7))
210 (defcstruct s-double2
211 (a-double :double)
212 (a-short :short))
214 (defctype s-double2 (:struct s-double2))
216 (defcstruct s-s-double2
217 (a-char :char)
218 (a-s-double2 s-double2)
219 (another-short :short))
221 (defctype s-s-double2 (:struct s-s-double2))
223 (defcvar "the_s_s_double2" s-s-double2)
225 (deftest struct.alignment.5
226 (with-foreign-slots
227 ((a-char a-s-double2 another-short) *the-s-s-double2* s-s-double2)
228 (with-foreign-slots ((a-double a-short) a-s-double2 s-double2)
229 (list 'a-double a-double
230 'a-short a-short
231 'a-char a-char
232 'another-short another-short)))
233 (a-double 1.0d0 a-short 2 a-char 3 another-short 4))
235 (defcstruct s-long-long
236 (a-long-long :long-long)
237 (a-short :short))
239 (defctype s-long-long (:struct s-long-long))
241 (defcstruct s-s-long-long
242 (a-char :char)
243 (a-s-long-long s-long-long)
244 (another-short :short))
246 (defctype s-s-long-long (:struct s-s-long-long))
248 (defcvar "the_s_s_long_long" s-s-long-long)
250 (deftest struct.alignment.6
251 (with-foreign-slots
252 ((a-char a-s-long-long another-short) *the-s-s-long-long* s-s-long-long)
253 (with-foreign-slots ((a-long-long a-short) a-s-long-long s-long-long)
254 (list 'a-long-long a-long-long
255 'a-short a-short
256 'a-char a-char
257 'another-short another-short)))
258 (a-long-long 1 a-short 2 a-char 3 another-short 4))
260 (defcstruct s-s-double3
261 (a-s-double2 s-double2)
262 (another-short :short))
264 (defctype s-s-double3 (:struct s-s-double3))
266 (defcstruct s-s-s-double3
267 (a-s-s-double3 s-s-double3)
268 (a-char :char))
270 (defctype s-s-s-double3 (:struct s-s-s-double3))
272 (defcvar "the_s_s_s_double3" s-s-s-double3)
274 (deftest struct.alignment.7
275 (with-foreign-slots ((a-s-s-double3 a-char) *the-s-s-s-double3* s-s-s-double3)
276 (with-foreign-slots ((a-s-double2 another-short) a-s-s-double3 s-s-double3)
277 (with-foreign-slots ((a-double a-short) a-s-double2 s-double2)
278 (list 'a-double a-double
279 'a-short a-short
280 'another-short another-short
281 'a-char a-char))))
282 (a-double 1.0d0 a-short 2 another-short 3 a-char 4))
285 (defcstruct empty-struct)
287 (defctype empty-struct (:struct empty-struct))
289 (defcstruct with-empty-struct
290 (foo empty-struct)
291 (an-int :int))
293 ;; commented out this test because an empty struct is not valid/standard C
294 ;; left the struct declarations anyway because they should be handled
295 ;; gracefuly anyway.
297 ; (defcvar "the_with_empty_struct" with-empty-struct)
299 ; (deftest struct.alignment.5
300 ; (with-foreign-slots ((foo an-int) *the-with-empty-struct* with-empty-struct)
301 ; an-int)
302 ; 42)
305 ;; regression test, setf-ing nested foreign-slot-value forms
306 ;; the setf expander used to return a bogus getter
308 (defcstruct s1
309 (an-int :int))
311 (defctype s1 (:struct s1))
313 (defcstruct s2
314 (an-s1 s1))
316 (defctype s2 (:struct s2))
318 (deftest struct.nested-setf
319 (with-foreign-object (an-s2 's2)
320 (setf (foreign-slot-value (foreign-slot-value an-s2 's2 'an-s1)
321 's1 'an-int)
322 1984)
323 (foreign-slot-value (foreign-slot-value an-s2 's2 'an-s1)
324 's1 'an-int))
325 1984)
327 ;; regression test, some Lisps were returning 4 instead of 8 for
328 ;; (foreign-type-alignment :unsigned-long-long) on darwin/ppc32
330 (defcstruct s-unsigned-long-long
331 (an-unsigned-long-long :unsigned-long-long)
332 (a-short :short))
334 (defctype s-unsigned-long-long (:struct s-unsigned-long-long))
336 (defcstruct s-s-unsigned-long-long
337 (a-char :char)
338 (a-s-unsigned-long-long s-unsigned-long-long)
339 (another-short :short))
341 (defctype s-s-unsigned-long-long (:struct s-s-unsigned-long-long))
343 (defcvar "the_s_s_unsigned_long_long" s-s-unsigned-long-long)
345 (deftest struct.alignment.8
346 (with-foreign-slots
347 ((a-char a-s-unsigned-long-long another-short)
348 *the-s-s-unsigned-long-long* s-s-unsigned-long-long)
349 (with-foreign-slots ((an-unsigned-long-long a-short)
350 a-s-unsigned-long-long s-unsigned-long-long)
351 (list 'an-unsigned-long-long an-unsigned-long-long
352 'a-short a-short
353 'a-char a-char
354 'another-short another-short)))
355 (an-unsigned-long-long 1 a-short 2 a-char 3 another-short 4))
357 ;;;# C Struct Wrappers
359 (define-c-struct-wrapper timeval ())
361 (define-c-struct-wrapper (timeval2 (:struct timeval)) ()
362 (tv-secs))
364 (defmacro with-example-timeval (var &body body)
365 `(with-foreign-object (,var 'timeval)
366 (with-foreign-slots ((tv-secs tv-usecs) ,var timeval)
367 (setf tv-secs 42 tv-usecs 1984)
368 ,@body)))
370 (deftest struct-wrapper.1
371 (with-example-timeval ptr
372 (let ((obj (make-instance 'timeval :pointer ptr)))
373 (values (timeval-tv-secs obj)
374 (timeval-tv-usecs obj))))
375 42 1984)
377 (deftest struct-wrapper.2
378 (with-example-timeval ptr
379 (let ((obj (make-instance 'timeval2 :pointer ptr)))
380 (timeval2-tv-secs obj)))
383 ;;;# Structures as Values
385 (defcstruct (struct-pair :class pair)
386 (a :int)
387 (b :int))
389 (defctype struct-pair-typedef1 (:struct struct-pair))
390 (defctype struct-pair-typedef2 (:pointer (:struct struct-pair)))
392 (deftest struct.unparse.1
393 (mapcar (alexandria:compose #'cffi::unparse-type #'cffi::parse-type)
394 '(struct-pair
395 (:struct struct-pair)
396 struct-pair-typedef1
397 struct-pair-typedef2))
398 (struct-pair
399 (:struct struct-pair)
400 struct-pair-typedef1
401 struct-pair-typedef2))
403 (deftest struct.canonicalize.1
404 (mapcar #'cffi::canonicalize-foreign-type
405 '(struct-pair
406 (:struct struct-pair)
407 struct-pair-typedef1
408 struct-pair-typedef2))
409 (:pointer
410 (:struct struct-pair)
411 (:struct struct-pair)
412 :pointer))
414 (deftest struct.canonicalize.2
415 (mapcar #'cffi::canonicalize-foreign-type
416 '(struct-pair
417 (:struct struct-pair)
418 struct-pair-typedef1
419 struct-pair-typedef2))
420 (:pointer
421 (:struct struct-pair)
422 (:struct struct-pair)
423 :pointer))
425 (defmethod translate-from-foreign (pointer (type pair))
426 (with-foreign-slots ((a b) pointer (:struct struct-pair))
427 (cons a b)))
429 (defmethod translate-into-foreign-memory (object (type pair) pointer)
430 (with-foreign-slots ((a b) pointer (:struct struct-pair))
431 (setf a (car object)
432 b (cdr object))))
434 (defmethod translate-to-foreign (object (type pair))
435 (let ((p (foreign-alloc '(:struct struct-pair))))
436 (translate-into-foreign-memory object type p)
437 (values p t)))
439 (defmethod free-translated-object (pointer (type pair) freep)
440 (when freep
441 (foreign-free pointer)))
443 (deftest struct-values.translation.1
444 (multiple-value-bind (p freep)
445 (convert-to-foreign '(1 . 2) 'struct-pair)
446 (assert freep)
447 (unwind-protect
448 (convert-from-foreign p 'struct-pair)
449 (free-converted-object p 'struct-pair freep)))
450 (1 . 2))
452 (defcfun "pair_pointer_sum" :int
453 (p (:pointer (:struct struct-pair))))
455 #+#:pointer-translation-not-yet-implemented
456 (deftest struct-values.translation.2
457 (pair-pointer-sum '(1 . 2))
460 ;;; should the return type be something along the lines of
461 ;;; (:pointer (:struct pair) :free t)?
462 ;;; LMH: error on ":free t" option?
463 (defcfun "alloc_pair" (:pointer (:struct struct-pair))
464 (a :int)
465 (b :int))
467 ;; bogus: doesn't free() pointer.
468 #+#:pointer-translation-not-yet-implemented
469 (deftest struct-values.translation.3
470 (alloc-pair 1 2)
471 (1 . 2))
473 (deftest struct-values.translation.mem-ref.1
474 (with-foreign-object (p '(:struct struct-pair))
475 (setf (mem-ref p '(:struct struct-pair)) '(1 . 2))
476 (with-foreign-slots ((a b) p (:struct struct-pair))
477 (values (mem-ref p '(:struct struct-pair))
479 b)))
480 (1 . 2)
484 (deftest struct-values.translation.mem-aref.1
485 (with-foreign-object (p '(:struct struct-pair) 2)
486 (setf (mem-aref p '(:struct struct-pair) 0) '(1 . 2)
487 (mem-aref p '(:struct struct-pair) 1) '(3 . 4))
488 (values (mem-aref p '(:struct struct-pair) 0)
489 (mem-aref p '(:struct struct-pair) 1)))
490 (1 . 2)
491 (3 . 4))
493 (defcstruct (struct-pair-default-translate)
494 (a :int)
495 (b :int))
497 (deftest struct-values-default.translation.mem-ref.1
498 (with-foreign-object (p '(:struct struct-pair-default-translate))
499 (setf (mem-ref p '(:struct struct-pair-default-translate)) '(a 1 b 2))
500 (with-foreign-slots ((a b) p (:struct struct-pair-default-translate))
501 (let ((plist (mem-ref p '(:struct struct-pair-default-translate))))
502 (values (getf plist 'a)
503 (getf plist 'b)
505 b))))
511 (defcstruct (struct-pair+double)
512 (pr (:struct struct-pair-default-translate))
513 (dbl :double))
515 (deftest struct-values-default.translation.mem-ref.2
516 (with-foreign-object (p '(:struct struct-pair+double))
517 (setf (mem-ref p '(:struct struct-pair+double)) '(pr (a 4 b 5) dbl 2.5d0))
518 (with-foreign-slots ((pr dbl) p (:struct struct-pair+double))
519 (let ((plist (mem-ref p '(:struct struct-pair+double))))
520 (values (getf (getf plist 'pr) 'a)
521 (getf (getf plist 'pr) 'b)
522 (getf plist 'dbl)))))
525 2.5d0)
527 (defcstruct (struct-pair+1 :class pair+1)
528 (p (:pointer (:struct struct-pair)))
529 (c :int))
531 (defctype struct-pair+1 (:struct struct-pair+1))
533 (defmethod translate-from-foreign (pointer (type pair+1))
534 (with-foreign-slots ((p c) pointer struct-pair+1)
535 (cons p c)))
537 (defmethod translate-into-foreign-memory (object (type pair+1) pointer)
538 (with-foreign-slots ((c) pointer struct-pair+1)
539 (convert-into-foreign-memory (car object)
540 'struct-pair
541 (foreign-slot-pointer pointer
542 'struct-pair+1
543 'p))
544 (setf c (cdr object))))
546 (defmethod translate-to-foreign (object (type pair+1))
547 (let ((p (foreign-alloc 'struct-pair+1)))
548 (translate-into-foreign-memory object type p)
549 (values p t)))
551 (defmethod free-translated-object (pointer (type pair+1) freep)
552 (when freep
553 (foreign-free pointer)))
555 #+#:pointer-translation-not-yet-implemented
556 (deftest struct-values.translation.ppo.1
557 (multiple-value-bind (p freep)
558 (convert-to-foreign '((1 . 2) . 3) 'struct-pair+1)
559 (assert freep)
560 (unwind-protect
561 (convert-from-foreign p 'struct-pair+1)
562 (free-converted-object p 'struct-pair+1 freep)))
563 ((1 . 2) . 3))
565 #+#:unimplemented
566 (defcfun "pair_plus_one_sum" :int
567 (p (:struct pair+1)))
569 #+#:unused
570 (defcfun "pair_plus_one_pointer_sum" :int
571 (p (:pointer (:struct struct-pair+1))))
573 #+#:pointer-translation-not-yet-implemented
574 (deftest struct-values.translation.ppo.2
575 (pair-plus-one-pointer-sum '((1 . 2) . 3))
578 (defcfun "make_pair_plus_one" (:struct struct-pair+1)
579 (a :int)
580 (b :int)
581 (c :int))
583 (defcfun "alloc_pair_plus_one" (:pointer (:struct struct-pair+1))
584 (a :int)
585 (b :int)
586 (c :int))
588 ;; bogus: doesn't free() pointer.
589 #+#:pointer-translation-not-yet-implemented
590 (deftest struct-values.translation.ppo.3
591 (alloc-pair-plus-one 1 2 3)
592 ((1 . 2) . 3))
594 (defcfun "pair_sum" :int
595 (p (:struct struct-pair)))
597 (defcfun "make_pair" (:struct struct-pair)
598 (a :int)
599 (b :int))
601 (deftest struct-values.fn.1
602 (pair-sum '(-1 . 2))
605 (deftest struct-values.fn.2
606 (make-pair 13 17)
607 (13 . 17))
609 (defcstruct single-byte-struct
610 (a :uint8))
612 (deftest bare-struct-types.1
613 (eql (foreign-type-size 'single-byte-struct)
614 (foreign-type-size '(:struct single-byte-struct)))
617 (defctype single-byte-struct-alias (:struct single-byte-struct))
619 (deftest bare-struct-types.2
620 (eql (foreign-type-size 'single-byte-struct-alias)
621 (foreign-type-size '(:struct single-byte-struct)))
624 ;;; Old-style access to inner structure fields.
626 (defcstruct inner-struct (x :int))
627 (defcstruct old-style-outer (inner inner-struct))
628 (defcstruct new-style-outer (inner (:struct inner-struct)))
630 (deftest old-style-struct-access
631 (with-foreign-object (s '(:struct old-style-outer))
632 (let ((inner-ptr (foreign-slot-pointer s 'old-style-outer 'inner)))
633 (setf (foreign-slot-value inner-ptr 'inner-struct 'x) 42))
634 (assert (pointerp (foreign-slot-value s 'old-style-outer 'inner)))
635 (foreign-slot-value (foreign-slot-value s 'old-style-outer 'inner)
636 'inner-struct 'x))
639 (deftest new-style-struct-access
640 (with-foreign-object (s '(:struct new-style-outer))
641 (let ((inner-ptr (foreign-slot-pointer s 'new-style-outer 'inner)))
642 (setf (foreign-slot-value inner-ptr 'inner-struct 'x) 42))
643 (foreign-slot-value s 'new-style-outer 'inner))
644 (x 42))
646 ;;; regression test: setting the value of aggregate slots.
648 (defcstruct aggregate-struct
649 (x :int)
650 (pair (:struct struct-pair))
651 (y :int))
653 (deftest set-aggregate-struct-slot
654 (with-foreign-objects ((pair-struct '(:struct struct-pair))
655 (aggregate-struct '(:struct aggregate-struct)))
656 (with-foreign-slots ((a b) pair-struct (:struct struct-pair))
657 (setf a 1 b 2)
658 (with-foreign-slots ((x pair y) aggregate-struct (:struct aggregate-struct))
659 (setf x 42 y 42)
660 (setf pair pair-struct)
661 (values x pair y))))
663 (1 . 2)
666 ;; TODO this needs to go through compile-file to exhibit the error
667 ;; ("don't know how to dump #<CFFI::AGGREGATE-STRUCT-SLOT>"), but
668 ;; there's no support for that, so let's leave it at toplevel here.
669 (defcstruct (aggregate-struct.acc :conc-name acc-)
670 (x :int)
671 (pair (:struct struct-pair))
672 (y :int))
674 (deftest set-aggregate-struct-slot.acc
675 (with-foreign-objects ((pair-struct '(:struct struct-pair))
676 (aggregate-struct '(:struct aggregate-struct)))
677 (with-foreign-slots ((a b) pair-struct (:struct struct-pair))
678 (setf a 1 b 2)
679 (setf (acc-x aggregate-struct) 42)
680 (setf (acc-y aggregate-struct) 42)
681 (setf (acc-pair aggregate-struct) pair-struct)
682 (values (acc-x aggregate-struct)
683 (acc-pair aggregate-struct)
684 (acc-y aggregate-struct))))
686 (1 . 2)
689 ;; Test with-foreign-slots :pointer access and new binding syntax
690 (defcstruct struct.wfs
691 (tv-secs :long)
692 (tv-usecs :long))
694 (deftest struct.with-foreign-slots.1
695 (with-foreign-object (tv 'struct.wfs)
696 (with-foreign-slots (((secs tv-secs) (usecs tv-usecs)) tv timeval)
697 (setf secs 100 usecs 200)
698 (values secs usecs)))
699 100 200)
701 (deftest struct.with-foreign-slots.2
702 (with-foreign-object (tv 'struct.wfs)
703 (with-foreign-slots (((:pointer tv-secs) (:pointer tv-usecs)
704 (secs tv-secs) (usecs tv-usecs))
705 tv timeval)
706 (setf secs 100 usecs 200)
707 (values (mem-ref tv-secs :long) (mem-ref tv-usecs :long))))
708 100 200)
710 (deftest struct.with-foreign-slots.3
711 (with-foreign-object (tv 'struct.wfs)
712 (with-foreign-slots (((psecs :pointer tv-secs) (pusecs :pointer tv-usecs) (secs tv-secs) (usecs tv-usecs)) tv timeval)
713 (setf secs 100 usecs 200)
714 (values (mem-ref psecs :long) (mem-ref pusecs :long))))
715 100 200)
717 ;;; regression test: if slots use :offset, struct should still be big
718 ;;; enough to hold all of the slots.
719 (defcstruct struct.offsets
720 (a :int32 :offset 0 :count 4)
721 (b :int32)
722 (c :uint8) ;; end at odd offset to check final padding
723 (d :uint8 :offset 1)
724 (e :uint8) ;; offsets increase normally after an explicit offset
725 (f :uint8)
726 (g :uint8 :offset 6)
727 (h :uint32) ;; offset is aligned without explicit offset
728 (i :uint32 :offset 3) ;; explicit offset isn't aligned
729 (j :uint32 :offset 0)) ;; ending in middle shouldn't truncate total size
731 (deftest struct.offset.1
732 (foreign-type-size '(:struct struct.offsets))
735 ;; Add some tests for :offset in general
736 (deftest struct.offset.2
737 (mapcar (lambda (slot)
738 (foreign-slot-offset '(:struct struct.offsets) slot))
739 '(a b c d e f g h i j))
740 (0 16 20 1 2 3 6 8 3 0))