0.8.13.72: MORE CHAPTERS
[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 ;;; As reported by Paul Dietz from his ansi-test suite for gcl, REMOVE
15 ;;; malfunctioned when given :START, :END and :FROM-END arguments.
16 ;;; Make sure it doesn't happen again.
17 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7))
18        (x (copy-seq orig))
19        (y (remove 3 x :from-end t :start 1 :end 5))
20        (z (remove 2 x :from-end t :start 1 :end 5)))
21   (assert (equalp orig x))
22   (assert (equalp y '(1 2 2 6 1 2 4 1 3 2 7)))
23   (assert (equalp z '(1 3 6 1 2 4 1 3 2 7))))
24
25 ;;; Similarly, NSUBSTITUTE and friends were getting things wrong with
26 ;;; :START, :END and :FROM-END:
27 (assert
28  (loop for i from 0 to 9 always
29        (loop for j from i to 10 always
30              (loop for c from 0 to (- j i) always
31                    (let* ((orig '(a a a a a a a a a a))
32                           (x (copy-seq orig))
33                           (y (nsubstitute 'x 'a x :start i :end j :count c)))
34                      (equal y (nconc (make-list i :initial-element 'a)
35                                      (make-list c :initial-element 'x)
36                                      (make-list (- 10 (+ i c))
37                                                 :initial-element 'a))))))))
38
39 (assert
40  (loop for i from 0 to 9 always
41        (loop for j from i to 10 always
42              (loop for c from 0 to (- j i) always
43                    (let* ((orig '(a a a a a a a a a a))
44                           (x (copy-seq orig))
45                           (y (nsubstitute-if 'x (lambda (x) (eq x 'a)) x
46                                              :start i :end j
47                                              :count c :from-end t)))
48                      (equal y (nconc (make-list (- j c) :initial-element 'a)
49                                      (make-list c :initial-element 'x)
50                                      (make-list (- 10 j)
51                                                 :initial-element 'a))))))))
52 (assert
53  (loop for i from 0 to 9 always
54        (loop for j from i to 10 always
55              (loop for c from 0 to (- j i) always
56                    (let* ((orig '(a a a a a a a a a a))
57                           (x (copy-seq orig))
58                           (y (nsubstitute-if-not 'x (lambda (x)
59                                                       (not (eq x 'a))) x
60                                                  :start i :end j
61                                                  :count c :from-end t)))
62                      (equal y (nconc (make-list (- j c) :initial-element 'a)
63                                      (make-list c :initial-element 'x)
64                                      (make-list (- 10 j)
65                                                 :initial-element 'a))))))))
66
67 ;;; tests of COUNT
68 (assert (= 1 (count 1 '(1 2 3))))
69 (assert (= 2 (count 'z #(z 1 2 3 z))))
70 (assert (= 0 (count 'y '(z 1 2 3 z))))
71
72 ;;; tests of COUNT-IF and COUNT-IF-NOT
73 (macrolet (;; the guts of CCI, abstracted over whether we're testing
74            ;; COUNT-IF or COUNT-IF-NOT
75            (%cci (expected count-if test sequence-as-list &rest keys)
76              `(let* ((list ',sequence-as-list)
77                      (simple-vector (coerce list 'simple-vector))
78                      (length (length list))
79                      (vector (make-array (* 2 length) :fill-pointer length)))
80                 (replace vector list :end1 length)
81                 (dolist (seq (list list simple-vector vector))
82                   (assert (= ,expected (,count-if ,test seq ,@keys))))))
83            ;; "Check COUNT-IF"
84            (cci (expected test sequence-as-list &rest keys) 
85              `(progn
86                 (format t "~&SEQUENCE-AS-LIST=~S~%" ',sequence-as-list)
87                 (%cci ,expected
88                       count-if
89                       ,test
90                       ,sequence-as-list
91                       ,@keys)
92                 (%cci ,expected
93                       count-if-not
94                       (complement ,test)
95                       ,sequence-as-list
96                       ,@keys))))
97   (cci 1 #'consp (1 (12) 1))
98   (cci 3 #'consp (1 (2) 3 (4) (5) 6))
99   (cci 3 #'consp (1 (2) 3 (4) (5) 6) :from-end t)
100   (cci 2 #'consp (1 (2) 3 (4) (5) 6) :start 2)
101   (cci 0 #'consp (1 (2) 3 (4) (5) 6) :start 2 :end 3)
102   (cci 1 #'consp (1 (2) 3 (4) (5) 6) :start 1 :end 3)
103   (cci 1 #'consp (1 (2) 3 (4) (5) 6) :start 1 :end 2)
104   (cci 0 #'consp (1 (2) 3 (4) (5) 6) :start 2 :end 2)
105   (cci 2 #'zerop (0 10 0 11 12))
106   (cci 1 #'zerop (0 10 0 11 12) :start 1)
107   (cci 2 #'minusp (0 10 0 11 12) :key #'1-)
108   (cci 1 #'minusp (0 10 0 11 12) :key #'1- :end 2))
109 (multiple-value-bind (v e)
110     (ignore-errors (count-if #'zerop '(0 a 0 b c) :start 1))
111   (declare (ignore v))
112   (assert (eql (type-error-datum e) 'a)))
113 (multiple-value-bind (v e)
114     (ignore-errors (count-if #'zerop #(0 a 0 b c) :start 1 :from-end 11))
115   (declare (ignore v))
116   (assert (eql (type-error-datum e) 'c)))
117
118 ;;; :COUNT may be negative and BIGNUM
119 (assert (equal (remove 1 '(1 2 3 1) :count 1) '(2 3 1)))
120 (assert (equal (remove 1 '(1 2 3 1) :count (* 2 most-positive-fixnum)) '(2 3)))
121 (assert (equal (remove 1 '(1 2 3 1) :count (* -2 most-positive-fixnum)) '(1 2 3 1)))
122
123 ;;; bug reported by Wolfgang Jenkner on sbcl-devel 2003-01-04:
124 ;;; embedded calls of SORT do not work
125 (assert (equal (sort (list 0 0 0) (lambda (x y) (sort (list 0 0 0) #'<) nil))
126                '(0 0 0)))
127 (assert (equal (sort (list 0 0 0 0 0)
128                      (lambda (x y)
129                        (declare (ignore x y))
130                        (block compare
131                          (sort (make-list 11 :initial-element 1)
132                                (let ((counter 7))
133                                  (lambda (x y)
134                                    (declare (ignore x y))
135                                    (when (= (decf counter) 0)
136                                      (return-from compare nil))
137                                    t))))))
138                '(0 0 0 0 0)))
139
140 ;;; miscellaneous sanity checks on stuff which could've been broken by
141 ;;; changes in MERGE-LIST* in sbcl-0.7.11.*
142 (assert (equal (merge 'list () () '<) ()))
143 (assert (equal (merge 'list () (list 1) #'< :key 'identity) '(1)))
144 (assert (equal (merge 'list (list 2) () '>) '(2)))
145 (assert (equal (merge 'list (list 1 2 4) (list 2 3 7) '<) '(1 2 2 3 4 7)))
146 (assert (equal (merge 'list (list 1 2 4) (list -2 3 7) #'<) '(-2 1 2 3 4 7)))
147 (assert (equal (merge 'list (list 1 2 4) (vector -2 3 7) '< :key 'abs)
148                '(1 2 -2 3 4 7)))
149 (assert (equal (merge 'list (list 1 -2 4) (list -2 3 7) '< :key #'abs)
150                '(1 -2 -2 3 4 7)))
151 (assert (equal (stable-sort (list 1 10 2 12 13 3) '<) '(1 2 3 10 12 13)))
152 (assert (equal (stable-sort (list 1 10 2 12 13 3) #'< :key '-)
153                '(13 12 10 3 2 1)))
154 (assert (equal (stable-sort (list 1 10 2 12 13 3) '> :key #'-)
155                '(1 2 3 10 12 13)))
156 (assert (equal (stable-sort (list 1 2 3 -3 -2 -1) '< :key 'abs)
157                '(1 -1 2 -2 3 -3)))
158
159 ;;; CSR broke FILL by not returning the sequence argument in a transform.
160 (let* ((s1 (copy-seq "abcde"))
161        (s2 (fill s1 #\z)))
162   (assert s2)
163   (assert (string= s2 "zzzzz")))