2df75d13ee736d56b848f4e4299f2d2382fb5570
[sbcl.git] / seq.impure.lisp
1 ;;;; tests related to sequences
2
3 ;;;; This file is impure because we want to be able to use DEFUN.
4
5 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; more information.
7 ;;;;
8 ;;;; While most of SBCL is derived from the CMU CL system, the test
9 ;;;; files (like this one) were written from scratch after the fork
10 ;;;; from CMU CL.
11 ;;;;
12 ;;;; This software is in the public domain and is provided with
13 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
14 ;;;; more information.
15
16 (load "test-util.lisp")
17 (load "assertoid.lisp")
18
19 (defpackage :seq-test
20   (:use :cl :assertoid :test-util))
21
22 (in-package :seq-test)
23
24 ;;; helper functions for exercising SEQUENCE code on data of many
25 ;;; specialized types, and in many different optimization scenarios
26 (defun for-every-seq-1 (base-seq snippet)
27   (dolist (seq-type '(list
28                       (simple-array t 1)
29                       (vector t)
30                       (simple-array character 1)
31                       (vector character)
32                       (simple-array (signed-byte 4) 1)
33                       (vector (signed-byte 4))))
34     (flet ((entirely (eltype)
35              (every (lambda (el) (typep el eltype)) base-seq)))
36       (dolist (declaredness '(nil t))
37         (dolist (optimization '(((speed 3) (space 0))
38                                 ((speed 2) (space 2))
39                                 ((speed 1) (space 2))
40                                 ((speed 0) (space 1))))
41           (let* ((seq (if (eq seq-type 'list)
42                           (coerce base-seq 'list)
43                           (destructuring-bind (type-first &rest type-rest)
44                               seq-type
45                             (ecase type-first
46                               (simple-array
47                                (destructuring-bind (eltype one) type-rest
48                                  (assert (= one 1))
49                                  (if (entirely eltype)
50                                      (coerce base-seq seq-type)
51                                      (return))))
52                               (vector
53                                (destructuring-bind (eltype) type-rest
54                                  (if (entirely eltype)
55                                      (let ((initial-element
56                                             (cond ((subtypep eltype 'character)
57                                                    #\!)
58                                                   ((subtypep eltype 'number)
59                                                    0)
60                                                   (t #'error))))
61                                        (replace (make-array
62                                                  (+ (length base-seq)
63                                                     (random 3))
64                                                  :element-type eltype
65                                                  :fill-pointer
66                                                  (length base-seq)
67                                                  :initial-element
68                                                  initial-element)
69                                                 base-seq))
70                                      (return))))))))
71                  (lambda-expr `(lambda (seq)
72                                  ,@(when declaredness
73                                      `((declare (type ,seq-type seq))))
74                                  (declare (optimize ,@optimization))
75                                  ,snippet)))
76             (format t "~&~S~%" lambda-expr)
77             (multiple-value-bind (fun warnings-p failure-p)
78                 (compile nil lambda-expr)
79               (when (or warnings-p failure-p)
80                 (error "~@<failed compilation:~2I ~_LAMBDA-EXPR=~S ~_WARNINGS-P=~S ~_FAILURE-P=~S~:@>"
81                        lambda-expr warnings-p failure-p))
82               (format t "~&~S ~S~%~S~%~S ~S~%"
83                       base-seq snippet seq-type declaredness optimization)
84               (format t "~&(TYPEP SEQ 'SIMPLE-ARRAY)=~S~%"
85                       (typep seq 'simple-array))
86               (unless (funcall fun seq)
87                 (error "~@<failed test:~2I ~_BASE-SEQ=~S ~_SNIPPET=~S ~_SEQ-TYPE=~S ~_DECLAREDNESS=~S ~_OPTIMIZATION=~S~:@>"
88                        base-seq
89                        snippet
90                        seq-type
91                        declaredness
92                        optimization)))))))))
93 (defun for-every-seq (base-seq snippets)
94   (dolist (snippet snippets)
95     (for-every-seq-1 base-seq snippet)))
96
97 ;;; a wrapper to hide declared type information from the compiler, so
98 ;;; we don't get stopped by compiler warnings about e.g. compiling
99 ;;; (POSITION 1 #() :KEY #'ABS) when #() has been coerced to a string.
100 (defun indiscriminate (fun)
101   (lambda (&rest rest) (apply fun rest)))
102
103 ;;; asymmetric test arg order example from ANSI FIND definition page
104 (assert (eql #\space ; original example, depends on ASCII character ordering
105              (find #\d "here are some letters that can be looked at"
106                    :test #'char>)))
107 (assert (eql #\e ; modified example, depends only on standard a-z ordering
108              (find #\f "herearesomeletters" :test #'char>)))
109 (assert (eql 4 ; modified more, avoids charset technicalities completely
110              (find 5 '(6 4) :test '>)))
111
112 ;;; tests of FIND, POSITION, FIND-IF, and POSITION-IF (and a few for
113 ;;; deprecated FIND-IF-NOT and POSITION-IF-NOT too)
114 (for-every-seq #()
115   '((null (find 1 seq))
116     (null (find 1 seq :from-end t))
117     (null (position 1 seq :key (indiscriminate #'abs)))
118     (null (position nil seq :test (constantly t)))
119     (null (position nil seq :test nil))
120     (null (position nil seq :test-not nil))
121     (null (find-if #'1+ seq :key (indiscriminate #'log)))
122     (null (position-if #'identity seq :from-end t))
123     (null (find-if-not #'packagep seq))
124     (null (position-if-not #'packagep seq :key nil))))
125 (for-every-seq #(1)
126   '((null (find 2 seq))
127     ;; Get the argument ordering for asymmetric tests like #'> right.
128     ;; (bug reported and fixed by Alexey Dejneka sbcl-devel 2001-10-17)
129     (eql 1 (find 2 seq :test #'>))
130     (find 2 seq :key #'1+)
131     (find 1 seq :from-end t)
132     (null (find 1 seq :from-end t :start 1))
133     (null (find 0 seq :from-end t))
134     (eql 0 (position 1 seq :key #'abs))
135     (null (position nil seq :test 'equal))
136     (eql 1 (find-if #'1- seq :key #'log))
137     (eql 0 (position-if #'identity seq :from-end t))
138     (null (find-if-not #'sin seq))
139     (eql 0 (position-if-not #'packagep seq :key 'identity))))
140 (for-every-seq #(1 2 3 2 1)
141   '((find 3 seq)
142     (find 3 seq :from-end 'yes)
143     (eql 1 (position 1.5 seq :test #'<))
144     (eql 0 (position 0 seq :key '1-))
145     (eql 4 (position 0 seq :key '1- :from-end t))
146     (eql 2 (position 4 seq :key '1+))
147     (eql 2 (position 4 seq :key '1+ :from-end t))
148     (eql 1 (position 2 seq))
149     (eql 1 (position 2 seq :start 1))
150     (null (find 2 seq :start 1 :end 1))
151     (eql 3 (position 2 seq :start 2))
152     (eql 3 (position 2 seq :key nil :from-end t))
153     (eql 2 (position 3 seq :test '=))
154     (eql 0 (position 3 seq :test-not 'equalp))
155     (eql 2 (position 3 seq :test 'equal :from-end t))
156     (null (position 4 seq :test #'eql))
157     (null (find-if #'packagep seq))
158     (eql 1 (find-if #'plusp seq))
159     (eql 3 (position-if #'plusp seq :key #'1- :from-end t))
160     (eql 1 (position-if #'evenp seq))
161     (eql 3 (position-if #'evenp seq :from-end t))
162     (eql 2 (position-if #'plusp seq :from-end nil :key '1- :start 2))
163     (eql 3 (position-if #'plusp seq :from-end t :key '1- :start 2))
164     (null (position-if #'plusp seq :from-end t :key '1- :start 2 :end 2))
165     (null (find-if-not #'plusp seq))
166     (eql 0 (position-if-not #'evenp seq))
167     (eql 0 (search #(1) seq))
168     (eql 1 (search #(4 5) seq :key 'oddp))
169     (eql 1 (search #(-2) seq :test (lambda (a b) (= (- a) b))))
170     (eql 4 (search #(1) seq :start2 1))
171     (null (search #(3) seq :start2 3))
172     (eql 2 (search #(3) seq :start2 2))
173     (eql 0 (search #(1 2) seq))
174     (null (search #(2 1 3) seq))
175     (eql 0 (search #(0 1 2 4) seq :start1 1 :end1 3))
176     (eql 3 (search #(0 2 1 4) seq :start1 1 :end1 3))
177     (eql 4 (search #(1) seq :from-end t))
178     (eql 0 (search #(1 2) seq :from-end t))
179     (null (search #(1 2) seq :from-end t :start2 1))
180     (eql 0 (search #(0 1 2 4) seq :from-end t :start1 1 :end1 3))
181     (eql 3 (search #(0 2 1 4) seq :from-end t :start1 1 :end1 3))
182     (null (search #(2 1 3) seq :from-end t))))
183 (for-every-seq "string test"
184   '((null (find 0 seq))
185     (null (find #\D seq :key #'char-upcase))
186     (find #\E seq :key #'char-upcase)
187     (null (find #\e seq :key #'char-upcase))
188     (eql 3 (position #\i seq))
189     (eql 0 (position #\s seq :key #'char-downcase))
190     (eql 1 (position #\s seq :key #'char-downcase :test #'char/=))
191     (eql 9 (position #\s seq :from-end t :test #'char=))
192     (eql 10 (position #\s seq :from-end t :test #'char/=))
193     (eql 4 (position #\N seq :from-end t :key 'char-upcase :test #'char-equal))
194     (eql 5 (position-if (lambda (c) (equal #\g c)) seq))
195     (eql 5 (position-if (lambda (c) (equal #\g c)) seq :from-end t))
196     (find-if #'characterp seq)
197     (find-if (lambda (c) (typep c 'base-char)) seq :from-end t)
198     (null (find-if 'upper-case-p seq))))
199
200 ;;; SUBSEQ
201 (let ((avec (make-array 10
202                         :fill-pointer 4
203                         :initial-contents '(0 1 2 3 iv v vi vii iix ix))))
204   ;; These first five always worked AFAIK.
205   (assert (equalp (subseq avec 0 3) #(0 1 2)))
206   (assert (equalp (subseq avec 3 3) #()))
207   (assert (equalp (subseq avec 1 3) #(1 2)))
208   (assert (equalp (subseq avec 1) #(1 2 3)))
209   (assert (equalp (subseq avec 1 4) #(1 2 3)))
210   ;; SBCL bug found ca. 2002-05-01 by OpenMCL's correct handling of
211   ;; SUBSEQ, CSR's driving portable cross-compilation far enough to
212   ;; reach the SUBSEQ calls in assem.lisp, and WHN's sleazy
213   ;; translation of old CMU CL new-assem.lisp into sufficiently grotty
214   ;; portable Lisp that it passed suitable illegal values to SUBSEQ to
215   ;; exercise the bug:-|
216   ;;
217   ;; SUBSEQ should check its END value against logical LENGTH, not
218   ;; physical ARRAY-DIMENSION 0.
219   ;;
220   ;; fixed in sbcl-0.7.4.22 by WHN
221   (assert (null (ignore-errors (aref (subseq avec 1 5) 0)))))
222
223 ;;; FILL
224 (defun test-fill-typecheck (x)
225   (declare (optimize (safety 3) (space 2) (speed 1)))
226   (fill (make-string 10) x))
227
228 (assert (string= (test-fill-typecheck #\@) "@@@@@@@@@@"))
229 ;;; BUG 186, fixed in sbcl-0.7.5.5
230 (assert (null (ignore-errors (test-fill-typecheck 4097))))
231
232 ;;; MAKE-SEQUENCE, COERCE, CONCATENATE, MERGE, MAP and requested
233 ;;; result type (BUGs 46a, 46b, 66)
234 (macrolet ((assert-type-error (form)
235              `(assert (typep (nth-value 1 (ignore-errors ,form))
236                              'type-error))))
237   (dolist (type-stub '((simple-vector)
238                        (vector *)
239                        (vector (signed-byte 8))
240                        (vector (unsigned-byte 16))
241                        (vector (signed-byte 32))
242                        (simple-bit-vector)))
243     (declare (optimize safety))
244     (format t "~&~S~%" type-stub)
245     ;; MAKE-SEQUENCE
246     (assert (= (length (make-sequence `(,@type-stub) 10)) 10))
247     (assert (= (length (make-sequence `(,@type-stub 10) 10)) 10))
248     (assert-type-error (make-sequence `(,@type-stub 10) 11))
249     ;; COERCE
250     (assert (= (length (coerce '(0 0 0) `(,@type-stub))) 3))
251     (assert (= (length (coerce #(0 0 0) `(,@type-stub 3))) 3))
252     (assert-type-error (coerce #*111 `(,@type-stub 4)))
253     ;; CONCATENATE
254     (assert (= (length (concatenate `(,@type-stub) #(0 0 0) #*111)) 6))
255     (assert (equalp (concatenate `(,@type-stub) #(0 0 0) #*111)
256                    (coerce #(0 0 0 1 1 1) `(,@type-stub))))
257     (assert (= (length (concatenate `(,@type-stub 6) #(0 0 0) #*111)) 6))
258     (assert (equalp (concatenate `(,@type-stub 6) #(0 0 0) #*111)
259                    (coerce #(0 0 0 1 1 1) `(,@type-stub 6))))
260     (assert-type-error (concatenate `(,@type-stub 5) #(0 0 0) #*111))
261     ;; MERGE
262     (macrolet ((test (type)
263                  `(merge ,type (copy-seq #(0 1 0)) (copy-seq #*111) #'>)))
264       (assert (= (length (test `(,@type-stub))) 6))
265       (assert (equalp (test `(,@type-stub))
266                       (coerce #(1 1 1 0 1 0) `(,@type-stub))))
267       (assert (= (length (test `(,@type-stub 6))) 6))
268       (assert (equalp (test `(,@type-stub 6))
269                       (coerce #(1 1 1 0 1 0) `(,@type-stub 6))))
270       (assert-type-error (test `(,@type-stub 4))))
271     ;; MAP
272     (assert (= (length (map `(,@type-stub) #'logxor #(0 0 1 1) '(0 1 0 1))) 4))
273     (assert (equalp (map `(,@type-stub) #'logxor #(0 0 1 1) '(0 1 0 1))
274                    (coerce #(0 1 1 0) `(,@type-stub))))
275     (assert (= (length (map `(,@type-stub 4) #'logxor #(0 0 1 1) '(0 1 0 1)))
276                4))
277     (assert (equalp (map `(,@type-stub 4) #'logxor #(0 0 1 1) '(0 1 0 1))
278                    (coerce #(0 1 1 0) `(,@type-stub 4))))
279     (assert-type-error (map `(,@type-stub 5) #'logxor #(0 0 1 1) '(0 1 0 1))))
280   ;; some more CONCATENATE tests for strings
281   (locally
282       (declare (optimize safety))
283     (assert (string= (concatenate 'string "foo" " " "bar") "foo bar"))
284     (assert (string= (concatenate '(string 7) "foo" " " "bar") "foo bar"))
285     (assert-type-error (concatenate '(string 6) "foo" " " "bar"))
286     (assert (string= (concatenate '(string 6) "foo" #(#\b #\a #\r)) "foobar"))
287     (assert-type-error (concatenate '(string 7) "foo" #(#\b #\a #\r))))
288   ;; Non-VECTOR ARRAY types aren't allowed as vector type specifiers.
289   (locally
290     (declare (optimize safety))
291     (assert-type-error (concatenate 'simple-array "foo" "bar"))
292     (assert-type-error (map 'simple-array #'identity '(1 2 3)))
293     (assert (equalp #(11 13)
294                     (map '(simple-array fixnum (*)) #'+ '(1 2 3) '(10 11))))
295     (assert-type-error (coerce '(1 2 3) 'simple-array))
296     (assert-type-error (merge 'simple-array (list 1 3) (list 2 4) '<))
297     (assert (equalp #(3 2 1) (coerce '(3 2 1) '(vector fixnum))))
298     (assert-type-error (map 'array #'identity '(1 2 3)))
299     (assert-type-error (map '(array fixnum) #'identity '(1 2 3)))
300     (assert (equalp #(1 2 3) (coerce '(1 2 3) '(vector fixnum))))
301     ;; but COERCE has an exemption clause:
302     (assert (string= "foo" (coerce "foo" 'simple-array)))
303     ;; ... though not in all cases.
304     (assert-type-error (coerce '(#\f #\o #\o) 'simple-array))))
305
306 ;;; As pointed out by Raymond Toy on #lisp IRC, MERGE had some issues
307 ;;; with user-defined types until sbcl-0.7.8.11
308 (deftype list-typeoid () 'list)
309 (assert (equal '(1 2 3 4) (merge 'list-typeoid (list 1 3) (list 2 4) '<)))
310 ;;; and also with types that weren't precicely LIST
311 (assert (equal '(1 2 3 4) (merge 'cons (list 1 3) (list 2 4) '<)))
312
313 ;;; but wait, there's more! The NULL and CONS types also have implicit
314 ;;; length requirements:
315 (macrolet ((assert-type-error (form)
316              `(assert (typep (nth-value 1 (ignore-errors ,form))
317                              'type-error))))
318   (locally
319       (declare (optimize safety))
320     ;; MAKE-SEQUENCE
321     (assert-type-error (make-sequence 'cons 0))
322     (assert-type-error (make-sequence 'null 1))
323     (assert-type-error (make-sequence '(cons t null) 0))
324     (assert-type-error (make-sequence '(cons t null) 2))
325     ;; KLUDGE: I'm not certain that this test actually tests for what
326     ;; it should test, in that the type deriver and optimizers might
327     ;; be too smart for the good of an exhaustive test system.
328     ;; However, it makes me feel good.  -- CSR, 2002-10-18
329     (assert (null (make-sequence 'null 0)))
330     (assert (= (length (make-sequence 'cons 3)) 3))
331     (assert (= (length (make-sequence '(cons t null) 1)) 1))
332     ;; and NIL is not a valid type for MAKE-SEQUENCE
333     (assert-type-error (make-sequence 'nil 0))
334     ;; COERCE
335     (assert-type-error (coerce #(1) 'null))
336     (assert-type-error (coerce #() 'cons))
337     (assert-type-error (coerce #() '(cons t null)))
338     (assert-type-error (coerce #(1 2) '(cons t null)))
339     (assert (null (coerce #() 'null)))
340     (assert (= (length (coerce #(1) 'cons)) 1))
341     (assert (= (length (coerce #(1) '(cons t null))) 1))
342     (assert-type-error (coerce #() 'nil))
343     ;; MERGE
344     (assert-type-error (merge 'null (list 1 3) (list 2 4) '<))
345     (assert-type-error (merge 'cons () () '<))
346     (assert (null (merge 'null () () '<)))
347     (assert (= (length (merge 'cons (list 1 3) (list 2 4) '<)) 4))
348     (assert (= (length (merge '(cons t (cons t (cons t (cons t null))))
349                               (list 1 3) (list 2 4)
350                               '<))
351                4))
352     (assert-type-error (merge 'nil () () '<))
353     ;; CONCATENATE
354     (assert-type-error (concatenate 'null '(1) "2"))
355     (assert-type-error (concatenate 'cons #() ()))
356     (assert-type-error (concatenate '(cons t null) #(1 2 3) #(4 5 6)))
357     (assert (null (concatenate 'null () #())))
358     (assert (= (length (concatenate 'cons #() '(1) "2 3")) 4))
359     (assert (= (length (concatenate '(cons t cons) '(1) "34")) 3))
360     (assert-type-error (concatenate 'nil '(3)))
361     ;; FIXME: tests for MAP to come when some brave soul implements
362     ;; the analogous type checking for MAP/%MAP.
363     ))
364 \f
365 ;;; ELT should signal an error of type TYPE-ERROR if its index
366 ;;; argument isn't a valid sequence index for sequence:
367 (defun test-elt-signal (x)
368   (elt x 3))
369 (assert (raises-error? (test-elt-signal "foo") type-error))
370 (assert (eql (test-elt-signal "foob") #\b))
371 (locally
372   (declare (optimize (safety 3)))
373   (assert (raises-error? (elt (list 1 2 3) 3) type-error)))
374 \f
375 ;;; confusion in the refactoring led to this signalling an unbound
376 ;;; variable, not a type error.
377 (defun svrefalike (x)
378   (svref x 0))
379 (assert (raises-error? (svrefalike #*0) type-error))
380 \f
381 ;;; checks for uniform bounding index handling.
382 ;;;
383 ;;; This used to be SAFETY 3 only, but bypassing these checks with
384 ;;; above-zero speed when SPEED > SAFETY is not The SBCL Way.
385 ;;;
386 ;;; KLUDGE: not all in one big form because that causes SBCL to spend
387 ;;; an absolute age trying to compile it.
388 (defmacro sequence-bounding-indices-test (&body body)
389   `(progn
390      (locally
391     ;; See Issues 332 [and 333(!)] in the CLHS
392     (declare (optimize (speed 3) (safety 1)))
393     (let ((string (make-array 10
394                               :fill-pointer 5
395                               :initial-element #\a
396                               :element-type 'base-char)))
397         ,(car body)
398         (format t "... BASE-CHAR")
399         (finish-output)
400         (flet ((reset ()
401                  (setf (fill-pointer string) 10)
402                  (fill string #\a)
403                  (setf (fill-pointer string) 5)))
404           (declare (ignorable #'reset))
405           ,@(cdr body))))
406     (locally
407       ;; See Issues 332 [and 333(!)] in the CLHS
408       (declare (optimize (speed 3) (safety 1)))
409       (let ((string (make-array 10
410                                 :fill-pointer 5
411                                 :initial-element #\a
412                                 :element-type 'character)))
413         ,(car body)
414         (format t "... CHARACTER")
415         (finish-output)
416       (flet ((reset ()
417                (setf (fill-pointer string) 10)
418                (fill string #\a)
419                (setf (fill-pointer string) 5)))
420         (declare (ignorable #'reset))
421           ,@(cdr body))))))
422
423 (declaim (notinline opaque-identity))
424 (defun opaque-identity (x) x)
425 ;;; Accessor SUBSEQ
426 (sequence-bounding-indices-test
427  (format t "~&/Accessor SUBSEQ")
428  (assert (string= (subseq string 0 5) "aaaaa"))
429  (assert (raises-error? (subseq string 0 6)))
430  (assert (raises-error? (subseq string (opaque-identity -1) 5)))
431  (assert (raises-error? (subseq string 4 2)))
432  (assert (raises-error? (subseq string 6)))
433  (assert (string= (setf (subseq string 0 5) "abcde") "abcde"))
434  (assert (string= (subseq string 0 5) "abcde"))
435  (reset)
436  (assert (raises-error? (setf (subseq string 0 6) "abcdef")))
437  (assert (raises-error? (setf (subseq string (opaque-identity -1) 5) "abcdef")))
438  (assert (raises-error? (setf (subseq string 4 2) "")))
439  (assert (raises-error? (setf (subseq string 6) "ghij"))))
440
441 ;;; Function COUNT, COUNT-IF, COUNT-IF-NOT
442 (sequence-bounding-indices-test
443  (format t "~&/Function COUNT, COUNT-IF, COUNT-IF-NOT")
444  (assert (= (count #\a string :start 0 :end nil) 5))
445  (assert (= (count #\a string :start 0 :end 5) 5))
446  (assert (raises-error? (count #\a string :start 0 :end 6)))
447  (assert (raises-error? (count #\a string :start (opaque-identity -1) :end 5)))
448  (assert (raises-error? (count #\a string :start 4 :end 2)))
449  (assert (raises-error? (count #\a string :start 6 :end 9)))
450  (assert (= (count-if #'alpha-char-p string :start 0 :end nil) 5))
451  (assert (= (count-if #'alpha-char-p string :start 0 :end 5) 5))
452  (assert (raises-error?
453           (count-if #'alpha-char-p string :start 0 :end 6)))
454  (assert (raises-error?
455           (count-if #'alpha-char-p string :start (opaque-identity -1) :end 5)))
456  (assert (raises-error?
457           (count-if #'alpha-char-p string :start 4 :end 2)))
458  (assert (raises-error?
459           (count-if #'alpha-char-p string :start 6 :end 9)))
460  (assert (= (count-if-not #'alpha-char-p string :start 0 :end nil) 0))
461  (assert (= (count-if-not #'alpha-char-p string :start 0 :end 5) 0))
462  (assert (raises-error?
463           (count-if-not #'alpha-char-p string :start 0 :end 6)))
464  (assert (raises-error?
465           (count-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)))
466  (assert (raises-error?
467           (count-if-not #'alpha-char-p string :start 4 :end 2)))
468  (assert (raises-error?
469           (count-if-not #'alpha-char-p string :start 6 :end 9))))
470
471 ;;; Function FILL
472 (sequence-bounding-indices-test
473  (format t "~&/Function FILL")
474  (assert (string= (fill string #\b :start 0 :end 5) "bbbbb"))
475  (assert (string= (fill string #\c :start 0 :end nil) "ccccc"))
476  (assert (raises-error? (fill string #\d :start 0 :end 6)))
477  (assert (raises-error? (fill string #\d :start (opaque-identity -1) :end 5)))
478  (assert (raises-error? (fill string #\d :start 4 :end 2)))
479  (assert (raises-error? (fill string #\d :start 6 :end 9))))
480
481 ;;; Function FIND, FIND-IF, FIND-IF-NOT
482 (sequence-bounding-indices-test
483  (format t "~&/Function FIND, FIND-IF, FIND-IF-NOT")
484  (assert (char= (find #\a string :start 0 :end nil) #\a))
485  (assert (char= (find #\a string :start 0 :end 5) #\a))
486  (assert (raises-error? (find #\a string :start 0 :end 6)))
487  (assert (raises-error? (find #\a string :start (opaque-identity -1) :end 5)))
488  (assert (raises-error? (find #\a string :start 4 :end 2)))
489  (assert (raises-error? (find #\a string :start 6 :end 9)))
490  (assert (char= (find-if #'alpha-char-p string :start 0 :end nil) #\a))
491  (assert (char= (find-if #'alpha-char-p string :start 0 :end 5) #\a))
492  (assert (raises-error?
493           (find-if #'alpha-char-p string :start 0 :end 6)))
494  (assert (raises-error?
495           (find-if #'alpha-char-p string :start (opaque-identity -1) :end 5)))
496  (assert (raises-error?
497           (find-if #'alpha-char-p string :start 4 :end 2)))
498  (assert (raises-error?
499           (find-if #'alpha-char-p string :start 6 :end 9)))
500  (assert (eq (find-if-not #'alpha-char-p string :start 0 :end nil) nil))
501  (assert (eq (find-if-not #'alpha-char-p string :start 0 :end 5) nil))
502  (assert (raises-error?
503           (find-if-not #'alpha-char-p string :start 0 :end 6)))
504  (assert (raises-error?
505           (find-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)))
506  (assert (raises-error?
507           (find-if-not #'alpha-char-p string :start 4 :end 2)))
508  (assert (raises-error?
509           (find-if-not #'alpha-char-p string :start 6 :end 9))))
510
511 ;;; Function MISMATCH
512 (sequence-bounding-indices-test
513  (format t "~&/Function MISMATCH")
514  (assert (null (mismatch string "aaaaa" :start1 0 :end1 nil)))
515  (assert (= (mismatch "aaab" string :start2 0 :end2 4) 3))
516  (assert (raises-error? (mismatch "aaaaaa" string :start2 0 :end2 6)))
517  (assert (raises-error? (mismatch string "aaaaaa" :start1 (opaque-identity -1) :end1 5)))
518  (assert (raises-error? (mismatch string "" :start1 4 :end1 2)))
519  (assert (raises-error? (mismatch "aaaa" string :start2 6 :end2 9))))
520
521 ;;; Function PARSE-INTEGER
522 (sequence-bounding-indices-test
523  (format t "~&/Function PARSE-INTEGER")
524  (setf (fill-pointer string) 10)
525  (setf (subseq string 0 10) "1234567890")
526  (setf (fill-pointer string) 5)
527  (assert (= (parse-integer string :start 0 :end 5) 12345))
528  (assert (= (parse-integer string :start 0 :end nil) 12345))
529  (assert (raises-error? (parse-integer string :start 0 :end 6)))
530  (assert (raises-error? (parse-integer string :start (opaque-identity -1) :end 5)))
531  (assert (raises-error? (parse-integer string :start 4 :end 2)))
532  (assert (raises-error? (parse-integer string :start 6 :end 9))))
533
534 ;;; Function PARSE-NAMESTRING
535 (sequence-bounding-indices-test
536  (format t "~&/Function PARSE-NAMESTRING")
537  (setf (fill-pointer string) 10)
538  (setf (subseq string 0 10)
539        #-win32 "/dev/ /tmp"
540        #+win32 "C:/   NUL")
541  (setf (fill-pointer string) 5)
542  (assert (truename (parse-namestring string nil *default-pathname-defaults*
543                                      :start 0 :end 5)))
544  (assert (truename (parse-namestring string nil *default-pathname-defaults*
545                                      :start 0 :end nil)))
546  (assert (raises-error? (parse-namestring string nil
547                                           *default-pathname-defaults*
548                                           :start 0 :end 6)))
549  (assert (raises-error? (parse-namestring string nil
550                                           *default-pathname-defaults*
551                                           :start (opaque-identity -1) :end 5)))
552  (assert (raises-error? (parse-namestring string nil
553                                           *default-pathname-defaults*
554                                           :start 4 :end 2)))
555  (assert (raises-error? (parse-namestring string nil
556                                           *default-pathname-defaults*
557                                           :start 6 :end 9))))
558
559 ;;; Function POSITION, POSITION-IF, POSITION-IF-NOT
560 (sequence-bounding-indices-test
561  (format t "~&/Function POSITION, POSITION-IF, POSITION-IF-NOT")
562
563  (assert (= (position #\a string :start 0 :end nil) 0))
564  (assert (= (position #\a string :start 0 :end 5) 0))
565  (assert (raises-error? (position #\a string :start 0 :end 6)))
566  (assert (raises-error? (position #\a string :start (opaque-identity -1) :end 5)))
567  (assert (raises-error? (position #\a string :start 4 :end 2)))
568  (assert (raises-error? (position #\a string :start 6 :end 9)))
569  (assert (= (position-if #'alpha-char-p string :start 0 :end nil) 0))
570  (assert (= (position-if #'alpha-char-p string :start 0 :end 5) 0))
571  (assert (raises-error?
572           (position-if #'alpha-char-p string :start 0 :end 6)))
573  (assert (raises-error?
574           (position-if #'alpha-char-p string :start (opaque-identity -1) :end 5)))
575  (assert (raises-error?
576           (position-if #'alpha-char-p string :start 4 :end 2)))
577  (assert (raises-error?
578           (position-if #'alpha-char-p string :start 6 :end 9)))
579  (assert (eq (position-if-not #'alpha-char-p string :start 0 :end nil) nil))
580  (assert (eq (position-if-not #'alpha-char-p string :start 0 :end 5) nil))
581  (assert (raises-error?
582           (position-if-not #'alpha-char-p string :start 0 :end 6)))
583  (assert (raises-error?
584           (position-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)))
585  (assert (raises-error?
586           (position-if-not #'alpha-char-p string :start 4 :end 2)))
587  (assert (raises-error?
588           (position-if-not #'alpha-char-p string :start 6 :end 9))))
589
590 ;;; Function READ-FROM-STRING
591 (sequence-bounding-indices-test
592  (format t "~&/Function READ-FROM-STRING")
593  (setf (subseq string 0 5) "(a b)")
594  (assert (equal (read-from-string string nil nil :start 0 :end 5) '(a b)))
595  (assert (equal (read-from-string string nil nil :start 0 :end nil) '(a b)))
596  (assert (raises-error? (read-from-string string nil nil :start 0 :end 6)))
597  (assert (raises-error? (read-from-string string nil nil :start (opaque-identity -1) :end 5)))
598  (assert (raises-error? (read-from-string string nil nil :start 4 :end 2)))
599  (assert (raises-error? (read-from-string string nil nil :start 6 :end 9))))
600
601 ;;; Function REDUCE
602 (sequence-bounding-indices-test
603  (format t "~&/Function REDUCE")
604  (setf (subseq string 0 5) "abcde")
605  (assert (equal (reduce #'list* string :from-end t :start 0 :end nil)
606                 '(#\a #\b #\c #\d . #\e)))
607  (assert (equal (reduce #'list* string :from-end t :start 0 :end 5)
608                 '(#\a #\b #\c #\d . #\e)))
609  (assert (raises-error? (reduce #'list* string :start 0 :end 6)))
610  (assert (raises-error? (reduce #'list* string :start (opaque-identity -1) :end 5)))
611  (assert (raises-error? (reduce #'list* string :start 4 :end 2)))
612  (assert (raises-error? (reduce #'list* string :start 6 :end 9))))
613
614 ;;; Function REMOVE, REMOVE-IF, REMOVE-IF-NOT, DELETE, DELETE-IF,
615 ;;; DELETE-IF-NOT
616 (sequence-bounding-indices-test
617  (format t "~&/Function REMOVE, REMOVE-IF, REMOVE-IF-NOT, ...")
618  (assert (equal (remove #\a string :start 0 :end nil) ""))
619  (assert (equal (remove #\a string :start 0 :end 5) ""))
620  (assert (raises-error? (remove #\a string :start 0 :end 6)))
621  (assert (raises-error? (remove #\a string :start (opaque-identity -1) :end 5)))
622  (assert (raises-error? (remove #\a string :start 4 :end 2)))
623  (assert (raises-error? (remove #\a string :start 6 :end 9)))
624  (assert (equal (remove-if #'alpha-char-p string :start 0 :end nil) ""))
625  (assert (equal (remove-if #'alpha-char-p string :start 0 :end 5) ""))
626  (assert (raises-error?
627           (remove-if #'alpha-char-p string :start 0 :end 6)))
628  (assert (raises-error?
629           (remove-if #'alpha-char-p string :start (opaque-identity -1) :end 5)))
630  (assert (raises-error?
631           (remove-if #'alpha-char-p string :start 4 :end 2)))
632  (assert (raises-error?
633           (remove-if #'alpha-char-p string :start 6 :end 9)))
634  (assert (equal (remove-if-not #'alpha-char-p string :start 0 :end nil)
635                 "aaaaa"))
636  (assert (equal (remove-if-not #'alpha-char-p string :start 0 :end 5)
637                 "aaaaa"))
638  (assert (raises-error?
639           (remove-if-not #'alpha-char-p string :start 0 :end 6)))
640  (assert (raises-error?
641           (remove-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)))
642  (assert (raises-error?
643           (remove-if-not #'alpha-char-p string :start 4 :end 2)))
644  (assert (raises-error?
645           (remove-if-not #'alpha-char-p string :start 6 :end 9))))
646 (sequence-bounding-indices-test
647  (format t "~&/... DELETE, DELETE-IF, DELETE-IF-NOT")
648  (assert (equal (delete #\a string :start 0 :end nil) ""))
649  (reset)
650  (assert (equal (delete #\a string :start 0 :end 5) ""))
651  (reset)
652  (assert (raises-error? (delete #\a string :start 0 :end 6)))
653  (reset)
654  (assert (raises-error? (delete #\a string :start (opaque-identity -1) :end 5)))
655  (reset)
656  (assert (raises-error? (delete #\a string :start 4 :end 2)))
657  (reset)
658  (assert (raises-error? (delete #\a string :start 6 :end 9)))
659  (reset)
660  (assert (equal (delete-if #'alpha-char-p string :start 0 :end nil) ""))
661  (reset)
662  (assert (equal (delete-if #'alpha-char-p string :start 0 :end 5) ""))
663  (reset)
664  (assert (raises-error?
665           (delete-if #'alpha-char-p string :start 0 :end 6)))
666  (reset)
667  (assert (raises-error?
668           (delete-if #'alpha-char-p string :start (opaque-identity -1) :end 5)))
669  (reset)
670  (assert (raises-error?
671           (delete-if #'alpha-char-p string :start 4 :end 2)))
672  (reset)
673  (assert (raises-error?
674           (delete-if #'alpha-char-p string :start 6 :end 9)))
675  (reset)
676  (assert (equal (delete-if-not #'alpha-char-p string :start 0 :end nil)
677                 "aaaaa"))
678  (reset)
679  (assert (equal (delete-if-not #'alpha-char-p string :start 0 :end 5)
680                 "aaaaa"))
681  (reset)
682  (assert (raises-error?
683           (delete-if-not #'alpha-char-p string :start 0 :end 6)))
684  (reset)
685  (assert (raises-error?
686           (delete-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)))
687  (reset)
688  (assert (raises-error?
689           (delete-if-not #'alpha-char-p string :start 4 :end 2)))
690  (reset)
691  (assert (raises-error?
692           (delete-if-not #'alpha-char-p string :start 6 :end 9))))
693
694 ;;; Function REMOVE-DUPLICATES, DELETE-DUPLICATES
695 (sequence-bounding-indices-test
696  (format t "~&/Function REMOVE-DUPLICATES, DELETE-DUPLICATES")
697  (assert (string= (remove-duplicates string :start 0 :end 5) "a"))
698  (assert (string= (remove-duplicates string :start 0 :end nil) "a"))
699  (assert (raises-error? (remove-duplicates string :start 0 :end 6)))
700  (assert (raises-error? (remove-duplicates string :start (opaque-identity -1) :end 5)))
701  (assert (raises-error? (remove-duplicates string :start 4 :end 2)))
702  (assert (raises-error? (remove-duplicates string :start 6 :end 9)))
703  (assert (string= (delete-duplicates string :start 0 :end 5) "a"))
704  (reset)
705  (assert (string= (delete-duplicates string :start 0 :end nil) "a"))
706  (reset)
707  (assert (raises-error? (delete-duplicates string :start 0 :end 6)))
708  (reset)
709  (assert (raises-error? (delete-duplicates string :start (opaque-identity -1) :end 5)))
710  (reset)
711  (assert (raises-error? (delete-duplicates string :start 4 :end 2)))
712  (reset)
713  (assert (raises-error? (delete-duplicates string :start 6 :end 9))))
714
715 ;;; Function REPLACE
716 (sequence-bounding-indices-test
717  (format t "~&/Function REPLACE")
718  (assert (string= (replace string "bbbbb" :start1 0 :end1 5) "bbbbb"))
719  (assert (string= (replace (copy-seq "ccccc")
720                            string
721                            :start2 0 :end2 nil) "bbbbb"))
722  (assert (raises-error? (replace string "ccccc" :start1 0 :end1 6)))
723  (assert (raises-error? (replace string "ccccc" :start2 (opaque-identity -1) :end2 5)))
724  (assert (raises-error? (replace string "ccccc" :start1 4 :end1 2)))
725  (assert (raises-error? (replace string "ccccc" :start1 6 :end1 9))))
726
727 ;;; Function SEARCH
728 (sequence-bounding-indices-test
729  (format t "~&/Function SEARCH")
730  (assert (= (search "aa" string :start2 0 :end2 5) 0))
731  (assert (null (search string "aa" :start1 0 :end2 nil)))
732  (assert (raises-error? (search "aa" string :start2 0 :end2 6)))
733  (assert (raises-error? (search "aa" string :start2 (opaque-identity -1) :end2 5)))
734  (assert (raises-error? (search "aa" string :start2 4 :end2 2)))
735  (assert (raises-error? (search "aa" string :start2 6 :end2 9))))
736
737 ;;; Function STRING-UPCASE, STRING-DOWNCASE, STRING-CAPITALIZE,
738 ;;; NSTRING-UPCASE, NSTRING-DOWNCASE, NSTRING-CAPITALIZE
739 (defmacro string-case-frob (fn)
740   `(progn
741     (assert (raises-error? (,fn string :start 0 :end 6)))
742     (assert (raises-error? (,fn string :start (opaque-identity -1) :end 5)))
743     (assert (raises-error? (,fn string :start 4 :end 2)))
744     (assert (raises-error? (,fn string :start 6 :end 9)))))
745
746 (sequence-bounding-indices-test
747  (format t "~&/Function STRING-UPCASE, STRING-DOWNCASE, STRING-CAPITALIZE, ...")
748  (string-case-frob string-upcase)
749  (string-case-frob string-downcase)
750  (string-case-frob string-capitalize)
751  (format t "~&/... NSTRING-UPCASE, NSTRING-DOWNCASE, NSTRING-CAPITALIZE")
752  (string-case-frob nstring-upcase)
753  (string-case-frob nstring-downcase)
754  (string-case-frob nstring-capitalize))
755
756 ;;; Function STRING=, STRING/=, STRING<, STRING>, STRING<=, STRING>=,
757 ;;; STRING-EQUAL, STRING-NOT-EQUAL, STRING-LESSP, STRING-GREATERP,
758 ;;; STRING-NOT-GREATERP, STRING-NOT-LESSP
759 (defmacro string-predicate-frob (fn)
760   `(progn
761     (,fn string "abcde" :start1 0 :end1 5)
762     (,fn "fghij" string :start2 0 :end2 nil)
763     (assert (raises-error? (,fn string "klmno"
764                                 :start1 0 :end1 6)))
765     (assert (raises-error? (,fn "pqrst" string
766                                 :start2 (opaque-identity -1) :end2 5)))
767     (assert (raises-error? (,fn "uvwxy" string
768                                 :start1 4 :end1 2)))
769     (assert (raises-error? (,fn string "z" :start2 6 :end2 9)))))
770 (sequence-bounding-indices-test
771  (format t "~&/Function STRING=, STRING/=, STRING<, STRING>, STRING<=, STRING>=, ...")
772  (string-predicate-frob string=)
773  (string-predicate-frob string/=)
774  (string-predicate-frob string<)
775  (string-predicate-frob string>)
776  (string-predicate-frob string<=)
777  (string-predicate-frob string>=))
778 (sequence-bounding-indices-test
779  (format t "~&/... STRING-EQUAL, STRING-NOT-EQUAL, STRING-LESSP, ...")
780  (string-predicate-frob string-equal)
781  (string-predicate-frob string-not-equal)
782  (string-predicate-frob string-lessp))
783 (sequence-bounding-indices-test
784  (format t "~&/... STRING-GREATERP, STRING-NOT-GREATERP, STRING-NOT-LESSP")
785  (string-predicate-frob string-greaterp)
786  (string-predicate-frob string-not-greaterp)
787  (string-predicate-frob string-not-lessp))
788
789 ;;; Function SUBSTITUTE, SUBSTITUTE-IF, SUBSTITUTE-IF-NOT,
790 ;;; NSUBSTITUTE, NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT
791 (sequence-bounding-indices-test
792  (format t "~&/Function SUBSTITUTE, SUBSTITUTE-IF, SUBSTITUTE-IF-NOT, ...")
793  (assert (string= (substitute #\b #\a string :start 0 :end 5) "bbbbb"))
794  (assert (string= (substitute #\c #\a string :start 0 :end nil)
795                   "ccccc"))
796  (assert (raises-error? (substitute #\b #\a string :start 0 :end 6)))
797  (assert (raises-error? (substitute #\b #\a string :start (opaque-identity -1) :end 5)))
798  (assert (raises-error? (substitute #\b #\a string :start 4 :end 2)))
799  (assert (raises-error? (substitute #\b #\a string :start 6 :end 9)))
800  (assert (string= (substitute-if #\b #'alpha-char-p string
801                                  :start 0 :end 5)
802                   "bbbbb"))
803  (assert (string= (substitute-if #\c #'alpha-char-p string
804                                  :start 0 :end nil)
805                   "ccccc"))
806  (assert (raises-error? (substitute-if #\b #'alpha-char-p string
807                                        :start 0 :end 6)))
808  (assert (raises-error? (substitute-if #\b #'alpha-char-p string
809                                        :start (opaque-identity -1) :end 5)))
810  (assert (raises-error? (substitute-if #\b #'alpha-char-p string
811                                        :start 4 :end 2)))
812  (assert (raises-error? (substitute-if #\b #'alpha-char-p string
813                                        :start 6 :end 9)))
814  (assert (string= (substitute-if-not #\b #'alpha-char-p string
815                                      :start 0 :end 5)
816                   "aaaaa"))
817  (assert (string= (substitute-if-not #\c #'alpha-char-p string
818                                      :start 0 :end nil)
819                   "aaaaa"))
820  (assert (raises-error? (substitute-if-not #\b #'alpha-char-p string
821                                            :start 0 :end 6)))
822  (assert (raises-error? (substitute-if-not #\b #'alpha-char-p string
823                                            :start (opaque-identity -1) :end 5)))
824  (assert (raises-error? (substitute-if-not #\b #'alpha-char-p string
825                                            :start 4 :end 2)))
826  (assert (raises-error? (substitute-if-not #\b #'alpha-char-p string
827                                            :start 6 :end 9))))
828 (sequence-bounding-indices-test
829  (format t "~&/... NSUBSTITUTE, NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT")
830  (assert (string= (nsubstitute #\b #\a string :start 0 :end 5) "bbbbb"))
831  (reset)
832  (assert (string= (nsubstitute #\c #\a string :start 0 :end nil)
833                   "ccccc"))
834  (reset)
835  (assert (raises-error? (nsubstitute #\b #\a string :start 0 :end 6)))
836  (reset)
837  (assert (raises-error? (nsubstitute #\b #\a string :start (opaque-identity -1) :end 5)))
838  (reset)
839  (assert (raises-error? (nsubstitute #\b #\a string :start 4 :end 2)))
840  (reset)
841  (assert (raises-error? (nsubstitute #\b #\a string :start 6 :end 9)))
842  (reset)
843  (assert (string= (nsubstitute-if #\b #'alpha-char-p string
844                                   :start 0 :end 5)
845                   "bbbbb"))
846  (reset)
847  (assert (string= (nsubstitute-if #\c #'alpha-char-p string
848                                   :start 0 :end nil)
849                   "ccccc"))
850  (reset)
851  (assert (raises-error? (nsubstitute-if #\b #'alpha-char-p string
852                                         :start 0 :end 6)))
853  (reset)
854  (assert (raises-error? (nsubstitute-if #\b #'alpha-char-p string
855                                         :start (opaque-identity -1) :end 5)))
856  (reset)
857  (assert (raises-error? (nsubstitute-if #\b #'alpha-char-p string
858                                         :start 4 :end 2)))
859  (reset)
860  (assert (raises-error? (nsubstitute-if #\b #'alpha-char-p string
861                                         :start 6 :end 9)))
862  (reset)
863  (assert (string= (nsubstitute-if-not #\b #'alpha-char-p string
864                                       :start 0 :end 5)
865                   "aaaaa"))
866  (reset)
867  (assert (string= (nsubstitute-if-not #\c #'alpha-char-p string
868                                       :start 0 :end nil)
869                   "aaaaa"))
870  (reset)
871  (assert (raises-error? (nsubstitute-if-not #\b #'alpha-char-p string
872                                             :start 0 :end 6)))
873  (reset)
874  (assert (raises-error? (nsubstitute-if-not #\b #'alpha-char-p string
875                                             :start (opaque-identity -1) :end 5)))
876  (reset)
877  (assert (raises-error? (nsubstitute-if-not #\b #'alpha-char-p string
878                                             :start 4 :end 2)))
879  (reset)
880  (assert (raises-error? (nsubstitute-if-not #\b #'alpha-char-p string
881                                             :start 6 :end 9))))
882 ;;; Function WRITE-STRING, WRITE-LINE
883 (sequence-bounding-indices-test
884  (format t "~&/Function WRITE-STRING, WRITE-LINE")
885  (write-string string *standard-output* :start 0 :end 5)
886  (write-string string *standard-output* :start 0 :end nil)
887  (assert (raises-error? (write-string string *standard-output*
888                                       :start 0 :end 6)))
889  (assert (raises-error? (write-string string *standard-output*
890                                       :start (opaque-identity -1) :end 5)))
891  (assert (raises-error? (write-string string *standard-output*
892                                       :start 4 :end 2)))
893  (assert (raises-error? (write-string string *standard-output*
894                                       :start 6 :end 9)))
895  (write-line string *standard-output* :start 0 :end 5)
896  (write-line string *standard-output* :start 0 :end nil)
897  (assert (raises-error? (write-line string *standard-output*
898                                       :start 0 :end 6)))
899  (assert (raises-error? (write-line string *standard-output*
900                                       :start (opaque-identity -1) :end 5)))
901  (assert (raises-error? (write-line string *standard-output*
902                                       :start 4 :end 2)))
903  (assert (raises-error? (write-line string *standard-output*
904                                       :start 6 :end 9))))
905
906 ;;; Macro WITH-INPUT-FROM-STRING
907 (sequence-bounding-indices-test
908  (format t "~&/Macro WITH-INPUT-FROM-STRING")
909  (with-input-from-string (s string :start 0 :end 5)
910    (assert (char= (read-char s) #\a)))
911  (with-input-from-string (s string :start 0 :end nil)
912    (assert (char= (read-char s) #\a)))
913  (assert (raises-error?
914           (with-input-from-string (s string :start 0 :end 6)
915             (read-char s))))
916  (assert (raises-error?
917           (with-input-from-string (s string :start (opaque-identity -1) :end 5)
918             (read-char s))))
919  (assert (raises-error?
920           (with-input-from-string (s string :start 4 :end 2)
921             (read-char s))))
922  (assert (raises-error?
923           (with-input-from-string (s string :start 6 :end 9)
924             (read-char s)))))
925 \f
926 ;;; testing bit-bashing according to _The Practice of Programming_
927 (defun fill-bytes-for-testing (bitsize)
928   "Return a list of 'bytes' of type (MOD BITSIZE)."
929   (remove-duplicates (list 0
930                            (1- (ash 1 (1- bitsize)))
931                            (ash 1 (1- bitsize))
932                            (1- (ash 1 bitsize)))))
933
934 (defun fill-with-known-value (value size &rest vectors)
935   (dolist (vec vectors)
936     (dotimes (i size)
937       (setf (aref vec i) value))))
938
939 (defun collect-fill-amounts (n-power)
940   (remove-duplicates
941    (loop for i from 0 upto n-power
942          collect (1- (expt 2 i))
943          collect (expt 2 i)
944          collect (1+ (expt 2 i)))))
945
946 (defun test-fill-bashing (bitsize padding-amount n-power)
947   (let* ((size (+ (* padding-amount 2) (expt 2 n-power) (* padding-amount 2)))
948          (standard (make-array size :element-type `(unsigned-byte ,bitsize)))
949          (bashed (make-array size :element-type `(unsigned-byte ,bitsize)))
950          (fill-amounts (collect-fill-amounts n-power))
951          (bash-function (intern (format nil "UB~A-BASH-FILL" bitsize)
952                                 (find-package "SB-KERNEL"))))
953     (format t "~&/Function ~A..." bash-function)
954     (loop for offset from padding-amount below (* 2 padding-amount) do
955           (dolist (c (fill-bytes-for-testing bitsize))
956             (dolist (n fill-amounts)
957               (fill-with-known-value (mod (lognot c) (ash 1 bitsize)) n
958                                      standard bashed)
959               ;; fill vectors
960               ;; a) the standard slow way
961               (locally (declare (notinline fill))
962                 (fill standard c :start offset :end (+ offset n)))
963               ;; b) the blazingly fast way
964               (let ((value (loop for i from 0 by bitsize
965                                  until (= i sb-vm:n-word-bits)
966                                  sum (ash c i))))
967                 (funcall bash-function value bashed offset n))
968               ;; check for errors
969               (when (mismatch standard bashed)
970                 (format t "Test with offset ~A, fill ~A and length ~A failed.~%"
971                         offset c n)
972                 (format t "Mismatch: ~A ~A~%"
973                         (subseq standard 0 (+ offset n 1))
974                         (subseq bashed 0 (+ offset n 1)))
975                 (return-from test-fill-bashing nil))))
976           finally (return t))))
977
978 (defun test-copy-bashing (bitsize padding-amount n-power)
979   (let* ((size (+ (* padding-amount 2) (expt 2 n-power) (* padding-amount 2)))
980          (standard-dst (make-array size :element-type `(unsigned-byte ,bitsize)))
981          (bashed-dst (make-array size :element-type `(unsigned-byte ,bitsize)))
982          (source (make-array size :element-type `(unsigned-byte ,bitsize)))
983          (fill-amounts (collect-fill-amounts n-power))
984          (bash-function (intern (format nil "UB~A-BASH-COPY" bitsize)
985                                 (find-package "SB-KERNEL"))))
986     (format t "~&/Function ~A..." bash-function)
987     (do ((source-offset padding-amount (1+ source-offset)))
988         ((>= source-offset (* padding-amount 2))
989          ;; success!
990          t)
991      (do ((target-offset padding-amount (1+ target-offset)))
992          ((>= target-offset (* padding-amount 2)))
993        (dolist (c (fill-bytes-for-testing bitsize))
994          (dolist (n fill-amounts)
995            (fill-with-known-value (mod (lognot c) (ash 1 bitsize)) size
996                                   source standard-dst bashed-dst)
997            ;; fill with test data
998            (fill source c :start source-offset :end (+ source-offset n))
999            ;; copy filled test data to test vectors
1000            ;; a) the slow way
1001            (replace standard-dst source
1002                     :start1 target-offset :end1 (+ target-offset n)
1003                     :start2 source-offset :end2 (+ source-offset n))
1004            ;; b) the blazingly fast way
1005            (funcall bash-function source source-offset
1006                     bashed-dst target-offset n)
1007            ;; check for errors
1008            (when (mismatch standard-dst bashed-dst)
1009              (format t "Test with target-offset ~A, source-offset ~A, fill ~A, and length ~A failed.~%"
1010                      target-offset source-offset c n)
1011              (format t "Mismatch:~% correct ~A~% actual  ~A~%"
1012                      standard-dst
1013                      bashed-dst)
1014              (return-from test-copy-bashing nil))))))))
1015
1016 ;; Too slow for the interpreter
1017 #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
1018 (loop for i = 1 then (* i 2) do
1019      ;; the bare '13' here is fairly arbitrary, except that it's been
1020      ;; reduced from '32', which made the tests take aeons; '8' provides
1021      ;; a good range of lengths over which to fill and copy, which
1022      ;; should tease out most errors in the code (if any exist).  (It
1023      ;; also makes this part of the test suite finish reasonably
1024      ;; quickly.)
1025      (assert (time (test-fill-bashing i 13 8)))
1026      (assert (time (test-copy-bashing i 13 8)))
1027      until (= i sb-vm:n-word-bits))
1028
1029 (defun test-inlined-bashing (bitsize)
1030   ;; We have to compile things separately for each bitsize so the
1031   ;; compiler will work out the array type and trigger the REPLACE
1032   ;; transform.
1033   (let ((lambda-form
1034          `(lambda ()
1035             (let* ((n-elements-per-word ,(truncate sb-vm:n-word-bits bitsize))
1036                    (size (* 3 n-elements-per-word))
1037                    (standard-dst (make-array size :element-type '(unsigned-byte ,bitsize)))
1038                    (bashed-dst (make-array size :element-type '(unsigned-byte ,bitsize)))
1039                    (source (make-array size :element-type '(unsigned-byte ,bitsize))))
1040               (declare (type (simple-array (unsigned-byte ,bitsize) (*))
1041                              source standard-dst bashed-dst))
1042               (do ((i 0 (1+ i))
1043                    (offset n-elements-per-word (1+ offset)))
1044                   ((>= offset (* 2 n-elements-per-word)) t)
1045                 (dolist (c (fill-bytes-for-testing ,bitsize))
1046                   (fill-with-known-value (mod (lognot c) (ash 1 ,bitsize)) size
1047                                          source standard-dst bashed-dst)
1048                   ;; fill with test-data
1049                   (fill source c :start offset :end (+ offset n-elements-per-word))
1050                   ;; copy filled data to test vectors
1051                   ;;
1052                   ;; a) the slow way (which is actually fast, since this
1053                   ;; should be transformed into UB*-BASH-COPY)
1054                   (replace standard-dst source
1055                            :start1 (- offset n-elements-per-word i)
1056                            :start2 (- offset n-elements-per-word i)
1057                            :end1 offset :end2 offset)
1058                   ;; b) the fast way--we fold the
1059                   ;; :START{1,2} arguments above ourselves
1060                   ;; to trigger the REPLACE transform
1061                   (replace bashed-dst source
1062                            :start1 0 :start2 0 :end1 offset :end2 offset)
1063                   ;; check for errors
1064                   (when (or (mismatch standard-dst bashed-dst)
1065                             ;; trigger COPY-SEQ transform
1066                             (mismatch (copy-seq standard-dst) bashed-dst)
1067                             ;; trigger SUBSEQ transform
1068                             (mismatch (subseq standard-dst (- offset n-elements-per-word i))
1069                                       bashed-dst))
1070                     (format t "Test with target-offset ~A, source-offset ~A, fill ~A, and length ~A failed.~%"
1071                             0 0 c offset)
1072                     (format t "Mismatch:~% correct ~A~% actual  ~A~%"
1073                             standard-dst
1074                             bashed-dst)
1075                     (return-from nil nil))))))))
1076     (funcall (compile nil lambda-form))))
1077
1078 #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
1079 (loop for i = 1 then (* i 2) do
1080       (assert (test-inlined-bashing i))
1081       until (= i sb-vm:n-word-bits))
1082 \f
1083 ;;; tests from the Sacla test suite via Eric Marsden, 2007-05-07
1084 (remove-duplicates (vector 1 2 2 1) :test-not (lambda (a b) (not (= a b))))
1085
1086 (delete-duplicates (vector #\a #\b #\c #\a)
1087                    :test-not (lambda (a b) (not (char-equal a b))))
1088
1089 ;;; FILL on lists
1090 (let ((l (list 1 2 3)))
1091   (assert (eq l (fill l 0 :start 1 :end 2)))
1092   (assert (equal l '(1 0 3)))
1093   (assert (eq l (fill l 'x :start 2 :end 3)))
1094   (assert (equal l '(1 0 x)))
1095   (assert (eq l (fill l 'y :start 1)))
1096   (assert (equal l '(1 y y)))
1097   (assert (eq l (fill l 'z :end 2)))
1098   (assert (equal l '(z z y)))
1099   (assert (eq l (fill l 1)))
1100   (assert (equal l '(1 1 1)))
1101   (assert (raises-error? (fill l 0 :start 4)))
1102   (assert (raises-error? (fill l 0 :end 4)))
1103   (assert (raises-error? (fill l 0 :start 2 :end 1))))
1104
1105 ;;; Both :TEST and :TEST-NOT provided
1106 (with-test (:name :test-and-test-not-to-adjoin)
1107   (let* ((wc 0)
1108          (fun
1109           (handler-bind (((and warning (not style-warning))
1110                           (lambda (w) (incf wc))))
1111             (compile nil `(lambda (item test test-not) (adjoin item '(1 2 3 :foo)
1112                                                                :test test
1113                                                                :test-not test-not))))))
1114     (assert (= 1 wc))
1115     (assert (eq :error
1116                 (handler-case
1117                     (funcall fun 1 #'eql (complement #'eql))
1118                   (error ()
1119                     :error))))))
1120 \f
1121 ;;; tests of deftype types equivalent to STRING or SIMPLE-STRING
1122 (deftype %string () 'string)
1123 (deftype %simple-string () 'simple-string)
1124 (deftype string-3 () '(string 3))
1125 (deftype simple-string-3 () '(simple-string 3))
1126
1127 (with-test (:name :user-defined-string-types-map-etc)
1128   (dolist (type '(%string %simple-string string-3 simple-string-3))
1129     (assert (string= "foo" (coerce '(#\f #\o #\o) type)))
1130     (assert (string= "foo" (map type 'identity #(#\f #\o #\o))))
1131     (assert (string= "foo" (merge type '(#\o) '(#\f #\o) 'char<)))
1132     (assert (string= "foo" (concatenate type '(#\f) "oo")))
1133     (assert (string= "ooo" (make-sequence type 3 :initial-element #\o)))))
1134 (with-test (:name :user-defined-string-types-map-etc-error)
1135   (dolist (type '(string-3 simple-string-3))
1136     (assert (raises-error? (coerce '(#\q #\u #\u #\x) type)))
1137     (assert (raises-error? (map type 'identity #(#\q #\u #\u #\x))))
1138     (assert (raises-error? (merge type '(#\q #\x) "uu" 'char<)))
1139     (assert (raises-error? (concatenate type "qu" '(#\u #\x))))
1140     (assert (raises-error? (make-sequence type 4 :initial-element #\u)))))
1141
1142 (defun test-bit-position (size set start end from-end res)
1143   (let ((v (make-array size :element-type 'bit :initial-element 0)))
1144     (dolist (i set)
1145       (setf (bit v i) 1))
1146     (dolist (f (list (compile nil
1147                               `(lambda (b v s e fe)
1148                                  (position b (the bit-vector v) :start s :end e :from-end fe)))
1149                      (compile nil
1150                               `(lambda (b v s e fe)
1151                                  (assert (eql b 1))
1152                                  (position 1 (the bit-vector v) :start s :end e :from-end fe)))
1153                      (compile nil
1154                               `(lambda (b v s e fe)
1155                                  (position b (the vector v) :start s :end e :from-end fe)))))
1156       (let ((got (funcall f 1 v start end from-end)))
1157         (unless (eql res got)
1158           (cerror "Continue" "POSITION 1, Wanted ~S, got ~S.~%  size = ~S, set = ~S, from-end = ~S"
1159                   res got
1160                   size set from-end)))))
1161   (let ((v (make-array size :element-type 'bit :initial-element 1)))
1162     (dolist (i set)
1163       (setf (bit v i) 0))
1164     (dolist (f (list (compile nil
1165                               `(lambda (b v s e fe)
1166                                  (position b (the bit-vector v) :start s :end e :from-end fe)))
1167                      (compile nil
1168                               `(lambda (b v s e fe)
1169                                  (assert (eql b 0))
1170                                  (position 0 (the bit-vector v) :start s :end e :from-end fe)))
1171                      (compile nil
1172                               `(lambda (b v s e fe)
1173                                  (position b (the vector v) :start s :end e :from-end fe)))))
1174       (let ((got (funcall f 0 v start end from-end)))
1175         (unless (eql res got)
1176           (cerror "Continue" "POSITION 0, Wanted ~S, got ~S.~%  size = ~S, set = ~S, from-end = ~S"
1177                   res got
1178                   size set from-end))))))
1179
1180 (defun random-test-bit-position (n)
1181   (loop repeat n
1182         do (let* ((vector (make-array (+ 2 (random 5000)) :element-type 'bit))
1183                   (offset (random (1- (length vector))))
1184                   (size (1+ (random (- (length vector) offset))))
1185                   (disp (make-array size :element-type 'bit :displaced-to vector
1186                                          :displaced-index-offset offset)))
1187              (assert (plusp size))
1188              (loop repeat 10
1189                    do (setf (bit vector (random (length vector))) 1))
1190              (flet ((test (orig)
1191                       (declare (bit-vector orig))
1192                       (let ((copy (coerce orig 'simple-vector))
1193                             (p0 (random (length orig)))
1194                             (p1 (1+ (random (length orig)))))
1195                         (multiple-value-bind (s e)
1196                             (if (> p1 p0)
1197                                 (values p0 p1)
1198                                 (values p1 p0))
1199                           (assert (eql (position 1 copy :start s :end e)
1200                                        (position 1 orig :start s :end e)))
1201                           (assert (eql (position 1 copy :start s :end e :from-end t)
1202                                        (position 1 orig :start s :end e :from-end t)))))))
1203                (test vector)
1204                (test disp)))))
1205
1206 (with-test (:name :bit-position)
1207   (test-bit-position 0 (list) 0 0 nil nil)
1208   (test-bit-position 0 (list) 0 0 t nil)
1209   (test-bit-position 1 (list 0) 0 0 nil nil)
1210   (test-bit-position 1 (list 0) 0 0 t nil)
1211   (test-bit-position 1 (list 0) 0 1 nil 0)
1212   (test-bit-position 1 (list 0) 0 1 t 0)
1213   (test-bit-position 10 (list 0 1) 0 1 nil 0)
1214   (test-bit-position 10 (list 0 1) 1 1 nil nil)
1215   (test-bit-position 10 (list 0 1) 0 1 t 0)
1216   (test-bit-position 10 (list 0 1) 1 1 t nil)
1217   (test-bit-position 10 (list 0 3) 1 4 nil 3)
1218   (test-bit-position 10 (list 0 3) 1 4 t 3)
1219   (test-bit-position 10 (list 0 3 6) 1 10 nil 3)
1220   (test-bit-position 10 (list 0 3 6) 1 10 t 6)
1221   (test-bit-position 1000 (list 128 700) 20 500 nil 128)
1222   (test-bit-position 1000 (list 128 700) 20 500 t 128)
1223   (test-bit-position 1000 (list 423 762) 200 800 nil 423)
1224   (test-bit-position 1000 (list 423 762) 200 800 t 762)
1225   (test-bit-position 1000 (list 298 299) 100 400 nil 298)
1226   (test-bit-position 1000 (list 298 299) 100 400 t 299))
1227
1228 (with-test (:name (:bit-position :random-test))
1229   (random-test-bit-position 10000))
1230
1231 ;;; success