struct.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP (HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/ (DIR) Log (DIR) Files (DIR) Refs (DIR) Tags (DIR) README (DIR) 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 <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 ;;; 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 'another-char)) 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-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)) 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-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)) 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-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)) 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-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)) 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-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)) 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-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)) 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 C 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-empty-struct) 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 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) 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 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))))) 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 aggregate-struct)) 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)