struct.lisp - clic - Clic is an command line interactive client for gopher writ… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
struct.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) |