1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
3 ;;; memory.lisp --- Tests for memory referencing.
5 ;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
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:
15 ;;; The above copyright notice and this permission notice shall be
16 ;;; included in all copies or substantial portions of the Software.
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.
28 (in-package #:cffi-tests
)
31 (with-foreign-object (p :char
)
32 (setf (mem-ref p
:char
) -
127)
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
))
43 (with-foreign-object (p :short
)
44 (setf (mem-ref p
:short
) -
32767)
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
))
55 (with-foreign-object (p :int
)
56 (setf (mem-ref p
:int
) -
131072)
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
))
67 (with-foreign-object (p :long
)
68 (setf (mem-ref p
:long
) -
536870911)
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
))
78 #+(and cffi-features
:darwin openmcl
)
79 (pushnew 'deref.long-long rt
::*expected-failures
*)
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
))
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
))
93 (deftest deref.float
.1
94 (with-foreign-object (p :float
)
95 (setf (mem-ref p
:float
) 0.0)
99 (deftest deref.float
.2
100 (with-foreign-object (p :float
)
101 (setf (mem-ref p
:float
) *float-max
*)
105 (deftest deref.float
.3
106 (with-foreign-object (p :float
)
107 (setf (mem-ref p
:float
) *float-min
*)
111 (deftest deref.double
.1
112 (with-foreign-object (p :double
)
113 (setf (mem-ref p
:double
) 0.0d0
)
117 (deftest deref.double
.2
118 (with-foreign-object (p :double
)
119 (setf (mem-ref p
:double
) *double-max
*)
123 (deftest deref.double
.3
124 (with-foreign-object (p :double
)
125 (setf (mem-ref p
:double
) *double-min
*)
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
)
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
))
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
)
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
))
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
)))
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
))
167 ;; regression test. with-foreign-pointer shouldn't evaluate
168 ;; the size argument twice.
169 (deftest with-foreign-pointer.evalx2
171 (with-foreign-pointer (x (incf count
) size-var
)
172 (values count size-var
)))
175 (deftest mem-ref.left-to-right
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
)))
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
()
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))
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
)
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
()
204 (with-foreign-object (p :char
)
205 (%mem-set
(progn (push 1 result
) 0)
206 (progn (push 2 result
) p
)
208 (progn (push 3 result
) 0))
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
)
217 ;; regression test. mem-aref's setf expansion evaluated its type argument twice.
218 (deftest mem-aref.eval-type-x2
220 (with-foreign-pointer (p 1)
221 (setf (mem-aref p
(progn (incf count
) :char
) 0) 127))
225 (deftest mem-aref.left-to-right
227 (with-foreign-pointer (p 2)
229 (setf (mem-aref p
(progn (incf count
) :char
) (incf count
)) (incf count
))
231 (mem-aref (progn (incf count
) p
) :char
(incf count
))
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)
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)))
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.
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
))
262 (deftest deref.aggregate
263 (with-foreign-object (s 'some-struct
)
264 (pointer-eq s
(mem-ref s
'some-struct
)))
267 (deftest deref.array-of-aggregates
268 (with-foreign-object (arr 'some-struct
3)
270 do
(setf (foreign-slot-value (mem-aref arr
'some-struct i
)
274 collect
(foreign-slot-value (mem-aref arr
'some-struct i
)
278 ;;; pointer operations
280 (pointer-address (make-pointer 42))
283 ;;; I suppose this test is not very good. --luis
285 (pointer-address (null-pointer))
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
)))
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)))
304 ;;; Test the INITIAL-ELEMENT keyword argument to FOREIGN-ALLOC.
305 (deftest foreign-alloc
.1
306 (let ((ptr (foreign-alloc :int
:initial-element
42)))
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)))
316 (loop for i from
0 below
4
317 collect
(mem-aref ptr
:int i
))
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))))
326 (loop for i from
0 below
4
327 collect
(mem-aref ptr
:int i
))
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))))
336 (loop for i from
0 below
4
337 collect
(mem-aref ptr
:int i
))
341 ;;; Ensure calling FOREIGN-ALLOC with both INITIAL-ELEMENT and
342 ;;; INITIAL-CONTENTS signals an error.
343 (deftest foreign-alloc
.5
346 (let ((ptr (foreign-alloc :int
:initial-element
1 :initial-contents
'(1))))
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
()
356 (:simple-parser not-an-int
))
358 (defmethod translate-to-foreign (value (type not-an-int
))
359 (assert (not (integerp value
)))
362 (deftest foreign-alloc
.6
363 (let ((ptr (foreign-alloc 'not-an-int
:initial-element
'foooo
)))
368 ;;; Ensure calling FOREIGN-ALLOC with NULL-TERMINATED-P and a non-pointer
369 ;;; type signals an error.
370 (deftest foreign-alloc
.7
373 (let ((ptr (foreign-alloc :int
:null-terminated-p t
)))
378 ;;; The opposite of the above test.
379 (defctype pointer-alias
:pointer
)
381 (deftest foreign-alloc
.8
383 (foreign-free (foreign-alloc 'pointer-alias
:count
0 :null-terminated-p t
))
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
)))
392 (null-pointer-p (mem-ref ptr
:pointer
))
396 ;;; Tests for mem-ref with a non-constant type. This is a way to test
397 ;;; the functional interface (without compiler macros).
399 (deftest deref.nonconst.char
401 (with-foreign-object (p type
)
402 (setf (mem-ref p type
) -
127)
406 (deftest deref.nonconst.unsigned-char
407 (let ((type :unsigned-char
))
408 (with-foreign-object (p type
)
409 (setf (mem-ref p type
) 255)
413 (deftest deref.nonconst.short
415 (with-foreign-object (p type
)
416 (setf (mem-ref p type
) -
32767)
420 (deftest deref.nonconst.unsigned-short
421 (let ((type :unsigned-short
))
422 (with-foreign-object (p type
)
423 (setf (mem-ref p type
) 65535)
427 (deftest deref.nonconst.int
429 (with-foreign-object (p type
)
430 (setf (mem-ref p type
) -
131072)
434 (deftest deref.nonconst.unsigned-int
435 (let ((type :unsigned-int
))
436 (with-foreign-object (p type
)
437 (setf (mem-ref p type
) 262144)
441 (deftest deref.nonconst.long
443 (with-foreign-object (p type
)
444 (setf (mem-ref p type
) -
536870911)
448 (deftest deref.nonconst.unsigned-long
449 (let ((type :unsigned-long
))
450 (with-foreign-object (p type
)
451 (setf (mem-ref p type
) 536870912)
455 #+(and cffi-features
:darwin openmcl
)
456 (pushnew 'deref.nonconst.long-long rt
::*expected-failures
*)
458 (deftest deref.nonconst.long-long
459 (let ((type :long-long
))
460 (with-foreign-object (p type
)
461 (setf (mem-ref p type
) -
9223372036854775807)
463 -
9223372036854775807)
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)
470 18446744073709551615)
472 (deftest deref.nonconst.float
.1
474 (with-foreign-object (p type
)
475 (setf (mem-ref p type
) 0.0)
479 (deftest deref.nonconst.float
.2
481 (with-foreign-object (p type
)
482 (setf (mem-ref p type
) *float-max
*)
486 (deftest deref.nonconst.float
.3
488 (with-foreign-object (p type
)
489 (setf (mem-ref p type
) *float-min
*)
493 (deftest deref.nonconst.double
.1
494 (let ((type :double
))
495 (with-foreign-object (p type
)
496 (setf (mem-ref p type
) 0.0d0
)
500 (deftest deref.nonconst.double
.2
501 (let ((type :double
))
502 (with-foreign-object (p type
)
503 (setf (mem-ref p type
) *double-max
*)
507 (deftest deref.nonconst.double
.3
508 (let ((type :double
))
509 (with-foreign-object (p type
)
510 (setf (mem-ref p type
) *double-min
*)
514 ;;; regression tests: lispworks's %mem-ref and %mem-set compiler
515 ;;; macros were misbehaving.
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))))
523 (deftest mem-ref.rt
.1
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))))
533 (deftest mem-ref.rt
.2
537 (deftest incf-pointer
.1
538 (let ((ptr (null-pointer)))
540 (pointer-address ptr
))
543 (deftest incf-pointer
.2
544 (let ((ptr (null-pointer)))
545 (incf-pointer ptr
42)
546 (pointer-address ptr
))
551 (pointerp (null-pointer))
552 (null-pointer-p (null-pointer))
553 (typep (null-pointer) 'foreign-pointer
))
557 (let ((p (make-pointer #xFEFF
)))
560 (typep p
'foreign-pointer
)))