Commit b9959181 authored by pfdietz's avatar pfdietz

Add tests for VECTOR-PUSH-EXTEND on displaced vectors.

parent d03be51a
......@@ -2,8 +2,6 @@ Things to do to the test suite (not a complete list)
1. subtypep and typep on complex types
2. upgraded-complex-part-type
3. More type tests on array types
4. Extend random subtypep tester to complex and array types.
......@@ -29,11 +27,6 @@ Things to do to the test suite (not a complete list)
14. Finish testing DEFSETF
15. All tests for DO-ALL-SYMBOLS
16. Test VECTOR-PUSH-EXTEND on displaced vectors, etc. (just like adjust-array;
see 6.)
17. Tests that have an argument that provides a return value for special
conditions (like eof) that happens to be the same as a normal value the
functions would return (suggested by CR).
......
......@@ -252,6 +252,153 @@
5 5 6 nil #(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0 0.0l0))
;;; Tests on displaced arrays
(deftest vector-push-extend.21
(let* ((a1 (make-array 10 :initial-element nil))
(a2 (make-array 6 :displaced-to a1
:displaced-index-offset 2
:fill-pointer 0)))
(values
(fill-pointer a2)
(map 'list #'identity a2)
(vector-push-extend 'foo a2)
(fill-pointer a2)
(map 'list #'identity a2)
(map 'list #'identity a1)))
0
()
0
1
(foo)
(nil nil foo nil nil nil nil nil nil nil))
(deftest vector-push-extend.22
(let* ((a1 (make-array 6 :initial-element nil))
(a2 (make-array 0 :displaced-to a1
:displaced-index-offset 2
:adjustable t
:fill-pointer 0)))
(values
(fill-pointer a2)
(map 'list #'identity a2)
(vector-push-extend 'foo a2)
(fill-pointer a2)
(map 'list #'identity a2)
(map 'list #'identity a1)
(notnot (adjustable-array-p a2))
(multiple-value-list (array-displacement a2))
))
0
()
0
1
(foo)
(nil nil nil nil nil nil)
t
(nil 0))
(deftest vector-push-extend.23
(let* ((a1 (make-array 10 :initial-element nil))
(a2 (make-array 6 :displaced-to a1
:displaced-index-offset 2
:adjustable t
:fill-pointer 1)))
(values
(fill-pointer a2)
(map 'list #'identity a2)
(vector-push-extend 'foo a2)
(fill-pointer a2)
(map 'list #'identity a2)
(map 'list #'identity a1)
(notnot (adjustable-array-p a2))
(eqt (array-displacement a2) a1)
(nth-value 1 (array-displacement a2))
))
1
(nil)
1
2
(nil foo)
(nil nil nil foo nil nil nil nil nil nil)
t
t
2)
(deftest vector-push-extend.24
(let* ((a1 (make-array 4 :initial-element nil))
(a2 (make-array 2 :displaced-to a1
:displaced-index-offset 2
:adjustable t
:fill-pointer 2)))
(values
(map 'list #'identity a1)
(map 'list #'identity a2)
(vector-push-extend 'foo a2 7)
(fill-pointer a2)
(map 'list #'identity a1)
(map 'list #'identity a2)
(array-dimension a2 0)
(notnot (adjustable-array-p a2))
(multiple-value-list (array-displacement a2))))
(nil nil nil nil)
(nil nil)
2
3
(nil nil nil nil)
(nil nil foo)
9
t
(nil 0))
;;; Integer vectors
(deftest vector-push-extend.25
(loop for adj in '(nil t)
nconc
(loop for bits from 1 to 64
for etype = `(unsigned-byte ,bits)
for a1 = (make-array 10 :initial-element 0
:element-type etype)
for a2 =(make-array 6
:element-type etype
:displaced-to a1
:displaced-index-offset 2
:adjustable adj
:fill-pointer 0)
for result = (list (fill-pointer a2)
(map 'list #'identity a2)
(vector-push-extend 1 a2)
(fill-pointer a2)
(map 'list #'identity a2)
(map 'list #'identity a1))
unless (equal result '(0 () 0 1 (1) (0 0 1 0 0 0 0 0 0 0)))
collect (list etype adj result)))
nil)
(deftest vector-push-extend.26
(loop for bits from 1 to 64
for etype = `(unsigned-byte ,bits)
for a1 = (make-array 8 :initial-element 0
:element-type etype)
for a2 = (make-array 6
:element-type etype
:displaced-to a1
:displaced-index-offset 2
:adjustable t
:fill-pointer 6)
for result = (list (fill-pointer a2)
(map 'list #'identity a2)
(vector-push-extend 1 a2)
(fill-pointer a2)
(map 'list #'identity a2)
(map 'list #'identity a1)
(notnot (adjustable-array-p a2))
(multiple-value-list (array-displacement a1)))
unless (equal result '(6 (0 0 0 0 0 0) 6 7 (0 0 0 0 0 0 1)
(0 0 0 0 0 0 0 0) t (nil 0)))
collect (list etype result))
nil)
;;; Error tests
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment