1.0.39: will be tagged as sbcl_1_0_39
[sbcl.git] / tests / seq.pure.lisp
1 ;;;; tests related to sequences
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
8 ;;;; from CMU CL.
9 ;;;;
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
13
14 (in-package :cl-user)
15
16 ;;; As reported by Paul Dietz from his ansi-test suite for gcl, REMOVE
17 ;;; malfunctioned when given :START, :END and :FROM-END arguments.
18 ;;; Make sure it doesn't happen again.
19 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7))
20        (x (copy-seq orig))
21        (y (remove 3 x :from-end t :start 1 :end 5))
22        (z (remove 2 x :from-end t :start 1 :end 5)))
23   (assert (equalp orig x))
24   (assert (equalp y '(1 2 2 6 1 2 4 1 3 2 7)))
25   (assert (equalp z '(1 3 6 1 2 4 1 3 2 7))))
26
27 ;;; Similarly, NSUBSTITUTE and friends were getting things wrong with
28 ;;; :START, :END and :FROM-END:
29 (assert
30  (loop for i from 0 to 9 always
31        (loop for j from i to 10 always
32              (loop for c from 0 to (- j i) always
33                    (let* ((orig '(a a a a a a a a a a))
34                           (x (copy-seq orig))
35                           (y (nsubstitute 'x 'a x :start i :end j :count c)))
36                      (equal y (nconc (make-list i :initial-element 'a)
37                                      (make-list c :initial-element 'x)
38                                      (make-list (- 10 (+ i c))
39                                                 :initial-element 'a))))))))
40
41 (assert
42  (loop for i from 0 to 9 always
43        (loop for j from i to 10 always
44              (loop for c from 0 to (- j i) always
45                    (let* ((orig '(a a a a a a a a a a))
46                           (x (copy-seq orig))
47                           (y (nsubstitute-if 'x (lambda (x) (eq x 'a)) x
48                                              :start i :end j
49                                              :count c :from-end t)))
50                      (equal y (nconc (make-list (- j c) :initial-element 'a)
51                                      (make-list c :initial-element 'x)
52                                      (make-list (- 10 j)
53                                                 :initial-element 'a))))))))
54 (assert
55  (loop for i from 0 to 9 always
56        (loop for j from i to 10 always
57              (loop for c from 0 to (- j i) always
58                    (let* ((orig '(a a a a a a a a a a))
59                           (x (copy-seq orig))
60                           (y (nsubstitute-if-not 'x (lambda (x)
61                                                       (not (eq x 'a))) x
62                                                  :start i :end j
63                                                  :count c :from-end t)))
64                      (equal y (nconc (make-list (- j c) :initial-element 'a)
65                                      (make-list c :initial-element 'x)
66                                      (make-list (- 10 j)
67                                                 :initial-element 'a))))))))
68
69 ;;; And equally similarly, REMOVE-DUPLICATES misbehaved when given
70 ;;; :START arguments:
71
72 (let ((orig (list 0 1 2 0 1 2 0 1 2 0 1 2)))
73   (assert (equalp (remove-duplicates orig :start 3 :end 9) '(0 1 2 0 1 2 0 1 2)))
74   (assert (equalp (delete-duplicates orig :start 3 :end 9) '(0 1 2 0 1 2 0 1 2))))
75
76 ;;; tests of COUNT
77 (assert (= 1 (count 1 '(1 2 3))))
78 (assert (= 2 (count 'z #(z 1 2 3 z))))
79 (assert (= 0 (count 'y '(z 1 2 3 z))))
80
81 ;;; tests of COUNT-IF and COUNT-IF-NOT
82 (macrolet (;; the guts of CCI, abstracted over whether we're testing
83            ;; COUNT-IF or COUNT-IF-NOT
84            (%cci (expected count-if test sequence-as-list &rest keys)
85              `(let* ((list ',sequence-as-list)
86                      (simple-vector (coerce list 'simple-vector))
87                      (length (length list))
88                      (vector (make-array (* 2 length) :fill-pointer length)))
89                 (replace vector list :end1 length)
90                 (dolist (seq (list list simple-vector vector))
91                   (assert (= ,expected (,count-if ,test seq ,@keys))))))
92            ;; "Check COUNT-IF"
93            (cci (expected test sequence-as-list &rest keys)
94              `(progn
95                 (format t "~&SEQUENCE-AS-LIST=~S~%" ',sequence-as-list)
96                 (%cci ,expected
97                       count-if
98                       ,test
99                       ,sequence-as-list
100                       ,@keys)
101                 (%cci ,expected
102                       count-if-not
103                       (complement ,test)
104                       ,sequence-as-list
105                       ,@keys))))
106   (cci 1 #'consp (1 (12) 1))
107   (cci 3 #'consp (1 (2) 3 (4) (5) 6))
108   (cci 3 #'consp (1 (2) 3 (4) (5) 6) :from-end t)
109   (cci 2 #'consp (1 (2) 3 (4) (5) 6) :start 2)
110   (cci 0 #'consp (1 (2) 3 (4) (5) 6) :start 2 :end 3)
111   (cci 1 #'consp (1 (2) 3 (4) (5) 6) :start 1 :end 3)
112   (cci 1 #'consp (1 (2) 3 (4) (5) 6) :start 1 :end 2)
113   (cci 0 #'consp (1 (2) 3 (4) (5) 6) :start 2 :end 2)
114   (cci 2 #'zerop (0 10 0 11 12))
115   (cci 1 #'zerop (0 10 0 11 12) :start 1)
116   (cci 2 #'minusp (0 10 0 11 12) :key #'1-)
117   (cci 1 #'minusp (0 10 0 11 12) :key #'1- :end 2))
118 (multiple-value-bind (v e)
119     (ignore-errors (count-if #'zerop '(0 a 0 b c) :start 1))
120   (declare (ignore v))
121   (assert (eql (type-error-datum e) 'a)))
122 (multiple-value-bind (v e)
123     (ignore-errors (count-if #'zerop #(0 a 0 b c) :start 1 :from-end 11))
124   (declare (ignore v))
125   (assert (eql (type-error-datum e) 'c)))
126
127 ;;; :COUNT may be negative and BIGNUM
128 (assert (equal (remove 1 '(1 2 3 1) :count 1) '(2 3 1)))
129 (assert (equal (remove 1 '(1 2 3 1) :count (* 2 most-positive-fixnum)) '(2 3)))
130 (assert (equal (remove 1 '(1 2 3 1) :count (* -2 most-positive-fixnum)) '(1 2 3 1)))
131
132 ;;; bug reported by Wolfgang Jenkner on sbcl-devel 2003-01-04:
133 ;;; embedded calls of SORT do not work
134 (assert (equal (sort (list 0 0 0) (lambda (x y) (sort (list 0 0 0) #'<) nil))
135                '(0 0 0)))
136 (assert (equal (sort (list 0 0 0 0 0)
137                      (lambda (x y)
138                        (declare (ignore x y))
139                        (block compare
140                          (sort (make-list 11 :initial-element 1)
141                                (let ((counter 7))
142                                  (lambda (x y)
143                                    (declare (ignore x y))
144                                    (when (= (decf counter) 0)
145                                      (return-from compare nil))
146                                    t))))))
147                '(0 0 0 0 0)))
148
149 ;;; miscellaneous sanity checks on stuff which could've been broken by
150 ;;; changes in MERGE-LIST* in sbcl-0.7.11.*
151 (assert (equal (merge 'list () () '<) ()))
152 (assert (equal (merge 'list () (list 1) #'< :key 'identity) '(1)))
153 (assert (equal (merge 'list (list 2) () '>) '(2)))
154 (assert (equal (merge 'list (list 1 2 4) (list 2 3 7) '<) '(1 2 2 3 4 7)))
155 (assert (equal (merge 'list (list 1 2 4) (list -2 3 7) #'<) '(-2 1 2 3 4 7)))
156 (assert (equal (merge 'list (list 1 2 4) (vector -2 3 7) '< :key 'abs)
157                '(1 2 -2 3 4 7)))
158 (assert (equal (merge 'list (list 1 -2 4) (list -2 3 7) '< :key #'abs)
159                '(1 -2 -2 3 4 7)))
160 (assert (equal (stable-sort (list 1 10 2 12 13 3) '<) '(1 2 3 10 12 13)))
161 (assert (equal (stable-sort (list 1 10 2 12 13 3) #'< :key '-)
162                '(13 12 10 3 2 1)))
163 (assert (equal (stable-sort (list 1 10 2 12 13 3) '> :key #'-)
164                '(1 2 3 10 12 13)))
165 (assert (equal (stable-sort (list 1 2 3 -3 -2 -1) '< :key 'abs)
166                '(1 -1 2 -2 3 -3)))
167
168 ;;; CSR broke FILL by not returning the sequence argument in a transform.
169 (let* ((s1 (copy-seq "abcde"))
170        (s2 (fill s1 #\z)))
171   (assert s2)
172   (assert (string= s2 "zzzzz")))
173
174 ;;; POSITION on displaced arrays with non-zero offset has been broken
175 ;;; for quite a while...
176 (let ((fn (compile nil '(lambda (x) (position x)))))
177   (let* ((x #(1 2 3))
178          (y (make-array 2 :displaced-to x :displaced-index-offset 1)))
179     (assert (= (position 2 y) 0))))
180
181 ;;; (SIMPLE-STRING) is a legal type specifier for creation functions
182 (let ((a (make-sequence '(simple-string) 5))
183       (b (concatenate '(simple-string) "a" "bdec"))
184       (c (map '(simple-string) 'identity "abcde"))
185       (d (merge '(simple-string) (copy-seq "acd") (copy-seq "be") 'char>))
186       (e (coerce '(#\a #\b #\c #\e #\d) '(simple-string))))
187   (assert (= (length a) 5))
188   (assert (string= b "abdec"))
189   (assert (string= c "abcde"))
190   (assert (string= d "beacd"))
191   (assert (string= e "abced")))
192
193 ;;; COPY-SEQ "should be prepared to signal an error if sequence is not
194 ;;; a proper sequence".
195 (locally (declare (optimize safety))
196   (multiple-value-bind (seq err) (ignore-errors (copy-seq '(1 2 3 . 4)))
197     (assert (not seq))
198     (assert (typep err 'type-error))))
199
200 ;;; UBX-BASH-COPY transform had an inconsistent return type
201 (let ((sb-c::*check-consistency* t))
202   (handler-bind ((warning #'error))
203     (compile nil
204              '(lambda (l)
205                (declare (type fixnum l))
206                (let* ((bsize 128)
207                       (b1 (make-array bsize :element-type '(unsigned-byte 8)))
208                       (b2 (make-array l :element-type '(unsigned-byte 8))))
209                  (replace b1 b2 :start2 0 :end2 l))))))
210
211 (with-test (:name :bug-452008)
212   ;; FIND & POSITION on lists should check bounds and (in safe code) detect
213   ;; circular and dotted lists.
214   (macrolet ((test (type lambda)
215                `(let ((got (handler-case
216                                (funcall (compile nil ',lambda))
217                              (,type () :error)
218                              (:no-error (res)
219                                (list :no-error res)))))
220                   (let ((*print-circle* t))
221                     (format t "test: ~S~%" ',lambda))
222                   (unless (eq :error got)
223                     (error "wanted an error, got ~S for~%  ~S"
224                            (second got) ',lambda)))))
225     (test sb-kernel:bounding-indices-bad-error
226           (lambda ()
227             (find :foo '(1 2 3 :foo) :start 1 :end 5 :from-end t)))
228     (test sb-kernel:bounding-indices-bad-error
229           (lambda ()
230             (position :foo '(1 2 3 :foo) :start 1 :end 5 :from-end t)))
231     (test sb-kernel:bounding-indices-bad-error
232           (lambda ()
233             (find :foo '(1 2 3 :foo) :start 3 :end 0 :from-end t)))
234     (test sb-kernel:bounding-indices-bad-error
235           (lambda ()
236             (position :foo '(1 2 3 :foo) :start 3 :end 0 :from-end t)))
237     (test type-error
238           (lambda ()
239             (let ((list (list 1 2 3 :foo)))
240               (find :bar (nconc list list)))))
241     (test type-error
242           (lambda ()
243             (let ((list (list 1 2 3 :foo)))
244               (position :bar (nconc list list)))))))
245
246 (with-test (:name :bug-554385)
247   ;; FIND-IF shouldn't look through the entire list.
248   (assert (= 2 (find-if #'evenp '(1 2 1 1 1 1 1 1 1 1 1 1 :foo))))
249   ;; Even though the end bounds are incorrect, the
250   ;; element is found before that's an issue.
251   (assert (eq :foo (find :foo '(1 2 3 :foo) :start 1 :end 5)))
252   (assert (= 3 (position :foo '(1 2 3 :foo) :start 1 :end 5))))