memory.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
memory.lisp (19020B)
---
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 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-sys::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 (defconstant +two+ 2)
176
177 ;;; regression test. cffi-allegro's with-foreign-pointer wasn't
178 ;;; handling constants properly.
179 (deftest with-foreign-pointer.constant-size
180 (with-foreign-pointer (p +two+ size)
181 size)
182 2)
183
184 (deftest mem-ref.left-to-right
185 (let ((i 0))
186 (with-foreign-object (p :char 3)
187 (setf (mem-ref p :char 0) 66 (mem-ref p :char 1) 92)
188 (setf (mem-ref p :char (incf i)) (incf i))
189 (values (mem-ref p :char 0) (mem-ref p :char 1) i)))
190 66 2 2)
191
192 ;;; This needs to be in a real function for at least Allegro CL or the
193 ;;; compiler macro on %MEM-REF is not expanded and the test doesn't
194 ;;; actually test anything!
195 (defun %mem-ref-left-to-right ()
196 (let ((result nil))
197 (with-foreign-object (p :char)
198 (%mem-set 42 p :char)
199 (%mem-ref (progn (push 1 result) p) :char (progn (push 2 result) 0))
200 (nreverse result))))
201
202 ;;; Test left-to-right evaluation of the arguments to %MEM-REF when
203 ;;; optimized by the compiler macro.
204 (deftest %mem-ref.left-to-right
205 (%mem-ref-left-to-right)
206 (1 2))
207
208 ;;; This needs to be in a top-level function for at least Allegro CL
209 ;;; or the compiler macro on %MEM-SET is not expanded and the test
210 ;;; doesn't actually test anything!
211 (defun %mem-set-left-to-right ()
212 (let ((result nil))
213 (with-foreign-object (p :char)
214 (%mem-set (progn (push 1 result) 0)
215 (progn (push 2 result) p)
216 :char
217 (progn (push 3 result) 0))
218 (nreverse result))))
219
220 ;;; Test left-to-right evaluation of the arguments to %MEM-SET when
221 ;;; optimized by the compiler macro.
222 (deftest %mem-set.left-to-right
223 (%mem-set-left-to-right)
224 (1 2 3))
225
226 ;; regression test. mem-aref's setf expansion evaluated its type argument twice.
227 (deftest mem-aref.eval-type-x2
228 (let ((count 0))
229 (with-foreign-pointer (p 1)
230 (setf (mem-aref p (progn (incf count) :char) 0) 127))
231 count)
232 1)
233
234 (deftest mem-aref.left-to-right
235 (let ((count -1))
236 (with-foreign-pointer (p 2)
237 (values
238 (setf (mem-aref p (progn (incf count) :char) (incf count)) (incf count))
239 (setq count -1)
240 (mem-aref (progn (incf count) p) :char (incf count))
241 count)))
242 2 -1 2 1)
243
244 ;; regression tests. nested mem-ref's and mem-aref's had bogus getters
245 (deftest mem-ref.nested
246 (with-foreign-object (p :pointer)
247 (with-foreign-object (i :int)
248 (setf (mem-ref p :pointer) i)
249 (setf (mem-ref i :int) 42)
250 (setf (mem-ref (mem-ref p :pointer) :int) 1984)
251 (mem-ref i :int)))
252 1984)
253
254 (deftest mem-aref.nested
255 (with-foreign-object (p :pointer)
256 (with-foreign-object (i :int 2)
257 (setf (mem-aref p :pointer 0) i)
258 (setf (mem-aref i :int 1) 42)
259 (setf (mem-aref (mem-ref p :pointer 0) :int 1) 1984)
260 (mem-aref i :int 1)))
261 1984)
262
263 (cffi:defcstruct mem-aref.bare-struct
264 (a :uint8))
265
266 ;;; regression test: although mem-aref was dealing with bare struct
267 ;;; types as though they were pointers, it wasn't calculating the
268 ;;; proper offsets. The offsets for bare structs types should be
269 ;;; calculated as aggregate types.
270 (deftest mem-aref.bare-struct
271 (with-foreign-object (a 'mem-aref.bare-struct 2)
272 (eql (- (pointer-address (cffi:mem-aref a 'mem-aref.bare-struct 1))
273 (pointer-address (cffi:mem-aref a 'mem-aref.bare-struct 0)))
274 (foreign-type-size '(:struct mem-aref.bare-struct))))
275 t)
276
277 ;;; regression tests. dereferencing an aggregate type. dereferencing a
278 ;;; struct should return a pointer to the struct itself, not return the
279 ;;; first 4 bytes (or whatever the size of :pointer is) as a pointer.
280 ;;;
281 ;;; This important for accessing an array of structs, which is
282 ;;; what the deref.array-of-aggregates test does.
283 (defcstruct some-struct (x :int))
284
285 (deftest deref.aggregate
286 (with-foreign-object (s 'some-struct)
287 (pointer-eq s (mem-ref s 'some-struct)))
288 t)
289
290 (deftest deref.array-of-aggregates
291 (with-foreign-object (arr 'some-struct 3)
292 (loop for i below 3
293 do (setf (foreign-slot-value (mem-aref arr 'some-struct i)
294 'some-struct 'x)
295 112))
296 (loop for i below 3
297 collect (foreign-slot-value (mem-aref arr 'some-struct i)
298 'some-struct 'x)))
299 (112 112 112))
300
301 ;;; pointer operations
302 (deftest pointer.1
303 (pointer-address (make-pointer 42))
304 42)
305
306 ;;; I suppose this test is not very good. --luis
307 (deftest pointer.2
308 (pointer-address (null-pointer))
309 0)
310
311 (deftest pointer.null
312 (nth-value 0 (ignore-errors (null-pointer-p nil)))
313 nil)
314
315 (deftest foreign-pointer-type.nil
316 (typep nil 'foreign-pointer)
317 nil)
318
319 ;;; Ensure that a pointer to the highest possible address can be
320 ;;; created using MAKE-POINTER. Regression test for CLISP/X86-64.
321 (deftest make-pointer.high
322 (let* ((pointer-length (foreign-type-size :pointer))
323 (high-address (1- (expt 2 (* pointer-length 8))))
324 (pointer (make-pointer high-address)))
325 (- high-address (pointer-address pointer)))
326 0)
327
328 ;;; Ensure that incrementing a pointer by zero bytes returns an
329 ;;; equivalent pointer.
330 (deftest inc-pointer.zero
331 (with-foreign-object (x :int)
332 (pointer-eq x (inc-pointer x 0)))
333 t)
334
335 ;;; Test the INITIAL-ELEMENT keyword argument to FOREIGN-ALLOC.
336 (deftest foreign-alloc.1
337 (let ((ptr (foreign-alloc :int :initial-element 42)))
338 (unwind-protect
339 (mem-ref ptr :int)
340 (foreign-free ptr)))
341 42)
342
343 ;;; Test the INITIAL-ELEMENT and COUNT arguments to FOREIGN-ALLOC.
344 (deftest foreign-alloc.2
345 (let ((ptr (foreign-alloc :int :count 4 :initial-element 100)))
346 (unwind-protect
347 (loop for i from 0 below 4
348 collect (mem-aref ptr :int i))
349 (foreign-free ptr)))
350 (100 100 100 100))
351
352 ;;; Test the INITIAL-CONTENTS and COUNT arguments to FOREIGN-ALLOC,
353 ;;; passing a list of initial values.
354 (deftest foreign-alloc.3
355 (let ((ptr (foreign-alloc :int :count 4 :initial-contents '(4 3 2 1))))
356 (unwind-protect
357 (loop for i from 0 below 4
358 collect (mem-aref ptr :int i))
359 (foreign-free ptr)))
360 (4 3 2 1))
361
362 ;;; Test INITIAL-CONTENTS and COUNT with FOREIGN-ALLOC passing a
363 ;;; vector of initial values.
364 (deftest foreign-alloc.4
365 (let ((ptr (foreign-alloc :int :count 4 :initial-contents #(10 20 30 40))))
366 (unwind-protect
367 (loop for i from 0 below 4
368 collect (mem-aref ptr :int i))
369 (foreign-free ptr)))
370 (10 20 30 40))
371
372 ;;; Ensure calling FOREIGN-ALLOC with both INITIAL-ELEMENT and
373 ;;; INITIAL-CONTENTS signals an error.
374 (deftest foreign-alloc.5
375 (values
376 (ignore-errors
377 (let ((ptr (foreign-alloc :int :initial-element 1
378 :initial-contents '(1))))
379 (foreign-free ptr))
380 t))
381 nil)
382
383 ;;; Regression test: FOREIGN-ALLOC shouldn't actually perform translation
384 ;;; on initial-element/initial-contents since MEM-AREF will do that already.
385 (define-foreign-type not-an-int ()
386 ()
387 (:actual-type :int)
388 (:simple-parser not-an-int))
389
390 (defmethod translate-to-foreign (value (type not-an-int))
391 (assert (not (integerp value)))
392 0)
393
394 (deftest foreign-alloc.6
395 (let ((ptr (foreign-alloc 'not-an-int :initial-element 'foooo)))
396 (foreign-free ptr)
397 t)
398 t)
399
400 ;;; Ensure calling FOREIGN-ALLOC with NULL-TERMINATED-P and a non-pointer
401 ;;; type signals an error.
402 (deftest foreign-alloc.7
403 (values
404 (ignore-errors
405 (let ((ptr (foreign-alloc :int :null-terminated-p t)))
406 (foreign-free ptr))
407 t))
408 nil)
409
410 ;;; The opposite of the above test.
411 (defctype pointer-alias :pointer)
412
413 (deftest foreign-alloc.8
414 (progn
415 (foreign-free (foreign-alloc 'pointer-alias :count 0 :null-terminated-p t))
416 t)
417 t)
418
419 ;;; Ensure calling FOREIGN-ALLOC with NULL-TERMINATED-P actually places
420 ;;; a null pointer at the end. Not a very reliable test apparently.
421 (deftest foreign-alloc.9
422 (let ((ptr (foreign-alloc :pointer :count 0 :null-terminated-p t)))
423 (unwind-protect
424 (null-pointer-p (mem-ref ptr :pointer))
425 (foreign-free ptr)))
426 t)
427
428 ;;; RT: FOREIGN-ALLOC with :COUNT 0 on CLISP signalled an error.
429 (deftest foreign-alloc.10
430 (null (foreign-free (foreign-alloc :char :count 0)))
431 t)
432
433 ;;; Tests for mem-ref with a non-constant type. This is a way to test
434 ;;; the functional interface (without compiler macros).
435
436 (deftest deref.nonconst.char
437 (let ((type :char))
438 (with-foreign-object (p type)
439 (setf (mem-ref p type) -127)
440 (mem-ref p type)))
441 -127)
442
443 (deftest deref.nonconst.unsigned-char
444 (let ((type :unsigned-char))
445 (with-foreign-object (p type)
446 (setf (mem-ref p type) 255)
447 (mem-ref p type)))
448 255)
449
450 (deftest deref.nonconst.short
451 (let ((type :short))
452 (with-foreign-object (p type)
453 (setf (mem-ref p type) -32767)
454 (mem-ref p type)))
455 -32767)
456
457 (deftest deref.nonconst.unsigned-short
458 (let ((type :unsigned-short))
459 (with-foreign-object (p type)
460 (setf (mem-ref p type) 65535)
461 (mem-ref p type)))
462 65535)
463
464 (deftest deref.nonconst.int
465 (let ((type :int))
466 (with-foreign-object (p type)
467 (setf (mem-ref p type) -131072)
468 (mem-ref p type)))
469 -131072)
470
471 (deftest deref.nonconst.unsigned-int
472 (let ((type :unsigned-int))
473 (with-foreign-object (p type)
474 (setf (mem-ref p type) 262144)
475 (mem-ref p type)))
476 262144)
477
478 (deftest deref.nonconst.long
479 (let ((type :long))
480 (with-foreign-object (p type)
481 (setf (mem-ref p type) -536870911)
482 (mem-ref p type)))
483 -536870911)
484
485 (deftest deref.nonconst.unsigned-long
486 (let ((type :unsigned-long))
487 (with-foreign-object (p type)
488 (setf (mem-ref p type) 536870912)
489 (mem-ref p type)))
490 536870912)
491
492 #+(and darwin openmcl)
493 (pushnew 'deref.nonconst.long-long rt::*expected-failures*)
494
495 (deftest deref.nonconst.long-long
496 (let ((type :long-long))
497 (with-foreign-object (p type)
498 (setf (mem-ref p type) -9223372036854775807)
499 (mem-ref p type)))
500 -9223372036854775807)
501
502 (deftest deref.nonconst.unsigned-long-long
503 (let ((type :unsigned-long-long))
504 (with-foreign-object (p type)
505 (setf (mem-ref p type) 18446744073709551615)
506 (mem-ref p type)))
507 18446744073709551615)
508
509 (deftest deref.nonconst.float.1
510 (let ((type :float))
511 (with-foreign-object (p type)
512 (setf (mem-ref p type) 0.0)
513 (mem-ref p type)))
514 0.0)
515
516 (deftest deref.nonconst.float.2
517 (let ((type :float))
518 (with-foreign-object (p type)
519 (setf (mem-ref p type) *float-max*)
520 (mem-ref p type)))
521 #.*float-max*)
522
523 (deftest deref.nonconst.float.3
524 (let ((type :float))
525 (with-foreign-object (p type)
526 (setf (mem-ref p type) *float-min*)
527 (mem-ref p type)))
528 #.*float-min*)
529
530 (deftest deref.nonconst.double.1
531 (let ((type :double))
532 (with-foreign-object (p type)
533 (setf (mem-ref p type) 0.0d0)
534 (mem-ref p type)))
535 0.0d0)
536
537 (deftest deref.nonconst.double.2
538 (let ((type :double))
539 (with-foreign-object (p type)
540 (setf (mem-ref p type) *double-max*)
541 (mem-ref p type)))
542 #.*double-max*)
543
544 (deftest deref.nonconst.double.3
545 (let ((type :double))
546 (with-foreign-object (p type)
547 (setf (mem-ref p type) *double-min*)
548 (mem-ref p type)))
549 #.*double-min*)
550
551 ;;; regression tests: lispworks's %mem-ref and %mem-set compiler
552 ;;; macros were misbehaving.
553
554 (defun mem-ref-rt-1 ()
555 (with-foreign-object (a :int 2)
556 (setf (mem-aref a :int 0) 123
557 (mem-aref a :int 1) 456)
558 (values (mem-aref a :int 0) (mem-aref a :int 1))))
559
560 (deftest mem-ref.rt.1
561 (mem-ref-rt-1)
562 123 456)
563
564 (defun mem-ref-rt-2 ()
565 (with-foreign-object (a :double 2)
566 (setf (mem-aref a :double 0) 123.0d0
567 (mem-aref a :double 1) 456.0d0)
568 (values (mem-aref a :double 0) (mem-aref a :double 1))))
569
570 (deftest mem-ref.rt.2
571 (mem-ref-rt-2)
572 123.0d0 456.0d0)
573
574 (deftest incf-pointer.1
575 (let ((ptr (null-pointer)))
576 (incf-pointer ptr)
577 (pointer-address ptr))
578 1)
579
580 (deftest incf-pointer.2
581 (let ((ptr (null-pointer)))
582 (incf-pointer ptr 42)
583 (pointer-address ptr))
584 42)
585
586 (deftest pointerp.1
587 (values
588 (pointerp (null-pointer))
589 (null-pointer-p (null-pointer))
590 (typep (null-pointer) 'foreign-pointer))
591 t t t)
592
593 (deftest pointerp.2
594 (let ((p (make-pointer #xFEFF)))
595 (values
596 (pointerp p)
597 (typep p 'foreign-pointer)))
598 t t)
599
600 (deftest pointerp.3
601 (pointerp 'not-a-pointer)
602 nil)
603
604 (deftest pointerp.4
605 (pointerp 42)
606 nil)
607
608 (deftest pointerp.5
609 (pointerp 0)
610 nil)
611
612 (deftest pointerp.6
613 (pointerp nil)
614 nil)
615
616 (deftest mem-ref.setf.1
617 (with-foreign-object (p :char)
618 (setf (mem-ref p :char) 42))
619 42)
620
621 (define-foreign-type int+1 ()
622 ()
623 (:actual-type :int)
624 (:simple-parser int+1))
625
626 (defmethod translate-to-foreign (value (type int+1))
627 (1+ value))
628
629 (defmethod translate-from-foreign (value (type int+1))
630 (1+ value))
631
632 (deftest mem-ref.setf.2
633 (with-foreign-object (p 'int+1)
634 (values (setf (mem-ref p 'int+1) 42)
635 (mem-ref p 'int+1)))
636 42 ; should this be 43?
637 44)
638
639 (deftest pointer-eq.non-pointers.1
640 (expecting-error (pointer-eq 1 2))
641 :error)
642
643 (deftest pointer-eq.non-pointers.2
644 (expecting-error (pointer-eq 'a 'b))
645 :error)
646
647 (deftest null-pointer-p.non-pointer.1
648 (expecting-error (null-pointer-p 'not-a-pointer))
649 :error)
650
651 (deftest null-pointer-p.non-pointer.2
652 (expecting-error (null-pointer-p 0))
653 :error)
654
655 (deftest null-pointer-p.non-pointer.3
656 (expecting-error (null-pointer-p nil))
657 :error)