external/cffi.darcs/_darcs/pristine/tests/memory.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; memory.lisp --- Tests for memory referencing.
   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 (deftest deref.char
  31     (with-foreign-object (p :char)
  32       (setf (mem-ref p :char) -127)
  33       (mem-ref p :char))
  34   -127)
  35
  36 (deftest deref.unsigned-char
  37     (with-foreign-object (p :unsigned-char)
  38       (setf (mem-ref p :unsigned-char) 255)
  39       (mem-ref p :unsigned-char))
  40   255)
  41
  42 (deftest deref.short
  43     (with-foreign-object (p :short)
  44       (setf (mem-ref p :short) -32767)
  45       (mem-ref p :short))
  46   -32767)
  47
  48 (deftest deref.unsigned-short
  49     (with-foreign-object (p :unsigned-short)
  50       (setf (mem-ref p :unsigned-short) 65535)
  51       (mem-ref p :unsigned-short))
  52   65535)
  53
  54 (deftest deref.int
  55     (with-foreign-object (p :int)
  56       (setf (mem-ref p :int) -131072)
  57       (mem-ref p :int))
  58   -131072)
  59
  60 (deftest deref.unsigned-int
  61     (with-foreign-object (p :unsigned-int)
  62       (setf (mem-ref p :unsigned-int) 262144)
  63       (mem-ref p :unsigned-int))
  64   262144)
  65
  66 (deftest deref.long
  67     (with-foreign-object (p :long)
  68       (setf (mem-ref p :long) -536870911)
  69       (mem-ref p :long))
  70   -536870911)
  71
  72 (deftest deref.unsigned-long
  73     (with-foreign-object (p :unsigned-long)
  74       (setf (mem-ref p :unsigned-long) 536870912)
  75       (mem-ref p :unsigned-long))
  76   536870912)
  77
  78 #-cffi-features:no-long-long
  79 (progn
  80   #+(and cffi-features:darwin openmcl)
  81   (pushnew 'deref.long-long rt::*expected-failures*)
  82
  83   (deftest deref.long-long
  84       (with-foreign-object (p :long-long)
  85         (setf (mem-ref p :long-long) -9223372036854775807)
  86         (mem-ref p :long-long))
  87     -9223372036854775807)
  88
  89   (deftest deref.unsigned-long-long
  90       (with-foreign-object (p :unsigned-long-long)
  91         (setf (mem-ref p :unsigned-long-long) 18446744073709551615)
  92         (mem-ref p :unsigned-long-long))
  93     18446744073709551615))
  94
  95 (deftest deref.float.1
  96     (with-foreign-object (p :float)
  97       (setf (mem-ref p :float) 0.0)
  98       (mem-ref p :float))
  99   0.0)
 100
 101 (deftest deref.float.2
 102     (with-foreign-object (p :float)
 103       (setf (mem-ref p :float) *float-max*)
 104       (mem-ref p :float))
 105   #.*float-max*)
 106
 107 (deftest deref.float.3
 108     (with-foreign-object (p :float)
 109       (setf (mem-ref p :float) *float-min*)
 110       (mem-ref p :float))
 111   #.*float-min*)
 112
 113 (deftest deref.double.1
 114     (with-foreign-object (p :double)
 115       (setf (mem-ref p :double) 0.0d0)
 116       (mem-ref p :double))
 117   0.0d0)
 118
 119 (deftest deref.double.2
 120     (with-foreign-object (p :double)
 121       (setf (mem-ref p :double) *double-max*)
 122       (mem-ref p :double))
 123   #.*double-max*)
 124
 125 (deftest deref.double.3
 126     (with-foreign-object (p :double)
 127       (setf (mem-ref p :double) *double-min*)
 128       (mem-ref p :double))
 129   #.*double-min*)
 130
 131 ;;; TODO: use something like *DOUBLE-MIN/MAX* above once we actually
 132 ;;; have an available lisp that supports long double.
 133 ;#-cffi-features:no-long-float
 134 #+(and scl long-double)
 135 (progn
 136   (deftest deref.long-double.1
 137       (with-foreign-object (p :long-double)
 138         (setf (mem-ref p :long-double) 0.0l0)
 139         (mem-ref p :long-double))
 140     0.0l0)
 141
 142   (deftest deref.long-double.2
 143       (with-foreign-object (p :long-double)
 144         (setf (mem-ref p :long-double) most-positive-long-float)
 145         (mem-ref p :long-double))
 146     #.most-positive-long-float)
 147
 148   (deftest deref.long-double.3
 149       (with-foreign-object (p :long-double)
 150         (setf (mem-ref p :long-double) least-positive-long-float)
 151         (mem-ref p :long-double))
 152     #.least-positive-long-float))
 153
 154 ;;; make sure the lisp doesn't convert NULL to NIL
 155 (deftest deref.pointer.null
 156     (with-foreign-object (p :pointer)
 157       (setf (mem-ref p :pointer) (null-pointer))
 158       (null-pointer-p (mem-ref p :pointer)))
 159   t)
 160
 161 ;;; regression test. lisp-string-to-foreign should handle empty strings
 162 (deftest lisp-string-to-foreign.empty
 163     (with-foreign-pointer (str 2)
 164       (setf (mem-ref str :unsigned-char) 42)
 165       (lisp-string-to-foreign "" str 1)
 166       (mem-ref str :unsigned-char))
 167   0)
 168
 169 ;; regression test. with-foreign-pointer shouldn't evaluate
 170 ;; the size argument twice.
 171 (deftest with-foreign-pointer.evalx2
 172     (let ((count 0))
 173       (with-foreign-pointer (x (incf count) size-var)
 174         (values count size-var)))
 175   1 1)
 176
 177 (deftest mem-ref.left-to-right
 178     (let ((i 0))
 179       (with-foreign-object (p :char 3)
 180         (setf (mem-ref p :char 0) 66 (mem-ref p :char 1) 92)
 181         (setf (mem-ref p :char (incf i)) (incf i))
 182         (values (mem-ref p :char 0) (mem-ref p :char 1) i)))
 183   66 2 2)
 184
 185 ;;; This needs to be in a real function for at least Allegro CL or the
 186 ;;; compiler macro on %MEM-REF is not expanded and the test doesn't
 187 ;;; actually test anything!
 188 (defun %mem-ref-left-to-right ()
 189   (let ((result nil))
 190     (with-foreign-object (p :char)
 191       (%mem-set 42 p :char)
 192       (%mem-ref (progn (push 1 result) p) :char (progn (push 2 result) 0))
 193       (nreverse result))))
 194
 195 ;;; Test left-to-right evaluation of the arguments to %MEM-REF when
 196 ;;; optimized by the compiler macro.
 197 (deftest %mem-ref.left-to-right
 198     (%mem-ref-left-to-right)
 199   (1 2))
 200
 201 ;;; This needs to be in a top-level function for at least Allegro CL
 202 ;;; or the compiler macro on %MEM-SET is not expanded and the test
 203 ;;; doesn't actually test anything!
 204 (defun %mem-set-left-to-right ()
 205   (let ((result nil))
 206     (with-foreign-object (p :char)
 207       (%mem-set (progn (push 1 result) 0)
 208                 (progn (push 2 result) p)
 209                 :char
 210                 (progn (push 3 result) 0))
 211       (nreverse result))))
 212
 213 ;;; Test left-to-right evaluation of the arguments to %MEM-SET when
 214 ;;; optimized by the compiler macro.
 215 (deftest %mem-set.left-to-right
 216     (%mem-set-left-to-right)
 217   (1 2 3))
 218
 219 ;; regression test. mem-aref's setf expansion evaluated its type argument twice.
 220 (deftest mem-aref.eval-type-x2
 221     (let ((count 0))
 222       (with-foreign-pointer (p 1)
 223         (setf (mem-aref p (progn (incf count) :char) 0) 127))
 224       count)
 225   1)
 226
 227 (deftest mem-aref.left-to-right
 228     (let ((count -1))
 229       (with-foreign-pointer (p 2)
 230         (values
 231          (setf (mem-aref p (progn (incf count) :char) (incf count)) (incf count))
 232          (setq count -1)
 233          (mem-aref (progn (incf count) p) :char (incf count))
 234          count)))
 235   2 -1 2 1)
 236
 237 ;; regression tests. nested mem-ref's and mem-aref's had bogus getters
 238 (deftest mem-ref.nested
 239     (with-foreign-object (p :pointer)
 240       (with-foreign-object (i :int)
 241         (setf (mem-ref p :pointer) i)
 242         (setf (mem-ref i :int) 42)
 243         (setf (mem-ref (mem-ref p :pointer) :int) 1984)
 244         (mem-ref i :int)))
 245   1984)
 246
 247 (deftest mem-aref.nested
 248     (with-foreign-object (p :pointer)
 249       (with-foreign-object (i :int 2)
 250         (setf (mem-aref p :pointer 0) i)
 251         (setf (mem-aref i :int 1) 42)
 252         (setf (mem-aref (mem-ref p :pointer 0) :int 1) 1984)
 253         (mem-aref i :int 1)))
 254   1984)
 255
 256 ;;; regression tests. dereferencing an aggregate type. dereferencing a
 257 ;;; struct should return a pointer to the struct itself, not return the
 258 ;;; first 4 bytes (or whatever the size of :pointer is) as a pointer.
 259 ;;;
 260 ;;; This important for accessing an array of structs, which is
 261 ;;; what the deref.array-of-aggregates test does.
 262 (defcstruct some-struct (x :int))
 263
 264 (deftest deref.aggregate
 265     (with-foreign-object (s 'some-struct)
 266       (pointer-eq s (mem-ref s 'some-struct)))
 267   t)
 268
 269 (deftest deref.array-of-aggregates
 270     (with-foreign-object (arr 'some-struct 3)
 271       (loop for i below 3
 272             do (setf (foreign-slot-value (mem-aref arr 'some-struct i)
 273                                          'some-struct 'x)
 274                      112))
 275       (loop for i below 3
 276             collect (foreign-slot-value (mem-aref arr 'some-struct i)
 277                                         'some-struct 'x)))
 278   (112 112 112))
 279
 280 ;;; pointer operations
 281 (deftest pointer.1
 282     (pointer-address (make-pointer 42))
 283   42)
 284
 285 ;;; I suppose this test is not very good. --luis
 286 (deftest pointer.2
 287     (pointer-address (null-pointer))
 288   0)
 289
 290 ;;; Ensure that a pointer to the highest possible address can be
 291 ;;; created using MAKE-POINTER.  Regression test for CLISP/X86-64.
 292 (deftest make-pointer.high
 293     (let* ((pointer-length (foreign-type-size :pointer))
 294            (high-address (1- (expt 2 (* pointer-length 8))))
 295            (pointer (make-pointer high-address)))
 296       (- high-address (pointer-address pointer)))
 297   0)
 298
 299 ;;; Ensure that incrementing a pointer by zero bytes returns an
 300 ;;; equivalent pointer.
 301 (deftest inc-pointer.zero
 302     (with-foreign-object (x :int)
 303       (pointer-eq x (inc-pointer x 0)))
 304   t)
 305
 306 ;;; Test the INITIAL-ELEMENT keyword argument to FOREIGN-ALLOC.
 307 (deftest foreign-alloc.1
 308     (let ((ptr (foreign-alloc :int :initial-element 42)))
 309       (unwind-protect
 310            (mem-ref ptr :int)
 311         (foreign-free ptr)))
 312   42)
 313
 314 ;;; Test the INITIAL-ELEMENT and COUNT arguments to FOREIGN-ALLOC.
 315 (deftest foreign-alloc.2
 316     (let ((ptr (foreign-alloc :int :count 4 :initial-element 100)))
 317       (unwind-protect
 318            (loop for i from 0 below 4
 319                  collect (mem-aref ptr :int i))
 320         (foreign-free ptr)))
 321   (100 100 100 100))
 322
 323 ;;; Test the INITIAL-CONTENTS and COUNT arguments to FOREIGN-ALLOC,
 324 ;;; passing a list of initial values.
 325 (deftest foreign-alloc.3
 326     (let ((ptr (foreign-alloc :int :count 4 :initial-contents '(4 3 2 1))))
 327       (unwind-protect
 328            (loop for i from 0 below 4
 329                  collect (mem-aref ptr :int i))
 330         (foreign-free ptr)))
 331   (4 3 2 1))
 332
 333 ;;; Test INITIAL-CONTENTS and COUNT with FOREIGN-ALLOC passing a
 334 ;;; vector of initial values.
 335 (deftest foreign-alloc.4
 336     (let ((ptr (foreign-alloc :int :count 4 :initial-contents #(10 20 30 40))))
 337       (unwind-protect
 338            (loop for i from 0 below 4
 339                  collect (mem-aref ptr :int i))
 340         (foreign-free ptr)))
 341   (10 20 30 40))
 342
 343 ;;; Ensure calling FOREIGN-ALLOC with both INITIAL-ELEMENT and
 344 ;;; INITIAL-CONTENTS signals an error.
 345 (deftest foreign-alloc.5
 346     (values
 347      (ignore-errors
 348        (let ((ptr (foreign-alloc :int :initial-element 1 :initial-contents '(1))))
 349          (foreign-free ptr))
 350        t))
 351   nil)
 352
 353 ;;; Regression test: FOREIGN-ALLOC shouldn't actually perform translation
 354 ;;; on initial-element/initial-contents since MEM-AREF will do that already.
 355 (define-foreign-type not-an-int ()
 356   ()
 357   (:actual-type :int)
 358   (:simple-parser not-an-int))
 359
 360 (defmethod translate-to-foreign (value (type not-an-int))
 361   (assert (not (integerp value)))
 362   0)
 363
 364 (deftest foreign-alloc.6
 365     (let ((ptr (foreign-alloc 'not-an-int :initial-element 'foooo)))
 366       (foreign-free ptr)
 367       t)
 368   t)
 369
 370 ;;; Ensure calling FOREIGN-ALLOC with NULL-TERMINATED-P and a non-pointer
 371 ;;; type signals an error.
 372 (deftest foreign-alloc.7
 373     (values
 374      (ignore-errors
 375        (let ((ptr (foreign-alloc :int :null-terminated-p t)))
 376          (foreign-free ptr))
 377        t))
 378   nil)
 379
 380 ;;; The opposite of the above test.
 381 (defctype pointer-alias :pointer)
 382
 383 (deftest foreign-alloc.8
 384     (progn
 385       (foreign-free (foreign-alloc 'pointer-alias :count 0 :null-terminated-p t))
 386       t)
 387   t)
 388
 389 ;;; Ensure calling FOREIGN-ALLOC with NULL-TERMINATED-P actually places
 390 ;;; a null pointer at the end. Not a very reliable test apparently.
 391 (deftest foreign-alloc.9
 392     (let ((ptr (foreign-alloc :pointer :count 0 :null-terminated-p t)))
 393       (unwind-protect
 394            (null-pointer-p (mem-ref ptr :pointer))
 395         (foreign-free ptr)))
 396   t)
 397
 398 ;;; Tests for mem-ref with a non-constant type. This is a way to test
 399 ;;; the functional interface (without compiler macros).
 400
 401 (deftest deref.nonconst.char
 402     (let ((type :char))
 403       (with-foreign-object (p type)
 404         (setf (mem-ref p type) -127)
 405         (mem-ref p type)))
 406   -127)
 407
 408 (deftest deref.nonconst.unsigned-char
 409     (let ((type :unsigned-char))
 410       (with-foreign-object (p type)
 411         (setf (mem-ref p type) 255)
 412         (mem-ref p type)))
 413   255)
 414
 415 (deftest deref.nonconst.short
 416     (let ((type :short))
 417       (with-foreign-object (p type)
 418         (setf (mem-ref p type) -32767)
 419         (mem-ref p type)))
 420   -32767)
 421
 422 (deftest deref.nonconst.unsigned-short
 423     (let ((type :unsigned-short))
 424       (with-foreign-object (p type)
 425         (setf (mem-ref p type) 65535)
 426         (mem-ref p type)))
 427   65535)
 428
 429 (deftest deref.nonconst.int
 430     (let ((type :int))
 431       (with-foreign-object (p type)
 432         (setf (mem-ref p type) -131072)
 433         (mem-ref p type)))
 434   -131072)
 435
 436 (deftest deref.nonconst.unsigned-int
 437     (let ((type :unsigned-int))
 438       (with-foreign-object (p type)
 439         (setf (mem-ref p type) 262144)
 440         (mem-ref p type)))
 441   262144)
 442
 443 (deftest deref.nonconst.long
 444     (let ((type :long))
 445       (with-foreign-object (p type)
 446         (setf (mem-ref p type) -536870911)
 447         (mem-ref p type)))
 448   -536870911)
 449
 450 (deftest deref.nonconst.unsigned-long
 451     (let ((type :unsigned-long))
 452       (with-foreign-object (p type)
 453         (setf (mem-ref p type) 536870912)
 454         (mem-ref p type)))
 455   536870912)
 456
 457 #-cffi-features:no-long-long
 458 (progn
 459   #+(and cffi-features:darwin openmcl)
 460   (pushnew 'deref.nonconst.long-long rt::*expected-failures*)
 461
 462   (deftest deref.nonconst.long-long
 463       (let ((type :long-long))
 464         (with-foreign-object (p type)
 465           (setf (mem-ref p type) -9223372036854775807)
 466           (mem-ref p type)))
 467     -9223372036854775807)
 468
 469   (deftest deref.nonconst.unsigned-long-long
 470       (let ((type :unsigned-long-long))
 471         (with-foreign-object (p type)
 472           (setf (mem-ref p type) 18446744073709551615)
 473           (mem-ref p type)))
 474     18446744073709551615))
 475
 476 (deftest deref.nonconst.float.1
 477     (let ((type :float))
 478       (with-foreign-object (p type)
 479         (setf (mem-ref p type) 0.0)
 480         (mem-ref p type)))
 481   0.0)
 482
 483 (deftest deref.nonconst.float.2
 484     (let ((type :float))
 485       (with-foreign-object (p type)
 486         (setf (mem-ref p type) *float-max*)
 487         (mem-ref p type)))
 488   #.*float-max*)
 489
 490 (deftest deref.nonconst.float.3
 491     (let ((type :float))
 492       (with-foreign-object (p type)
 493         (setf (mem-ref p type) *float-min*)
 494         (mem-ref p type)))
 495   #.*float-min*)
 496
 497 (deftest deref.nonconst.double.1
 498     (let ((type :double))
 499       (with-foreign-object (p type)
 500         (setf (mem-ref p type) 0.0d0)
 501         (mem-ref p type)))
 502   0.0d0)
 503
 504 (deftest deref.nonconst.double.2
 505     (let ((type :double))
 506       (with-foreign-object (p type)
 507         (setf (mem-ref p type) *double-max*)
 508         (mem-ref p type)))
 509   #.*double-max*)
 510
 511 (deftest deref.nonconst.double.3
 512     (let ((type :double))
 513       (with-foreign-object (p type)
 514         (setf (mem-ref p type) *double-min*)
 515         (mem-ref p type)))
 516   #.*double-min*)
 517
 518 ;;; regression tests: lispworks's %mem-ref and %mem-set compiler
 519 ;;; macros were misbehaving.
 520
 521 (defun mem-ref-rt-1 ()
 522   (with-foreign-object (a :int 2)
 523     (setf (mem-aref a :int 0) 123
 524           (mem-aref a :int 1) 456)
 525     (values (mem-aref a :int 0) (mem-aref a :int 1))))
 526
 527 (deftest mem-ref.rt.1
 528     (mem-ref-rt-1)
 529   123 456)
 530
 531 (defun mem-ref-rt-2 ()
 532   (with-foreign-object (a :double 2)
 533     (setf (mem-aref a :double 0) 123.0d0
 534           (mem-aref a :double 1) 456.0d0)
 535     (values (mem-aref a :double 0) (mem-aref a :double 1))))
 536
 537 (deftest mem-ref.rt.2
 538     (mem-ref-rt-2)
 539   123.0d0 456.0d0)
 540
 541 (deftest incf-pointer.1
 542     (let ((ptr (null-pointer)))
 543       (incf-pointer ptr)
 544       (pointer-address ptr))
 545   1)
 546
 547 (deftest incf-pointer.2
 548     (let ((ptr (null-pointer)))
 549       (incf-pointer ptr 42)
 550       (pointer-address ptr))
 551   42)
 552
 553 (deftest pointerp.1
 554     (values
 555      (pointerp (null-pointer))
 556      (null-pointer-p (null-pointer))
 557      (typep (null-pointer) 'foreign-pointer))
 558   t t t)
 559
 560 (deftest pointerp.2
 561     (let ((p (make-pointer #xFEFF)))
 562       (values
 563        (pointerp p)
 564        (typep p 'foreign-pointer)))
 565   t t)