external/cffi.darcs/_darcs/pristine/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
 217 #-cffi-features:no-long-long
 218 (progn
 219   (defcstruct s-long-long
 220     (a-long-long :long-long)
 221     (a-short     :short))
 222
 223   (defcstruct s-s-long-long
 224     (a-char        :char)
 225     (a-s-long-long s-long-long)
 226     (another-short :short))
 227
 228   (defcvar "the_s_s_long_long" s-s-long-long)
 229
 230   (deftest struct.alignment.6
 231       (with-foreign-slots
 232           ((a-char a-s-long-long another-short) *the-s-s-long-long* s-s-long-long)
 233         (with-foreign-slots ((a-long-long a-short) a-s-long-long s-long-long)
 234           (list 'a-long-long    a-long-long
 235                 'a-short        a-short
 236                 'a-char         a-char
 237                 'another-short  another-short)))
 238     (a-long-long 1 a-short 2 a-char 3 another-short 4)))
 239
 240
 241 (defcstruct s-s-double3
 242   (a-s-double2   s-double2)
 243   (another-short :short))
 244
 245 (defcstruct s-s-s-double3
 246   (a-s-s-double3  s-s-double3)
 247   (a-char         :char))
 248
 249 (defcvar "the_s_s_s_double3" s-s-s-double3)
 250
 251 (deftest struct.alignment.7
 252     (with-foreign-slots ((a-s-s-double3 a-char) *the-s-s-s-double3* s-s-s-double3)
 253       (with-foreign-slots ((a-s-double2 another-short) a-s-s-double3 s-s-double3)
 254         (with-foreign-slots ((a-double a-short) a-s-double2 s-double2)
 255           (list 'a-double      a-double
 256                 'a-short       a-short
 257                 'another-short another-short
 258                 'a-char        a-char))))
 259   (a-double 1.0d0 a-short 2 another-short 3 a-char 4))
 260
 261
 262 (defcstruct empty-struct)
 263
 264 (defcstruct with-empty-struct
 265   (foo empty-struct)
 266   (an-int :int))
 267
 268 ;; commented out this test because an empty struct is not valid/standard C
 269 ;; left the struct declarations anyway because they should be handled
 270 ;; gracefuly anyway.
 271
 272 ; (defcvar "the_with_empty_struct" with-empty-struct)
 273 ;
 274 ; (deftest struct.alignment.5
 275 ;     (with-foreign-slots ((foo an-int) *the-with-empty-struct* with-empty-struct)
 276 ;       an-int)
 277 ;   42)
 278
 279
 280 ;; regression test, setf-ing nested foreign-slot-value forms
 281 ;; the setf expander used to return a bogus getter
 282
 283 (defcstruct s1
 284   (an-int :int))
 285
 286 (defcstruct s2
 287   (an-s1 s1))
 288
 289 (deftest struct.nested-setf
 290     (with-foreign-object (an-s2 's2)
 291       (setf (foreign-slot-value (foreign-slot-value an-s2 's2 'an-s1)
 292                                 's1 'an-int)
 293             1984)
 294       (foreign-slot-value (foreign-slot-value an-s2 's2 'an-s1)
 295                           's1 'an-int))
 296   1984)
 297
 298 ;; regression test, some Lisps were returning 4 instead of 8 for
 299 ;; (foreign-type-alignment :unsigned-long-long) on darwin/ppc32
 300
 301 #-cffi-features:no-long-long
 302 (progn
 303   (defcstruct s-unsigned-long-long
 304     (an-unsigned-long-long :unsigned-long-long)
 305     (a-short               :short))
 306
 307   (defcstruct s-s-unsigned-long-long
 308     (a-char                 :char)
 309     (a-s-unsigned-long-long s-unsigned-long-long)
 310     (another-short          :short))
 311
 312   (defcvar "the_s_s_unsigned_long_long" s-s-unsigned-long-long)
 313
 314   (deftest struct.alignment.8
 315       (with-foreign-slots
 316           ((a-char a-s-unsigned-long-long another-short)
 317            *the-s-s-unsigned-long-long* s-s-unsigned-long-long)
 318         (with-foreign-slots ((an-unsigned-long-long a-short)
 319                              a-s-unsigned-long-long s-unsigned-long-long)
 320           (list 'an-unsigned-long-long  an-unsigned-long-long
 321                 'a-short                a-short
 322                 'a-char                 a-char
 323                 'another-short          another-short)))
 324     (an-unsigned-long-long 1 a-short 2 a-char 3 another-short 4)))