Introduction
Introduction Statistics Contact Development Disclaimer Help
tstruct.lisp - clic - Clic is an command line interactive client for gopher wri…
git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
Log
Files
Refs
Tags
LICENSE
---
tstruct.lisp (21550B)
---
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; struct.lisp --- Foreign structure type tests.
4 ;;;
5 ;;; Copyright (C) 2005-2006, James Bielman <[email protected]>
6 ;;; Copyright (C) 2005-2011, Luis Oliveira <[email protected]>
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 ;;;
28
29 (in-package #:cffi-tests)
30
31 (defcstruct timeval
32 (tv-secs :long)
33 (tv-usecs :long))
34
35 (defparameter *timeval-size* (* 2 (max (foreign-type-size :long)
36 (foreign-type-alignment :long))))
37
38 ;;;# Basic Structure Tests
39
40 (deftest struct.1
41 (- (foreign-type-size 'timeval) *timeval-size*)
42 0)
43
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)
51
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)
58
59 ;; regression test: accessing a struct through a typedef
60
61 (defctype xpto (:struct timeval))
62
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)
69
70 (deftest struct.names
71 (sort (foreign-slot-names 'xpto) #'<
72 :key (lambda (x) (foreign-slot-offset 'xpto x)))
73 (tv-secs tv-usecs))
74
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.
78
79 (defctype my-int :int)
80 (defcstruct s5 (a my-int))
81
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)
87
88 ;;;# Structs with type translators
89
90 (defcstruct struct-string
91 (s :string))
92
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!")
99
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")
105
106 ;;;# Structure Alignment Tests
107 ;;;
108 ;;; See libtest.c and types.lisp for some comments about alignments.
109
110 (defcstruct s-ch
111 (a-char :char))
112
113 (defctype s-ch (:struct s-ch))
114
115 (defcstruct s-s-ch
116 (another-char :char)
117 (a-s-ch s-ch))
118
119 (defctype s-s-ch (:struct s-s-ch))
120
121 (defcvar "the_s_s_ch" s-s-ch)
122
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 'anothe…
128 (a-char 1 another-char 2))
129
130
131 (defcstruct s-short
132 (a-char :char)
133 (another-char :char)
134 (a-short :short))
135
136 (defctype s-short (:struct s-short))
137
138 (defcstruct s-s-short
139 (yet-another-char :char)
140 (a-s-short s-short))
141
142 (defctype s-s-short (:struct s-s-short))
143
144 (defcvar "the_s_s_short" s-s-short)
145
146 (deftest struct.alignment.2
147 (with-foreign-slots ((yet-another-char a-s-short) *the-s-s-short* s-…
148 (with-foreign-slots ((a-char another-char a-short) a-s-short s-sho…
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))
154
155
156 (defcstruct s-double
157 (a-char :char)
158 (a-double :double)
159 (another-char :char))
160
161 (defctype s-double (:struct s-double))
162
163 (defcstruct s-s-double
164 (yet-another-char :char)
165 (a-s-double s-double)
166 (a-short :short))
167
168 (defctype s-s-double (:struct s-s-double))
169
170 (defcvar "the_s_s_double" s-s-double)
171
172 (deftest struct.alignment.3
173 (with-foreign-slots
174 ((yet-another-char a-s-double a-short) *the-s-s-double* s-s-doub…
175 (with-foreign-slots ((a-char a-double another-char) a-s-double s-d…
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))
182
183
184 (defcstruct s-s-s-double
185 (another-short :short)
186 (a-s-s-double s-s-double)
187 (last-char :char))
188
189 (defctype s-s-s-double (:struct s-s-s-double))
190
191 (defcvar "the_s_s_s_double" s-s-s-double)
192
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…
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…
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))
208
209
210 (defcstruct s-double2
211 (a-double :double)
212 (a-short :short))
213
214 (defctype s-double2 (:struct s-double2))
215
216 (defcstruct s-s-double2
217 (a-char :char)
218 (a-s-double2 s-double2)
219 (another-short :short))
220
221 (defctype s-s-double2 (:struct s-s-double2))
222
223 (defcvar "the_s_s_double2" s-s-double2)
224
225 (deftest struct.alignment.5
226 (with-foreign-slots
227 ((a-char a-s-double2 another-short) *the-s-s-double2* s-s-double…
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))
234
235 (defcstruct s-long-long
236 (a-long-long :long-long)
237 (a-short :short))
238
239 (defctype s-long-long (:struct s-long-long))
240
241 (defcstruct s-s-long-long
242 (a-char :char)
243 (a-s-long-long s-long-long)
244 (another-short :short))
245
246 (defctype s-s-long-long (:struct s-s-long-long))
247
248 (defcvar "the_s_s_long_long" s-s-long-long)
249
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-lo…
253 (with-foreign-slots ((a-long-long a-short) a-s-long-long s-long-lo…
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))
259
260 (defcstruct s-s-double3
261 (a-s-double2 s-double2)
262 (another-short :short))
263
264 (defctype s-s-double3 (:struct s-s-double3))
265
266 (defcstruct s-s-s-double3
267 (a-s-s-double3 s-s-double3)
268 (a-char :char))
269
270 (defctype s-s-s-double3 (:struct s-s-s-double3))
271
272 (defcvar "the_s_s_s_double3" s-s-s-double3)
273
274 (deftest struct.alignment.7
275 (with-foreign-slots ((a-s-s-double3 a-char) *the-s-s-s-double3* s-s-…
276 (with-foreign-slots ((a-s-double2 another-short) a-s-s-double3 s-s…
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))
283
284
285 (defcstruct empty-struct)
286
287 (defctype empty-struct (:struct empty-struct))
288
289 (defcstruct with-empty-struct
290 (foo empty-struct)
291 (an-int :int))
292
293 ;; commented out this test because an empty struct is not valid/standard…
294 ;; left the struct declarations anyway because they should be handled
295 ;; gracefuly anyway.
296
297 ; (defcvar "the_with_empty_struct" with-empty-struct)
298 ;
299 ; (deftest struct.alignment.5
300 ; (with-foreign-slots ((foo an-int) *the-with-empty-struct* with-emp…
301 ; an-int)
302 ; 42)
303
304
305 ;; regression test, setf-ing nested foreign-slot-value forms
306 ;; the setf expander used to return a bogus getter
307
308 (defcstruct s1
309 (an-int :int))
310
311 (defctype s1 (:struct s1))
312
313 (defcstruct s2
314 (an-s1 s1))
315
316 (defctype s2 (:struct s2))
317
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)
326
327 ;; regression test, some Lisps were returning 4 instead of 8 for
328 ;; (foreign-type-alignment :unsigned-long-long) on darwin/ppc32
329
330 (defcstruct s-unsigned-long-long
331 (an-unsigned-long-long :unsigned-long-long)
332 (a-short :short))
333
334 (defctype s-unsigned-long-long (:struct s-unsigned-long-long))
335
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))
340
341 (defctype s-s-unsigned-long-long (:struct s-s-unsigned-long-long))
342
343 (defcvar "the_s_s_unsigned_long_long" s-s-unsigned-long-long)
344
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))
356
357 ;;;# C Struct Wrappers
358
359 (define-c-struct-wrapper timeval ())
360
361 (define-c-struct-wrapper (timeval2 (:struct timeval)) ()
362 (tv-secs))
363
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)))
369
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)
376
377 (deftest struct-wrapper.2
378 (with-example-timeval ptr
379 (let ((obj (make-instance 'timeval2 :pointer ptr)))
380 (timeval2-tv-secs obj)))
381 42)
382
383 ;;;# Structures as Values
384
385 (defcstruct (struct-pair :class pair)
386 (a :int)
387 (b :int))
388
389 (defctype struct-pair-typedef1 (:struct struct-pair))
390 (defctype struct-pair-typedef2 (:pointer (:struct struct-pair)))
391
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))
402
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))
413
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))
424
425 (defmethod translate-from-foreign (pointer (type pair))
426 (with-foreign-slots ((a b) pointer (:struct struct-pair))
427 (cons a b)))
428
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))))
433
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)))
438
439 (defmethod free-translated-object (pointer (type pair) freep)
440 (when freep
441 (foreign-free pointer)))
442
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))
451
452 (defcfun "pair_pointer_sum" :int
453 (p (:pointer (:struct struct-pair))))
454
455 #+#:pointer-translation-not-yet-implemented
456 (deftest struct-values.translation.2
457 (pair-pointer-sum '(1 . 2))
458 3)
459
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))
466
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))
472
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))
478 a
479 b)))
480 (1 . 2)
481 1
482 2)
483
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))
492
493 (defcstruct (struct-pair-default-translate :class pair-default)
494 (a :int)
495 (b :int))
496
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…
500 (with-foreign-slots ((a b) p (:struct struct-pair-default-translat…
501 (let ((plist (mem-ref p '(:struct struct-pair-default-translate)…
502 (values (getf plist 'a)
503 (getf plist 'b)
504 a
505 b))))
506 1
507 2
508 1
509 2)
510
511 (defcstruct (struct-pair+double :class pair+double)
512 (pr (:struct struct-pair-default-translate))
513 (dbl :double))
514
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…
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)))))
523 4
524 5
525 2.5d0)
526
527 (defcstruct (struct-pair+1 :class pair+1)
528 (p (:pointer (:struct struct-pair)))
529 (c :int))
530
531 (defctype struct-pair+1 (:struct struct-pair+1))
532
533 (defmethod translate-from-foreign (pointer (type pair+1))
534 (with-foreign-slots ((p c) pointer struct-pair+1)
535 (cons p c)))
536
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))))
545
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)))
550
551 (defmethod free-translated-object (pointer (type pair+1) freep)
552 (when freep
553 (foreign-free pointer)))
554
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))
564
565 #+#:unimplemented
566 (defcfun "pair_plus_one_sum" :int
567 (p (:struct pair+1)))
568
569 (defcfun "pair_plus_one_pointer_sum" :int
570 (p (:pointer (:struct struct-pair+1))))
571
572 #+#:pointer-translation-not-yet-implemented
573 (deftest struct-values.translation.ppo.2
574 (pair-plus-one-pointer-sum '((1 . 2) . 3))
575 6)
576
577 #+#:unimplemented
578 (defcfun "make_pair_plus_one" (:struct pair+1)
579 (a :int)
580 (b :int)
581 (c :int))
582
583 (defcfun "alloc_pair_plus_one" struct-pair+1
584 (a :int)
585 (b :int)
586 (c :int))
587
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))
593
594 #+#:unimplemented
595 (defcfun "pair_sum" :int
596 (p (:struct pair)))
597
598 #+#:unimplemented
599 (defcfun "make_pair" (:struct pair)
600 (a :int)
601 (b :int))
602
603 #|| ; TODO: load cffi-libffi for these tests to work.
604 (deftest struct-values.fn.1
605 (with-foreign-object (p '(:struct pair))
606 (with-foreign-slots ((a b) p (:struct pair))
607 (setf a -1 b 2)
608 (pair-sum p)))
609 1)
610
611 (deftest struct-values.fn.2
612 (pair-sum '(3 . 5))
613 8)
614
615 (deftest struct-values.fn.3
616 (with-foreign-object (p '(:struct pair))
617 (make-pair 7 11 :result-pointer p)
618 (with-foreign-slots ((a b) p (:struct pair))
619 (cons a b)))
620 (7 . 11))
621
622 (deftest struct-values.fn.4
623 (make-pair 13 17)
624 (13 . 17))
625 ||#
626
627 (defcstruct single-byte-struct
628 (a :uint8))
629
630 (deftest bare-struct-types.1
631 (eql (foreign-type-size 'single-byte-struct)
632 (foreign-type-size '(:struct single-byte-struct)))
633 t)
634
635 (defctype single-byte-struct-alias (:struct single-byte-struct))
636
637 (deftest bare-struct-types.2
638 (eql (foreign-type-size 'single-byte-struct-alias)
639 (foreign-type-size '(:struct single-byte-struct)))
640 t)
641
642 ;;; Old-style access to inner structure fields.
643
644 (defcstruct inner-struct (x :int))
645 (defcstruct old-style-outer (inner inner-struct))
646 (defcstruct new-style-outer (inner (:struct inner-struct)))
647
648 (deftest old-style-struct-access
649 (with-foreign-object (s '(:struct old-style-outer))
650 (let ((inner-ptr (foreign-slot-pointer s 'old-style-outer 'inner)))
651 (setf (foreign-slot-value inner-ptr 'inner-struct 'x) 42))
652 (assert (pointerp (foreign-slot-value s 'old-style-outer 'inner)))
653 (foreign-slot-value (foreign-slot-value s 'old-style-outer 'inner)
654 'inner-struct 'x))
655 42)
656
657 (deftest new-style-struct-access
658 (with-foreign-object (s '(:struct new-style-outer))
659 (let ((inner-ptr (foreign-slot-pointer s 'new-style-outer 'inner)))
660 (setf (foreign-slot-value inner-ptr 'inner-struct 'x) 42))
661 (foreign-slot-value s 'new-style-outer 'inner))
662 (x 42))
663
664 ;;; regression test: setting the value of aggregate slots.
665
666 (defcstruct aggregate-struct
667 (x :int)
668 (pair (:struct struct-pair))
669 (y :int))
670
671 (deftest set-aggregate-struct-slot
672 (with-foreign-objects ((pair-struct '(:struct struct-pair))
673 (aggregate-struct '(:struct aggregate-struct)…
674 (with-foreign-slots ((a b) pair-struct (:struct struct-pair))
675 (setf a 1 b 2)
676 (with-foreign-slots ((x pair y) aggregate-struct (:struct aggreg…
677 (setf x 42 y 42)
678 (setf pair pair-struct)
679 (values x pair y))))
680 42
681 (1 . 2)
682 42)
683
684 ;; TODO this needs to go through compile-file to exhibit the error
685 ;; ("don't know how to dump #<CFFI::AGGREGATE-STRUCT-SLOT>"), but
686 ;; there's no support for that, so let's leave it at toplevel here.
687 (defcstruct (aggregate-struct.acc :conc-name acc-)
688 (x :int)
689 (pair (:struct struct-pair))
690 (y :int))
691
692 (deftest set-aggregate-struct-slot.acc
693 (with-foreign-objects ((pair-struct '(:struct struct-pair))
694 (aggregate-struct '(:struct aggregate-struct)…
695 (with-foreign-slots ((a b) pair-struct (:struct struct-pair))
696 (setf a 1 b 2)
697 (setf (acc-x aggregate-struct) 42)
698 (setf (acc-y aggregate-struct) 42)
699 (setf (acc-pair aggregate-struct) pair-struct)
700 (values (acc-x aggregate-struct)
701 (acc-pair aggregate-struct)
702 (acc-y aggregate-struct))))
703 42
704 (1 . 2)
705 42)
You are viewing proxied material from bitreich.org. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.