external/cffi.darcs/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 ;;;
   7 ;;; Permission is hereby granted, free of charge, to any person
   8 ;;; obtaining a copy of this software and associated documentation
   9 ;;; files (the "Software"), to deal in the Software without
  10 ;;; restriction, including without limitation the rights to use, copy,
  11 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
  12 ;;; of the Software, and to permit persons to whom the Software is
  13 ;;; furnished to do so, subject to the following conditions:
  14 ;;;
  15 ;;; The above copyright notice and this permission notice shall be
  16 ;;; included in all copies or substantial portions of the Software.
  17 ;;;
  18 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  19 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  20 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  21 ;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  22 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  23 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  24 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  25 ;;; DEALINGS IN THE SOFTWARE.
  26 ;;;
  27
  28 (in-package #:cffi-tests)
  29
  30 (defcstruct timeval
  31   (tv-secs :long)
  32   (tv-usecs :long))
  33
  34 (defparameter *timeval-size* (* 2 (max (foreign-type-size :long)
  35                                        (foreign-type-alignment :long))))
  36
  37 ;;;# Basic Structure Tests
  38
  39 (deftest struct.1
  40     (- (foreign-type-size 'timeval) *timeval-size*)
  41   0)
  42
  43 (deftest struct.2
  44     (with-foreign-object (tv 'timeval)
  45       (setf (foreign-slot-value tv 'timeval 'tv-secs) 0)
  46       (setf (foreign-slot-value tv 'timeval 'tv-usecs) 1)
  47       (values (foreign-slot-value tv 'timeval 'tv-secs)
  48               (foreign-slot-value tv 'timeval 'tv-usecs)))
  49   0 1)
  50
  51 (deftest struct.3
  52     (with-foreign-object (tv 'timeval)
  53       (with-foreign-slots ((tv-secs tv-usecs) tv timeval)
  54         (setf tv-secs 100 tv-usecs 200)
  55         (values tv-secs tv-usecs)))
  56   100 200)
  57
  58 ;; regression test: accessing a struct through a typedef
  59
  60 (defctype xpto timeval)
  61
  62 (deftest struct.4
  63     (with-foreign-object (tv 'xpto)
  64       (setf (foreign-slot-value tv 'xpto 'tv-usecs) 1)
  65       (values (foreign-slot-value tv 'xpto 'tv-usecs)
  66               (foreign-slot-value tv 'timeval 'tv-usecs)))
  67   1 1)
  68
  69 (deftest struct.names
  70     (sort (foreign-slot-names 'xpto) #'<
  71           :key (lambda (x) (foreign-slot-offset 'xpto x)))
  72   (tv-secs tv-usecs))
  73
  74 ;; regression test: compiler macro not quoting the type in the
  75 ;; resulting mem-ref form. The compiler macro on foreign-slot-value
  76 ;; is not guaranteed to be expanded though.
  77
  78 (defctype my-int :int)
  79 (defcstruct s5 (a my-int))
  80
  81 (deftest struct.5
  82     (with-foreign-object (s 's5)
  83       (setf (foreign-slot-value s 's5 'a) 42)
  84       (foreign-slot-value s 's5 'a))
  85   42)
  86
  87 ;;;# Structs with type translators
  88
  89 (defcstruct struct-string
  90   (s :string))
  91
  92 (deftest struct.string.1
  93     (with-foreign-object (ptr 'struct-string)
  94       (with-foreign-slots ((s) ptr struct-string)
  95         (setf s "So long and thanks for all the fish!")
  96         s))
  97   "So long and thanks for all the fish!")
  98
  99 (deftest struct.string.2
 100     (with-foreign-object (ptr 'struct-string)
 101       (setf (foreign-slot-value ptr 'struct-string 's) "Cha")
 102       (foreign-slot-value ptr 'struct-string 's))
 103   "Cha")
 104
 105 ;;;# Structure Alignment Tests
 106 ;;;
 107 ;;; See libtest.c and types.lisp for some comments about alignments.
 108
 109 (defcstruct s-ch
 110   (a-char :char))
 111
 112 (defcstruct s-s-ch
 113   (another-char :char)
 114   (a-s-ch s-ch))
 115
 116 (defcvar "the_s_s_ch" s-s-ch)
 117
 118 (deftest struct.alignment.1
 119     (list 'a-char (foreign-slot-value
 120                    (foreign-slot-value *the-s-s-ch* 's-s-ch 'a-s-ch)
 121                    's-ch 'a-char)
 122           'another-char (foreign-slot-value *the-s-s-ch* 's-s-ch 'another-char))
 123   (a-char 1 another-char 2))
 124
 125
 126 (defcstruct s-short
 127   (a-char :char)
 128   (another-char :char)
 129   (a-short :short))
 130
 131 (defcstruct s-s-short
 132   (yet-another-char :char)
 133   (a-s-short s-short))
 134
 135 (defcvar "the_s_s_short" s-s-short)
 136
 137 (deftest struct.alignment.2
 138     (with-foreign-slots ((yet-another-char a-s-short) *the-s-s-short* s-s-short)
 139       (with-foreign-slots ((a-char another-char a-short) a-s-short s-short)
 140         (list 'a-char           a-char
 141               'another-char     another-char
 142               'a-short          a-short
 143               'yet-another-char yet-another-char)))
 144   (a-char 1 another-char 2 a-short 3 yet-another-char 4))
 145
 146
 147 (defcstruct s-double
 148   (a-char :char)
 149   (a-double :double)
 150   (another-char :char))
 151
 152 (defcstruct s-s-double
 153   (yet-another-char :char)
 154   (a-s-double s-double)
 155   (a-short :short))
 156
 157 (defcvar "the_s_s_double" s-s-double)
 158
 159 (deftest struct.alignment.3
 160     (with-foreign-slots
 161         ((yet-another-char a-s-double a-short) *the-s-s-double* s-s-double)
 162       (with-foreign-slots ((a-char a-double another-char) a-s-double s-double)
 163         (list 'a-char            a-char
 164               'a-double          a-double
 165               'another-char      another-char
 166               'yet-another-char  yet-another-char
 167               'a-short           a-short)))
 168   (a-char 1 a-double 2.0d0 another-char 3 yet-another-char 4 a-short 5))
 169
 170
 171 (defcstruct s-s-s-double
 172   (another-short :short)
 173   (a-s-s-double s-s-double)
 174   (last-char :char))
 175
 176 (defcvar "the_s_s_s_double" s-s-s-double)
 177
 178 (deftest struct.alignment.4
 179     (with-foreign-slots
 180         ((another-short a-s-s-double last-char) *the-s-s-s-double* s-s-s-double)
 181       (with-foreign-slots
 182           ((yet-another-char a-s-double a-short) a-s-s-double s-s-double)
 183         (with-foreign-slots ((a-char a-double another-char) a-s-double s-double)
 184           (list 'a-char            a-char
 185                 'a-double          a-double
 186                 'another-char      another-char
 187                 'yet-another-char  yet-another-char
 188                 'a-short           a-short
 189                 'another-short     another-short
 190                 'last-char         last-char))))
 191   (a-char 1 a-double 2.0d0 another-char 3 yet-another-char 4 a-short 5
 192    another-short 6 last-char 7))
 193
 194
 195 (defcstruct s-double2
 196   (a-double :double)
 197   (a-short  :short))
 198
 199 (defcstruct s-s-double2
 200   (a-char        :char)
 201   (a-s-double2   s-double2)
 202   (another-short :short))
 203
 204 (defcvar "the_s_s_double2" s-s-double2)
 205
 206 (deftest struct.alignment.5
 207     (with-foreign-slots
 208         ((a-char a-s-double2 another-short) *the-s-s-double2* s-s-double2)
 209       (with-foreign-slots ((a-double a-short) a-s-double2 s-double2)
 210         (list 'a-double       a-double
 211               'a-short        a-short
 212               'a-char         a-char
 213               'another-short  another-short)))
 214   (a-double 1.0d0 a-short 2 a-char 3 another-short 4))
 215
 216 (defcstruct s-long-long
 217   (a-long-long :long-long)
 218   (a-short     :short))
 219
 220 (defcstruct s-s-long-long
 221   (a-char        :char)
 222   (a-s-long-long s-long-long)
 223   (another-short :short))
 224
 225 (defcvar "the_s_s_long_long" s-s-long-long)
 226
 227 (deftest struct.alignment.6
 228     (with-foreign-slots
 229         ((a-char a-s-long-long another-short) *the-s-s-long-long* s-s-long-long)
 230       (with-foreign-slots ((a-long-long a-short) a-s-long-long s-long-long)
 231         (list 'a-long-long    a-long-long
 232               'a-short        a-short
 233               'a-char         a-char
 234               'another-short  another-short)))
 235   (a-long-long 1 a-short 2 a-char 3 another-short 4))
 236
 237 (defcstruct s-s-double3
 238   (a-s-double2   s-double2)
 239   (another-short :short))
 240
 241 (defcstruct s-s-s-double3
 242   (a-s-s-double3  s-s-double3)
 243   (a-char         :char))
 244
 245 (defcvar "the_s_s_s_double3" s-s-s-double3)
 246
 247 (deftest struct.alignment.7
 248     (with-foreign-slots ((a-s-s-double3 a-char) *the-s-s-s-double3* s-s-s-double3)
 249       (with-foreign-slots ((a-s-double2 another-short) a-s-s-double3 s-s-double3)
 250         (with-foreign-slots ((a-double a-short) a-s-double2 s-double2)
 251           (list 'a-double      a-double
 252                 'a-short       a-short
 253                 'another-short another-short
 254                 'a-char        a-char))))
 255   (a-double 1.0d0 a-short 2 another-short 3 a-char 4))
 256
 257
 258 (defcstruct empty-struct)
 259
 260 (defcstruct with-empty-struct
 261   (foo empty-struct)
 262   (an-int :int))
 263
 264 ;; commented out this test because an empty struct is not valid/standard C
 265 ;; left the struct declarations anyway because they should be handled
 266 ;; gracefuly anyway.
 267
 268 ; (defcvar "the_with_empty_struct" with-empty-struct)
 269 ;
 270 ; (deftest struct.alignment.5
 271 ;     (with-foreign-slots ((foo an-int) *the-with-empty-struct* with-empty-struct)
 272 ;       an-int)
 273 ;   42)
 274
 275
 276 ;; regression test, setf-ing nested foreign-slot-value forms
 277 ;; the setf expander used to return a bogus getter
 278
 279 (defcstruct s1
 280   (an-int :int))
 281
 282 (defcstruct s2
 283   (an-s1 s1))
 284
 285 (deftest struct.nested-setf
 286     (with-foreign-object (an-s2 's2)
 287       (setf (foreign-slot-value (foreign-slot-value an-s2 's2 'an-s1)
 288                                 's1 'an-int)
 289             1984)
 290       (foreign-slot-value (foreign-slot-value an-s2 's2 'an-s1)
 291                           's1 'an-int))
 292   1984)
 293
 294 ;; regression test, some Lisps were returning 4 instead of 8 for
 295 ;; (foreign-type-alignment :unsigned-long-long) on darwin/ppc32
 296
 297 (defcstruct s-unsigned-long-long
 298   (an-unsigned-long-long :unsigned-long-long)
 299   (a-short               :short))
 300
 301 (defcstruct s-s-unsigned-long-long
 302   (a-char                 :char)
 303   (a-s-unsigned-long-long s-unsigned-long-long)
 304   (another-short          :short))
 305
 306 (defcvar "the_s_s_unsigned_long_long" s-s-unsigned-long-long)
 307
 308 (deftest struct.alignment.8
 309     (with-foreign-slots
 310         ((a-char a-s-unsigned-long-long another-short)
 311          *the-s-s-unsigned-long-long* s-s-unsigned-long-long)
 312       (with-foreign-slots ((an-unsigned-long-long a-short)
 313                            a-s-unsigned-long-long s-unsigned-long-long)
 314         (list 'an-unsigned-long-long  an-unsigned-long-long
 315               'a-short                a-short
 316               'a-char                 a-char
 317               'another-short          another-short)))
 318   (an-unsigned-long-long 1 a-short 2 a-char 3 another-short 4))
 319
 320 ;;;# C Struct Wrappers
 321
 322 (define-c-struct-wrapper timeval ())
 323
 324 (define-c-struct-wrapper (timeval2 timeval) ()
 325   (tv-secs))
 326
 327 (defmacro with-example-timeval (var &body body)
 328   `(with-foreign-object (,var 'timeval)
 329      (with-foreign-slots ((tv-secs tv-usecs) ,var timeval)
 330        (setf tv-secs 42 tv-usecs 1984)
 331        ,@body)))
 332
 333 (deftest struct-wrapper.1
 334     (with-example-timeval ptr
 335       (let ((obj (make-instance 'timeval :pointer ptr)))
 336         (values (timeval-tv-secs obj)
 337                 (timeval-tv-usecs obj))))
 338   42 1984)
 339
 340 (deftest struct-wrapper.2
 341     (with-example-timeval ptr
 342       (let ((obj (make-instance 'timeval2 :pointer ptr)))
 343         (timeval2-tv-secs obj)))
 344   42)