tests/struct.lisp

   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)
 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)
 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 #+#:unused
 570 (defcfun "pair_plus_one_pointer_sum" :int
 571   (p (:pointer (:struct struct-pair+1))))
 572
 573 #+#:pointer-translation-not-yet-implemented
 574 (deftest struct-values.translation.ppo.2
 575     (pair-plus-one-pointer-sum '((1 . 2) . 3))
 576   6)
 577
 578 (defcfun "make_pair_plus_one" (:struct struct-pair+1)
 579   (a :int)
 580   (b :int)
 581   (c :int))
 582
 583 (defcfun "alloc_pair_plus_one" (:pointer (:struct 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 (defcfun "pair_sum" :int
 595   (p (:struct struct-pair)))
 596
 597 (defcfun "make_pair" (:struct struct-pair)
 598   (a :int)
 599   (b :int))
 600
 601 (deftest struct-values.fn.1
 602     (pair-sum '(-1 . 2))
 603   1)
 604
 605 (deftest struct-values.fn.2
 606     (make-pair 13 17)
 607   (13 . 17))
 608
 609 (defcstruct single-byte-struct
 610   (a :uint8))
 611
 612 (deftest bare-struct-types.1
 613     (eql (foreign-type-size 'single-byte-struct)
 614          (foreign-type-size '(:struct single-byte-struct)))
 615   t)
 616
 617 (defctype single-byte-struct-alias (:struct single-byte-struct))
 618
 619 (deftest bare-struct-types.2
 620     (eql (foreign-type-size 'single-byte-struct-alias)
 621          (foreign-type-size '(:struct single-byte-struct)))
 622   t)
 623
 624 ;;; Old-style access to inner structure fields.
 625
 626 (defcstruct inner-struct (x :int))
 627 (defcstruct old-style-outer (inner inner-struct))
 628 (defcstruct new-style-outer (inner (:struct inner-struct)))
 629
 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))
 637   42)
 638
 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))
 645
 646 ;;; regression test: setting the value of aggregate slots.
 647
 648 (defcstruct aggregate-struct
 649   (x :int)
 650   (pair (:struct struct-pair))
 651   (y :int))
 652
 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))))
 662   42
 663   (1 . 2)
 664   42)
 665
 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))
 673
 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))))
 685   42
 686   (1 . 2)
 687   42)
 688
 689 ;; Test with-foreign-slots :pointer access and new binding syntax
 690 (defcstruct struct.wfs
 691   (tv-secs :long)
 692   (tv-usecs :long))
 693
 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)
 700
 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)
 709
 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)