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