source: trunk/source/tests/ansi-tests/substitute-if.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 25.5 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat Aug 31 17:42:04 2002
4;;;; Contains: Tests for SUBSTITUTE-IF
5
6(in-package :cl-test)
7
8(deftest substitute-if-list.1
9  (let ((x '())) (values (substitute-if 'b #'identity x) x))
10  nil nil)
11
12(deftest substitute-if-list.2
13  (let ((x '(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x) x))
14  (b b b c)
15  (a b a c))
16
17(deftest substitute-if-list.3
18  (let ((x '(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count nil) x))
19  (b b b c)
20  (a b a c))
21
22(deftest substitute-if-list.4
23  (let ((x '(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count 2) x))
24  (b b b c)
25  (a b a c))
26
27(deftest substitute-if-list.5
28  (let ((x '(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count 1) x))
29  (b b a c)
30  (a b a c))
31
32(deftest substitute-if-list.6
33  (let ((x '(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count 0) x))
34  (a b a c)
35  (a b a c))
36
37(deftest substitute-if-list.7
38  (let ((x '(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count -1) x))
39  (a b a c)
40  (a b a c))
41
42(deftest substitute-if-list.8
43  (let ((x '())) (values (substitute-if 'b (is-eql-p 'a) x :from-end t) x))
44  nil nil)
45
46(deftest substitute-if-list.9
47  (let ((x '(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :from-end t) x))
48  (b b b c)
49  (a b a c))
50
51(deftest substitute-if-list.10
52  (let ((x '(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :from-end t :count nil) x))
53  (b b b c)
54  (a b a c))
55
56(deftest substitute-if-list.11
57  (let ((x '(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count 2 :from-end t) x))
58  (b b b c)
59  (a b a c))
60
61(deftest substitute-if-list.12
62  (let ((x '(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count 1 :from-end t) x))
63  (a b b c)
64  (a b a c))
65
66(deftest substitute-if-list.13
67  (let ((x '(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count 0 :from-end t) x))
68  (a b a c)
69  (a b a c))
70
71(deftest substitute-if-list.14
72  (let ((x '(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count -1 :from-end t) x))
73  (a b a c)
74  (a b a c))
75
76(deftest substitute-if-list.15
77  (loop for i from 0 to 9 always
78        (loop for j from i to 10 always
79              (let* ((orig '(a a a a a a a a a a))
80                     (x (copy-seq orig))
81                     (y (substitute-if 'x (is-eql-p 'a) x :start i :end j)))
82                (and (equal orig x)
83                     (equal y (nconc (make-list i :initial-element 'a)
84                                     (make-list (- j i) :initial-element 'x)
85                                     (make-list (- 10 j) :initial-element 'a)))))))
86  t)
87
88(deftest substitute-if-list.16
89  (loop for i from 0 to 9 always
90        (loop for j from i to 10 always
91              (let* ((orig '(a a a a a a a a a a))
92                     (x (copy-seq orig))
93                     (y (substitute-if 'x (is-eql-p 'a) x :start i :end j :from-end t)))
94                (and (equal orig x)
95                     (equal y (nconc (make-list i :initial-element 'a)
96                                     (make-list (- j i) :initial-element 'x)
97                                     (make-list (- 10 j) :initial-element 'a)))))))
98  t)
99
100(deftest substitute-if-list.17
101  (loop for i from 0 to 9 always
102        (loop for j from i to 10 always
103              (loop for c from 0 to (- j i) always
104                    (let* ((orig '(a a a a a a a a a a))
105                           (x (copy-seq orig))
106                           (y (substitute-if 'x (is-eql-p 'a) x :start i :end j :count c)))
107                      (and (equal orig x)
108                           (equal y (nconc (make-list i :initial-element 'a)
109                                           (make-list c :initial-element 'x)
110                                           (make-list (- 10 (+ i c)) :initial-element 'a))))))))
111  t)
112
113(deftest substitute-if-list.18
114  (loop for i from 0 to 9 always
115        (loop for j from i to 10 always
116              (loop for c from 0 to (- j i) always
117                    (let* ((orig '(a a a a a a a a a a))
118                           (x (copy-seq orig))
119                           (y (substitute-if 'x (is-eql-p 'a) x :start i :end j :count c :from-end t)))
120                      (and (equal orig x)
121                           (equal y (nconc (make-list (- j c) :initial-element 'a)
122                                           (make-list c :initial-element 'x)
123                                           (make-list (- 10 j) :initial-element 'a))))))))
124  t)
125
126
127;;; Tests on vectors
128
129(deftest substitute-if-vector.1
130  (let ((x #())) (values (substitute-if 'b (is-eql-p 'a) x) x))
131  #() #())
132
133(deftest substitute-if-vector.2
134  (let ((x #(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x) x))
135  #(b b b c)
136  #(a b a c))
137
138(deftest substitute-if-vector.3
139  (let ((x #(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count nil) x))
140  #(b b b c)
141  #(a b a c))
142
143(deftest substitute-if-vector.4
144  (let ((x #(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count 2) x))
145  #(b b b c)
146  #(a b a c))
147
148(deftest substitute-if-vector.5
149  (let ((x #(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count 1) x))
150  #(b b a c)
151  #(a b a c))
152
153(deftest substitute-if-vector.6
154  (let ((x #(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count 0) x))
155  #(a b a c)
156  #(a b a c))
157
158(deftest substitute-if-vector.7
159  (let ((x #(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count -1) x))
160  #(a b a c)
161  #(a b a c))
162
163(deftest substitute-if-vector.8
164  (let ((x #())) (values (substitute-if 'b (is-eql-p 'a) x :from-end t) x))
165  #() #())
166
167(deftest substitute-if-vector.9
168  (let ((x #(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :from-end t) x))
169  #(b b b c)
170  #(a b a c))
171
172(deftest substitute-if-vector.10
173  (let ((x #(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :from-end t :count nil) x))
174  #(b b b c)
175  #(a b a c))
176
177(deftest substitute-if-vector.11
178  (let ((x #(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count 2 :from-end t) x))
179  #(b b b c)
180  #(a b a c))
181
182(deftest substitute-if-vector.12
183  (let ((x #(a b a c)))
184    (values (substitute-if 'b (is-eql-p 'a) x :count 1 :from-end t) x))
185  #(a b b c)
186  #(a b a c))
187
188(deftest substitute-if-vector.13
189  (let ((x #(a b a c)))
190    (values (substitute-if 'b (is-eql-p 'a) x :count 0 :from-end t) x))
191  #(a b a c)
192  #(a b a c))
193
194(deftest substitute-if-vector.14
195  (let ((x #(a b a c)))
196    (values (substitute-if 'b (is-eql-p 'a) x :count -1 :from-end t) x))
197  #(a b a c)
198  #(a b a c))
199
200(deftest substitute-if-vector.15
201  (loop for i from 0 to 9 always
202        (loop for j from i to 10 always
203              (let* ((orig #(a a a a a a a a a a))
204                     (x (copy-seq orig))
205                     (y (substitute-if 'x (is-eql-p 'a) x :start i :end j)))
206                (and (equalp orig x)
207                     (equalp y
208                             (concatenate
209                              'simple-vector
210                              (make-array i :initial-element 'a)
211                              (make-array (- j i) :initial-element 'x)
212                              (make-array (- 10 j) :initial-element 'a)))))))
213  t)
214
215(deftest substitute-if-vector.16
216  (loop for i from 0 to 9 always
217        (loop for j from i to 10 always
218              (let* ((orig #(a a a a a a a a a a))
219                     (x (copy-seq orig))
220                     (y (substitute-if 'x (is-eql-p 'a) x :start i :end j :from-end t)))
221                (and (equalp orig x)
222                     (equalp y
223                             (concatenate
224                              'simple-vector
225                              (make-array i :initial-element 'a)
226                              (make-array (- j i) :initial-element 'x)
227                              (make-array (- 10 j) :initial-element 'a)))))))
228  t)
229
230(deftest substitute-if-vector.17
231  (loop for i from 0 to 9 always
232        (loop for j from i to 10 always
233              (loop for c from 0 to (- j i) always
234                    (let* ((orig #(a a a a a a a a a a))
235                           (x (copy-seq orig))
236                           (y (substitute-if 'x (is-eql-p 'a) x
237                                             :start i :end j :count c)))
238                      (and (equalp orig x)
239                           (equalp
240                            y (concatenate
241                               'simple-vector
242                               (make-array i :initial-element 'a)
243                               (make-array c :initial-element 'x)
244                               (make-array (- 10 (+ i c))
245                                           :initial-element 'a))))))))
246  t)
247
248(deftest substitute-if-vector.18
249  (loop for i from 0 to 9 always
250        (loop for j from i to 10 always
251              (loop for c from 0 to (- j i) always
252                    (let* ((orig #(a a a a a a a a a a))
253                           (x (copy-seq orig))
254                           (y (substitute-if 'x (is-eql-p 'a) x
255                                             :start i :end j :count c
256                                             :from-end t)))
257                      (and (equalp orig x)
258                           (equalp
259                            y
260                            (concatenate
261                             'simple-vector
262                             (make-array (- j c) :initial-element 'a)
263                             (make-array c :initial-element 'x)
264                             (make-array (- 10 j) :initial-element 'a))))))))
265  t)
266
267(deftest substitute-if-vector.28
268  (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f)
269                       :fill-pointer 5))
270         (result (substitute-if 'z (is-eql-p 'a) x)))
271    result)
272  #(z b z c b))
273
274(deftest substitute-if-vector.29
275  (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f)
276                       :fill-pointer 5))
277         (result (substitute-if 'z (is-eql-p 'a) x :from-end t)))
278    result)
279  #(z b z c b))
280
281(deftest substitute-if-vector.30
282  (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f)
283                       :fill-pointer 5))
284         (result (substitute-if 'z (is-eql-p 'a) x :count 1)))
285    result)
286  #(z b a c b))
287
288(deftest substitute-if-vector.31
289  (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f)
290                       :fill-pointer 5))
291         (result (substitute-if 'z (is-eql-p 'a) x :from-end t :count 1)))
292    result)
293  #(a b z c b))
294
295(deftest substitute-if-vector.32
296  (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d)))
297         (v2 (make-array '(8) :displaced-to v1
298                         :displaced-index-offset 3)))
299    (values
300     (substitute-if 'x (is-eql-p 'c) v2 :count 1)
301     v1))
302  #(d a b x d a b c)
303  #(a b c d a b c d a b c d a b c d))
304
305(deftest substitute-if-vector.33
306  (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d)))
307         (v2 (make-array '(8) :displaced-to v1
308                         :displaced-index-offset 3)))
309    (values
310     (substitute-if 'x (is-eql-p 'c) v2 :count 1 :from-end t)
311     v1))
312  #(d a b c d a b x)
313  #(a b c d a b c d a b c d a b c d))
314
315;;; Tests on strings
316
317(deftest substitute-if-string.1
318  (let ((x "")) (values (substitute-if #\b (is-eql-p #\a) x) x))
319  "" "")
320
321(deftest substitute-if-string.2
322  (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x) x))
323  "bbbc"
324  "abac")
325
326(deftest substitute-if-string.3
327  (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count nil) x))
328  "bbbc"
329  "abac")
330
331(deftest substitute-if-string.4
332  (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count 2) x))
333  "bbbc"
334  "abac")
335
336(deftest substitute-if-string.5
337  (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count 1) x))
338  "bbac"
339  "abac")
340
341(deftest substitute-if-string.6
342  (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count 0) x))
343  "abac"
344  "abac")
345
346(deftest substitute-if-string.7
347  (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count -1) x))
348  "abac"
349  "abac")
350
351(deftest substitute-if-string.8
352  (let ((x "")) (values (substitute-if #\b (is-eql-p #\a) x :from-end t) x))
353  "" "")
354
355(deftest substitute-if-string.9
356  (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :from-end t) x))
357  "bbbc"
358  "abac")
359
360(deftest substitute-if-string.10
361  (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :from-end t :count nil) x))
362  "bbbc"
363  "abac")
364
365(deftest substitute-if-string.11
366  (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count 2 :from-end t) x))
367  "bbbc"
368  "abac")
369
370(deftest substitute-if-string.12
371  (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count 1 :from-end t) x))
372  "abbc"
373  "abac")
374
375(deftest substitute-if-string.13
376  (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count 0 :from-end t) x))
377  "abac"
378  "abac")
379
380(deftest substitute-if-string.14
381  (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count -1 :from-end t) x))
382  "abac"
383  "abac")
384
385(deftest substitute-if-string.15
386  (loop for i from 0 to 9 always
387        (loop for j from i to 10 always
388              (let* ((orig "aaaaaaaaaa")
389                     (x (copy-seq orig))
390                     (y (substitute-if #\x (is-eql-p #\a) x :start i :end j)))
391                (and (equalp orig x)
392                     (equalp y (concatenate 'simple-string
393                                           (make-array i :initial-element #\a)
394                                           (make-array (- j i) :initial-element #\x)
395                                           (make-array (- 10 j) :initial-element #\a)))))))
396  t)
397
398(deftest substitute-if-string.16
399  (loop for i from 0 to 9 always
400        (loop for j from i to 10 always
401              (let* ((orig "aaaaaaaaaa")
402                     (x (copy-seq orig))
403                     (y (substitute-if #\x (is-eql-p #\a) x
404                                       :start i :end j :from-end t)))
405                (and (equalp orig x)
406                     (equalp y
407                             (concatenate
408                              'simple-string
409                              (make-array i :initial-element #\a)
410                              (make-array (- j i) :initial-element #\x)
411                              (make-array (- 10 j) :initial-element #\a)))))))
412  t)
413
414(deftest substitute-if-string.17
415  (loop for i from 0 to 9 always
416        (loop for j from i to 10 always
417              (loop for c from 0 to (- j i) always
418                    (let* ((orig "aaaaaaaaaa")
419                           (x (copy-seq orig))
420                           (y (substitute-if #\x (is-eql-p #\a) x
421                                             :start i :end j :count c)))
422                      (and (equalp orig x)
423                           (equalp y
424                                   (concatenate
425                                    'simple-string
426                                    (make-array i :initial-element #\a)
427                                    (make-array c :initial-element #\x)
428                                    (make-array (- 10 (+ i c))
429                                                :initial-element #\a))))))))
430  t)
431
432(deftest substitute-if-string.18
433  (loop for i from 0 to 9 always
434        (loop for j from i to 10 always
435              (loop for c from 0 to (- j i) always
436                    (let* ((orig "aaaaaaaaaa")
437                           (x (copy-seq orig))
438                           (y (substitute-if #\x (is-eql-p #\a) x
439                                             :start i :end j :count c
440                                             :from-end t)))
441                      (and (equalp orig x)
442                           (equalp y (concatenate
443                                      'simple-string
444                                      (make-array (- j c) :initial-element #\a)
445                                      (make-array c :initial-element #\x)
446                                      (make-array (- 10 j)
447                                                  :initial-element #\a))))))))
448  t)
449
450
451(deftest substitute-if-string.28
452  (let* ((x (make-array '(10) :initial-contents "abacbadeaf"
453                       :fill-pointer 5 :element-type 'character))
454         (result (substitute-if #\z (is-eql-p #\a) x)))
455    result)
456  "zbzcb")
457
458(deftest substitute-if-string.29
459  (let* ((x (make-array '(10) :initial-contents "abacbadeaf"
460                       :fill-pointer 5 :element-type 'character))
461         (result (substitute-if #\z (is-eql-p #\a) x :from-end t)))
462    result)
463  "zbzcb")
464
465(deftest substitute-if-string.30
466  (let* ((x (make-array '(10) :initial-contents "abacbadeaf"
467                       :fill-pointer 5 :element-type 'character))
468         (result (substitute-if #\z (is-eql-p #\a) x :count 1)))
469    result)
470  "zbacb")
471
472(deftest substitute-if-string.31
473  (let* ((x (make-array '(10) :initial-contents "abacbadeaf"
474                       :fill-pointer 5 :element-type 'character))
475         (result (substitute-if #\z (is-eql-p #\a) x :from-end t :count 1)))
476    result)
477  "abzcb")
478
479;;; Tests on bit-vectors
480
481(deftest substitute-if-bit-vector.1
482  (let* ((orig #*)
483         (x (copy-seq orig))
484         (result (substitute-if 0 (is-eql-p 1) x)))
485    (and (equalp orig x)
486         result))
487  #*)
488
489(deftest substitute-if-bit-vector.2
490  (let* ((orig #*)
491         (x (copy-seq orig))
492         (result (substitute-if 1 'zerop x)))
493    (and (equalp orig x)
494         result))
495  #*)
496
497(deftest substitute-if-bit-vector.3
498  (let* ((orig #*010101)
499         (x (copy-seq orig))
500         (result (substitute-if 0 (is-eql-p 1) x)))
501    (and (equalp orig x)
502         result))
503  #*000000)
504
505(deftest substitute-if-bit-vector.4
506  (let* ((orig #*010101)
507         (x (copy-seq orig))
508         (result (substitute-if 1 #'zerop x)))
509    (and (equalp orig x)
510         result))
511  #*111111)
512
513(deftest substitute-if-bit-vector.5
514  (let* ((orig #*010101)
515         (x (copy-seq orig))
516         (result (substitute-if 1 #'zerop x :start 1)))
517    (and (equalp orig x)
518         result))
519  #*011111)
520 
521(deftest substitute-if-bit-vector.6
522  (let* ((orig #*010101)
523         (x (copy-seq orig))
524         (result (substitute-if 0 (is-eql-p 1) x :start 2 :end nil)))
525    (and (equalp orig x)
526         result))
527  #*010000)
528
529(deftest substitute-if-bit-vector.7
530  (let* ((orig #*010101)
531         (x (copy-seq orig))
532         (result (substitute-if 1 #'zerop x :end 4)))
533    (and (equalp orig x)
534         result))
535  #*111101)
536 
537(deftest substitute-if-bit-vector.8
538  (let* ((orig #*010101)
539         (x (copy-seq orig))
540         (result (substitute-if 0 (is-eql-p 1) x :end nil)))
541    (and (equalp orig x)
542         result))
543  #*000000)
544
545(deftest substitute-if-bit-vector.9
546  (let* ((orig #*010101)
547         (x (copy-seq orig))
548         (result (substitute-if 0 (is-eql-p 1) x :end 3)))
549    (and (equalp orig x)
550         result))
551  #*000101)
552
553(deftest substitute-if-bit-vector.10
554  (let* ((orig #*010101)
555         (x (copy-seq orig))
556         (result (substitute-if 0 (is-eql-p 1) x :start 2 :end 4)))
557    (and (equalp orig x)
558         result))
559  #*010001)
560
561(deftest substitute-if-bit-vector.11
562  (let* ((orig #*010101)
563         (x (copy-seq orig))
564         (result (substitute-if 1 #'zerop x :start 2 :end 4)))
565    (and (equalp orig x)
566         result))
567  #*011101)
568
569(deftest substitute-if-bit-vector.12
570  (let* ((orig #*010101)
571         (x (copy-seq orig))
572         (result (substitute-if 1 #'zerop x :count 1)))
573    (and (equalp orig x)
574         result))
575  #*110101)
576
577(deftest substitute-if-bit-vector.13
578  (let* ((orig #*010101)
579         (x (copy-seq orig))
580         (result (substitute-if 1 #'zerop x :count 0)))
581    (and (equalp orig x)
582         result))
583  #*010101)
584
585(deftest substitute-if-bit-vector.14
586  (let* ((orig #*010101)
587         (x (copy-seq orig))
588         (result (substitute-if 1 #'zerop x :count -1)))
589    (and (equalp orig x)
590         result))
591  #*010101)
592
593(deftest substitute-if-bit-vector.15
594  (let* ((orig #*010101)
595         (x (copy-seq orig))
596         (result (substitute-if 1 #'zerop x :count 1 :from-end t)))
597    (and (equalp orig x)
598         result))
599  #*010111)
600
601(deftest substitute-if-bit-vector.16
602  (let* ((orig #*010101)
603         (x (copy-seq orig))
604         (result (substitute-if 1 #'zerop x :count 0 :from-end t)))
605    (and (equalp orig x)
606         result))
607  #*010101)
608
609(deftest substitute-if-bit-vector.17
610  (let* ((orig #*010101)
611         (x (copy-seq orig))
612         (result (substitute-if 1 #'zerop x :count -1 :from-end t)))
613    (and (equalp orig x)
614         result))
615  #*010101)
616
617(deftest substitute-if-bit-vector.18
618  (let* ((orig #*010101)
619         (x (copy-seq orig))
620         (result (substitute-if 1 #'zerop x :count nil)))
621    (and (equalp orig x)
622         result))
623  #*111111)
624
625(deftest substitute-if-bit-vector.19
626  (let* ((orig #*010101)
627         (x (copy-seq orig))
628         (result (substitute-if 1 #'zerop x :count nil :from-end t)))
629    (and (equalp orig x)
630         result))
631  #*111111)
632
633(deftest substitute-if-bit-vector.20
634  (loop for i from 0 to 9 always
635        (loop for j from i to 10 always
636              (loop for c from 0 to (- j i) always
637                    (let* ((orig #*0000000000)
638                           (x (copy-seq orig))
639                           (y (substitute-if 1 #'zerop x :start i :end j :count c)))
640                      (and (equalp orig x)
641                           (equalp y (concatenate
642                                      'simple-bit-vector
643                                      (make-list i :initial-element 0)
644                                      (make-list c :initial-element 1)
645                                      (make-list (- 10 (+ i c)) :initial-element 0))))))))
646  t)
647
648(deftest substitute-if-bit-vector.21
649  (loop for i from 0 to 9 always
650        (loop for j from i to 10 always
651              (loop for c from 0 to (- j i) always
652                    (let* ((orig #*1111111111)
653                           (x (copy-seq orig))
654                           (y (substitute-if 0 (is-eql-p 1) x :start i :end j :count c :from-end t)))
655                      (and (equalp orig x)
656                           (equalp y (concatenate
657                                      'simple-bit-vector
658                                      (make-list (- j c) :initial-element 1)
659                                      (make-list c :initial-element 0)
660                                      (make-list (- 10 j) :initial-element 1))))))))
661  t)
662
663;;; More tests
664
665(deftest substitute-if-list.24
666  (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7)))
667         (x (copy-seq orig))
668         (result (substitute-if '(a 10) (is-eql-p 'a) x :key #'car)))
669    (and (equal orig x)
670         result))
671  ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7)))
672
673(deftest substitute-if-list.25
674  (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7)))
675         (x (copy-seq orig))
676         (result (substitute-if '(a 10) (is-eql-p 'a) x
677                                :key #'car :start 1 :end 5)))
678    (and (equal orig x)
679         result))
680  ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7)))
681
682(deftest substitute-if-vector.24
683  (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7)))
684         (x (copy-seq orig))
685         (result (substitute-if '(a 10) (is-eql-p 'a) x :key #'car)))
686    (and (equalp orig x)
687         result))
688  #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7)))
689   
690(deftest substitute-if-vector.25
691  (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7)))
692         (x (copy-seq orig))
693         (result (substitute-if '(a 10) (is-eql-p 'a) x :key #'car :start 1 :end 5)))
694    (and (equalp orig x)
695         result))
696  #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7)))
697
698(deftest substitute-if-string.24
699  (let* ((orig "0102342015")
700         (x (copy-seq orig))
701         (result (substitute-if #\a (is-eql-p #\1) x :key #'nextdigit)))
702    (and (equalp orig x)
703         result))
704  "a1a2342a15")
705   
706(deftest substitute-if-string.25
707  (let* ((orig "0102342015")
708         (x (copy-seq orig))
709         (result (substitute-if #\a (is-eql-p #\1) x :key #'nextdigit :start 1 :end 6)))
710    (and (equalp orig x)
711         result))
712  "01a2342015")
713
714(deftest substitute-if-string.26
715  (do-special-strings
716   (s "xyzabcxyzabc" nil)
717   (assert (string= (substitute-if #\! (is-eql-p #\a) s) "xyz!bcxyz!bc"))
718   (assert (string= (substitute-if #\! (is-eql-p #\a) s :count 1) "xyz!bcxyzabc"))
719   (assert (string= (substitute-if #\! (is-eql-p #\a) s :count 1 :from-end t) "xyzabcxyz!bc"))
720   (assert (string= s "xyzabcxyzabc")))
721  nil)
722
723;;; More bit vector tests
724
725(deftest substitute-if-bit-vector.22
726  (let* ((orig #*00111001011010110)
727         (x (copy-seq orig))
728         (result (substitute-if 1 (is-eql-p 1) x :key #'1+)))
729    (and (equalp orig x)
730         result))
731  #*11111111111111111)
732   
733(deftest substitute-if-bit-vector.23
734  (let* ((orig #*00111001011010110)
735         (x (copy-seq orig))
736         (result (substitute-if 1 (is-eql-p 1) x :key #'1+ :start 1 :end 10)))
737    (and (equalp orig x)
738         result))
739  #*01111111111010110)
740
741(deftest substitute-if-bit-vector.24
742  (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1)
743                       :fill-pointer 5 :element-type 'bit))
744         (result (substitute-if 1 #'zerop x)))
745    result)
746  #*11111)
747
748(deftest substitute-if-bit-vector.25
749  (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1)
750                       :fill-pointer 5 :element-type 'bit))
751         (result (substitute-if 1 #'zerop x :from-end t)))
752    result)
753  #*11111)
754
755(deftest substitute-if-bit-vector.26
756  (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1)
757                       :fill-pointer 5 :element-type 'bit))
758         (result (substitute-if 1 #'zerop x :count 1)))
759    result)
760  #*11011)
761
762(deftest substitute-if-bit-vector.27
763  (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1)
764                       :fill-pointer 5 :element-type 'bit))
765         (result (substitute-if 1 #'zerop x :from-end t :count 1)))
766    result)
767  #*01111)
768
769;;; Order of evaluation tests
770
771(deftest substitute-if.order.1
772  (let ((i 0) a b c d e f g h)
773    (values
774     (substitute-if
775      (progn (setf a (incf i)) 'a)
776      (progn (setf b (incf i)) #'null)
777      (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5))
778      :count (progn (setf d (incf i)) 2)
779      :start (progn (setf e (incf i)) 0)
780      :end (progn (setf f (incf i)) 7)
781      :key (progn (setf g (incf i)) #'identity)
782      :from-end (setf h (incf i))
783      )
784     i a b c d e f g h))
785  (nil 1 2 a 3 4 a 5)
786  8 1 2 3 4 5 6 7 8)
787
788(deftest substitute-if.order.2
789  (let ((i 0) a b c d e f g h)
790    (values
791     (substitute-if
792      (progn (setf a (incf i)) 'a)
793      (progn (setf b (incf i)) #'null)
794      (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5))
795      :from-end (setf h (incf i))
796      :key (progn (setf g (incf i)) #'identity)
797      :end (progn (setf f (incf i)) 7)
798      :start (progn (setf e (incf i)) 0)
799      :count (progn (setf d (incf i)) 2)
800      )
801     i a b c d e f g h))
802  (nil 1 2 a 3 4 a 5)
803  8 1 2 3 8 7 6 5 4)
804
805;;; Keyword tests
806
807(deftest substitute-if.allow-other-keys.1
808  (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t)
809  (1 2 a 3 1 a 3))
810
811(deftest substitute-if.allow-other-keys.2
812  (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t)
813  (1 2 a 3 1 a 3))
814
815(deftest substitute-if.allow-other-keys.3
816  (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t
817                  :allow-other-keys nil :bad t)
818  (1 2 a 3 1 a 3))
819
820(deftest substitute-if.allow-other-keys.4
821  (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :bad t
822                  :allow-other-keys t :allow-other-keys nil)
823  (1 2 a 3 1 a 3))
824
825(deftest substitute-if.allow-other-keys.5
826  (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3)
827                  :allow-other-keys t :key #'1-)
828  (a 2 0 3 a 0 3))
829
830(deftest substitute-if.keywords.6
831  (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :key #'1- :key #'identity)
832  (a 2 0 3 a 0 3))
833
834(deftest substitute-if.allow-other-keys.7
835  (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t
836                  :bad t :allow-other-keys nil)
837  (1 2 a 3 1 a 3))
838
839(deftest substitute-if.allow-other-keys.8
840  (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys nil)
841  (1 2 a 3 1 a 3))
842
843;;; Constant folding tests
844
845(def-fold-test substitute-if.fold.1 (substitute-if 'z 'null '(a nil b)))
846(def-fold-test substitute-if.fold.2 (substitute-if 'z 'null #(a nil b)))
847(def-fold-test substitute-if.fold.3 (substitute-if 0 'plusp #*100110))
848(def-fold-test substitute-if.fold.4 (substitute-if #\x 'digit-char-p
849                                                   "asdf8234n123f"))
850
851;;; Error cases
852
853(deftest substitute-if.error.1
854  (signals-error (substitute-if) program-error)
855  t)
856
857(deftest substitute-if.error.2
858  (signals-error (substitute-if 'a) program-error)
859  t)
860
861(deftest substitute-if.error.3
862  (signals-error (substitute-if 'a #'null) program-error)
863  t)
864
865(deftest substitute-if.error.4
866  (signals-error (substitute-if 'a #'null nil 'bad t) program-error)
867  t)
868
869(deftest substitute-if.error.5
870  (signals-error (substitute-if 'a #'null nil 'bad t :allow-other-keys nil)
871                 program-error)
872  t)
873
874(deftest substitute-if.error.6
875  (signals-error (substitute-if 'a #'null nil :key) program-error)
876  t)
877
878(deftest substitute-if.error.7
879  (signals-error (substitute-if 'a #'null nil 1 2) program-error)
880  t)
881
882(deftest substitute-if.error.8
883  (signals-error (substitute-if 'a #'cons (list 'a 'b 'c)) program-error)
884  t)
885
886(deftest substitute-if.error.9
887  (signals-error (substitute-if 'a #'car (list 'a 'b 'c)) type-error)
888  t)
889
890(deftest substitute-if.error.10
891  (signals-error (substitute-if 'a #'identity (list 'a 'b 'c)
892                                  :key #'car)
893                 type-error)
894  t)
895
896(deftest substitute-if.error.11
897  (signals-error (substitute-if 'a #'identity (list 'a 'b 'c)
898                                  :key #'cons)
899                 program-error)
900  t)
901
902(deftest substitute-if.error.12
903  (check-type-error #'(lambda (x) (substitute-if 'a #'not x)) #'sequencep)
904  nil)
Note: See TracBrowser for help on using the repository browser.