1 ;;;; tests related to sequences
3 ;;;; This file is impure because we want to be able to use DEFUN.
5 ;;;; This software is part of the SBCL system. See the README file for
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
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.
18 (load "assertoid.lisp")
19 (use-package "ASSERTOID")
21 ;;; helper functions for exercising SEQUENCE code on data of many
22 ;;; specialized types, and in many different optimization scenarios
23 (defun for-every-seq-1 (base-seq snippet)
24 (dolist (seq-type '(list
27 (simple-array character 1)
29 (simple-array (signed-byte 4) 1)
30 (vector (signed-byte 4))))
31 (flet ((entirely (eltype)
32 (every (lambda (el) (typep el eltype)) base-seq)))
33 (dolist (declaredness '(nil t))
34 (dolist (optimization '(((speed 3) (space 0))
37 ((speed 0) (space 1))))
38 (let* ((seq (if (eq seq-type 'list)
39 (coerce base-seq 'list)
40 (destructuring-bind (type-first &rest type-rest)
44 (destructuring-bind (eltype one) type-rest
47 (coerce base-seq seq-type)
50 (destructuring-bind (eltype) type-rest
52 (let ((initial-element
53 (cond ((subtypep eltype 'character)
55 ((subtypep eltype 'number)
68 (lambda-expr `(lambda (seq)
70 `((declare (type ,seq-type seq))))
71 (declare (optimize ,@optimization))
73 (format t "~&~S~%" lambda-expr)
74 (multiple-value-bind (fun warnings-p failure-p)
75 (compile nil lambda-expr)
76 (when (or warnings-p failure-p)
77 (error "~@<failed compilation:~2I ~_LAMBDA-EXPR=~S ~_WARNINGS-P=~S ~_FAILURE-P=~S~:@>"
78 lambda-expr warnings-p failure-p))
79 (format t "~&~S ~S~%~S~%~S ~S~%"
80 base-seq snippet seq-type declaredness optimization)
81 (format t "~&(TYPEP SEQ 'SIMPLE-ARRAY)=~S~%"
82 (typep seq 'simple-array))
83 (unless (funcall fun seq)
84 (error "~@<failed test:~2I ~_BASE-SEQ=~S ~_SNIPPET=~S ~_SEQ-TYPE=~S ~_DECLAREDNESS=~S ~_OPTIMIZATION=~S~:@>"
90 (defun for-every-seq (base-seq snippets)
91 (dolist (snippet snippets)
92 (for-every-seq-1 base-seq snippet)))
94 ;;; a wrapper to hide declared type information from the compiler, so
95 ;;; we don't get stopped by compiler warnings about e.g. compiling
96 ;;; (POSITION 1 #() :KEY #'ABS) when #() has been coerced to a string.
97 (defun indiscriminate (fun)
98 (lambda (&rest rest) (apply fun rest)))
100 ;;; asymmetric test arg order example from ANSI FIND definition page
101 (assert (eql #\space ; original example, depends on ASCII character ordering
102 (find #\d "here are some letters that can be looked at"
104 (assert (eql #\e ; modified example, depends only on standard a-z ordering
105 (find #\f "herearesomeletters" :test #'char>)))
106 (assert (eql 4 ; modified more, avoids charset technicalities completely
107 (find 5 '(6 4) :test '>)))
109 ;;; tests of FIND, POSITION, FIND-IF, and POSITION-IF (and a few for
110 ;;; deprecated FIND-IF-NOT and POSITION-IF-NOT too)
112 '((null (find 1 seq))
113 (null (find 1 seq :from-end t))
114 (null (position 1 seq :key (indiscriminate #'abs)))
115 (null (position nil seq :test (constantly t)))
116 (null (position nil seq :test nil))
117 (null (position nil seq :test-not nil))
118 (null (find-if #'1+ seq :key (indiscriminate #'log)))
119 (null (position-if #'identity seq :from-end t))
120 (null (find-if-not #'packagep seq))
121 (null (position-if-not #'packagep seq :key nil))))
123 '((null (find 2 seq))
124 ;; Get the argument ordering for asymmetric tests like #'> right.
125 ;; (bug reported and fixed by Alexey Dejneka sbcl-devel 2001-10-17)
126 (eql 1 (find 2 seq :test #'>))
127 (find 2 seq :key #'1+)
128 (find 1 seq :from-end t)
129 (null (find 1 seq :from-end t :start 1))
130 (null (find 0 seq :from-end t))
131 (eql 0 (position 1 seq :key #'abs))
132 (null (position nil seq :test 'equal))
133 (eql 1 (find-if #'1- seq :key #'log))
134 (eql 0 (position-if #'identity seq :from-end t))
135 (null (find-if-not #'sin seq))
136 (eql 0 (position-if-not #'packagep seq :key 'identity))))
137 (for-every-seq #(1 2 3 2 1)
139 (find 3 seq :from-end 'yes)
140 (eql 1 (position 1.5 seq :test #'<))
141 (eql 0 (position 0 seq :key '1-))
142 (eql 4 (position 0 seq :key '1- :from-end t))
143 (eql 2 (position 4 seq :key '1+))
144 (eql 2 (position 4 seq :key '1+ :from-end t))
145 (eql 1 (position 2 seq))
146 (eql 1 (position 2 seq :start 1))
147 (null (find 2 seq :start 1 :end 1))
148 (eql 3 (position 2 seq :start 2))
149 (eql 3 (position 2 seq :key nil :from-end t))
150 (eql 2 (position 3 seq :test '=))
151 (eql 0 (position 3 seq :test-not 'equalp))
152 (eql 2 (position 3 seq :test 'equal :from-end t))
153 (null (position 4 seq :test #'eql))
154 (null (find-if #'packagep seq))
155 (eql 1 (find-if #'plusp seq))
156 (eql 3 (position-if #'plusp seq :key #'1- :from-end t))
157 (eql 1 (position-if #'evenp seq))
158 (eql 3 (position-if #'evenp seq :from-end t))
159 (eql 2 (position-if #'plusp seq :from-end nil :key '1- :start 2))
160 (eql 3 (position-if #'plusp seq :from-end t :key '1- :start 2))
161 (null (position-if #'plusp seq :from-end t :key '1- :start 2 :end 2))
162 (null (find-if-not #'plusp seq))
163 (eql 0 (position-if-not #'evenp seq))))
164 (for-every-seq "string test"
165 '((null (find 0 seq))
166 (null (find #\D seq :key #'char-upcase))
167 (find #\E seq :key #'char-upcase)
168 (null (find #\e seq :key #'char-upcase))
169 (eql 3 (position #\i seq))
170 (eql 0 (position #\s seq :key #'char-downcase))
171 (eql 1 (position #\s seq :key #'char-downcase :test #'char/=))
172 (eql 9 (position #\s seq :from-end t :test #'char=))
173 (eql 10 (position #\s seq :from-end t :test #'char/=))
174 (eql 4 (position #\N seq :from-end t :key 'char-upcase :test #'char-equal))
175 (eql 5 (position-if (lambda (c) (equal #\g c)) seq))
176 (eql 5 (position-if (lambda (c) (equal #\g c)) seq :from-end t))
177 (find-if #'characterp seq)
178 (find-if (lambda (c) (typep c 'base-char)) seq :from-end t)
179 (null (find-if 'upper-case-p seq))))
182 (let ((avec (make-array 10
184 :initial-contents '(0 1 2 3 iv v vi vii iix ix))))
185 ;; These first five always worked AFAIK.
186 (assert (equalp (subseq avec 0 3) #(0 1 2)))
187 (assert (equalp (subseq avec 3 3) #()))
188 (assert (equalp (subseq avec 1 3) #(1 2)))
189 (assert (equalp (subseq avec 1) #(1 2 3)))
190 (assert (equalp (subseq avec 1 4) #(1 2 3)))
191 ;; SBCL bug found ca. 2002-05-01 by OpenMCL's correct handling of
192 ;; SUBSEQ, CSR's driving portable cross-compilation far enough to
193 ;; reach the SUBSEQ calls in assem.lisp, and WHN's sleazy
194 ;; translation of old CMU CL new-assem.lisp into sufficiently grotty
195 ;; portable Lisp that it passed suitable illegal values to SUBSEQ to
196 ;; exercise the bug:-|
198 ;; SUBSEQ should check its END value against logical LENGTH, not
199 ;; physical ARRAY-DIMENSION 0.
201 ;; fixed in sbcl-0.7.4.22 by WHN
202 (assert (null (ignore-errors (aref (subseq avec 1 5) 0)))))
205 (defun test-fill-typecheck (x)
206 (declare (optimize (safety 3) (space 2) (speed 1)))
207 (fill (make-string 10) x))
209 (assert (string= (test-fill-typecheck #\@) "@@@@@@@@@@"))
210 ;;; BUG 186, fixed in sbcl-0.7.5.5
211 (assert (null (ignore-errors (test-fill-typecheck 4097))))
213 ;;; MAKE-SEQUENCE, COERCE, CONCATENATE, MERGE, MAP and requested
214 ;;; result type (BUGs 46a, 46b, 66)
215 (macrolet ((assert-type-error (form)
216 `(assert (typep (nth-value 1 (ignore-errors ,form))
218 (dolist (type-stub '((simple-vector)
220 (vector (signed-byte 8))
221 (vector (unsigned-byte 16))
222 (vector (signed-byte 32))
223 (simple-bit-vector)))
224 (declare (optimize safety))
225 (format t "~&~S~%" type-stub)
227 (assert (= (length (make-sequence `(,@type-stub) 10)) 10))
228 (assert (= (length (make-sequence `(,@type-stub 10) 10)) 10))
229 (assert-type-error (make-sequence `(,@type-stub 10) 11))
231 (assert (= (length (coerce '(0 0 0) `(,@type-stub))) 3))
232 (assert (= (length (coerce #(0 0 0) `(,@type-stub 3))) 3))
233 (assert-type-error (coerce #*111 `(,@type-stub 4)))
235 (assert (= (length (concatenate `(,@type-stub) #(0 0 0) #*111)) 6))
236 (assert (equalp (concatenate `(,@type-stub) #(0 0 0) #*111)
237 (coerce #(0 0 0 1 1 1) `(,@type-stub))))
238 (assert (= (length (concatenate `(,@type-stub 6) #(0 0 0) #*111)) 6))
239 (assert (equalp (concatenate `(,@type-stub 6) #(0 0 0) #*111)
240 (coerce #(0 0 0 1 1 1) `(,@type-stub 6))))
241 (assert-type-error (concatenate `(,@type-stub 5) #(0 0 0) #*111))
243 (assert (= (length (merge `(,@type-stub) #(0 1 0) #*111 #'>)) 6))
244 (assert (equalp (merge `(,@type-stub) #(0 1 0) #*111 #'>)
245 (coerce #(1 1 1 0 1 0) `(,@type-stub))))
246 (assert (= (length (merge `(,@type-stub 6) #(0 1 0) #*111 #'>)) 6))
247 (assert (equalp (merge `(,@type-stub 6) #(0 1 0) #*111 #'>)
248 (coerce #(1 1 1 0 1 0) `(,@type-stub 6))))
249 (assert-type-error (merge `(,@type-stub 4) #(0 1 0) #*111 #'>))
251 (assert (= (length (map `(,@type-stub) #'logxor #(0 0 1 1) '(0 1 0 1))) 4))
252 (assert (equalp (map `(,@type-stub) #'logxor #(0 0 1 1) '(0 1 0 1))
253 (coerce #(0 1 1 0) `(,@type-stub))))
254 (assert (= (length (map `(,@type-stub 4) #'logxor #(0 0 1 1) '(0 1 0 1)))
256 (assert (equalp (map `(,@type-stub 4) #'logxor #(0 0 1 1) '(0 1 0 1))
257 (coerce #(0 1 1 0) `(,@type-stub 4))))
258 (assert-type-error (map `(,@type-stub 5) #'logxor #(0 0 1 1) '(0 1 0 1))))
259 ;; some more CONCATENATE tests for strings
261 (declare (optimize safety))
262 (assert (string= (concatenate 'string "foo" " " "bar") "foo bar"))
263 (assert (string= (concatenate '(string 7) "foo" " " "bar") "foo bar"))
264 (assert-type-error (concatenate '(string 6) "foo" " " "bar"))
265 (assert (string= (concatenate '(string 6) "foo" #(#\b #\a #\r)) "foobar"))
266 (assert-type-error (concatenate '(string 7) "foo" #(#\b #\a #\r))))
267 ;; Non-VECTOR ARRAY types aren't allowed as vector type specifiers.
269 (declare (optimize safety))
270 (assert-type-error (concatenate 'simple-array "foo" "bar"))
271 (assert-type-error (map 'simple-array #'identity '(1 2 3)))
272 (assert (equalp #(11 13)
273 (map '(simple-array fixnum (*)) #'+ '(1 2 3) '(10 11))))
274 (assert-type-error (coerce '(1 2 3) 'simple-array))
275 (assert-type-error (merge 'simple-array '(1 3) '(2 4) '<))
276 (assert (equalp #(3 2 1) (coerce '(3 2 1) '(vector fixnum))))
277 (assert-type-error (map 'array #'identity '(1 2 3)))
278 (assert-type-error (map '(array fixnum) #'identity '(1 2 3)))
279 (assert (equalp #(1 2 3) (coerce '(1 2 3) '(vector fixnum))))
280 ;; but COERCE has an exemption clause:
281 (assert (string= "foo" (coerce "foo" 'simple-array)))
282 ;; ... though not in all cases.
283 (assert-type-error (coerce '(#\f #\o #\o) 'simple-array))))
285 ;;; As pointed out by Raymond Toy on #lisp IRC, MERGE had some issues
286 ;;; with user-defined types until sbcl-0.7.8.11
287 (deftype list-typeoid () 'list)
288 (assert (equal '(1 2 3 4) (merge 'list-typeoid '(1 3) '(2 4) '<)))
289 ;;; and also with types that weren't precicely LIST
290 (assert (equal '(1 2 3 4) (merge 'cons '(1 3) '(2 4) '<)))
292 ;;; but wait, there's more! The NULL and CONS types also have implicit
293 ;;; length requirements:
294 (macrolet ((assert-type-error (form)
295 `(assert (typep (nth-value 1 (ignore-errors ,form))
298 (declare (optimize safety))
300 (assert-type-error (make-sequence 'cons 0))
301 (assert-type-error (make-sequence 'null 1))
302 ;; KLUDGE: I'm not certain that this test actually tests for what
303 ;; it should test, in that the type deriver and optimizers might
304 ;; be too smart for the good of an exhaustive test system.
305 ;; However, it makes me feel good. -- CSR, 2002-10-18
306 (assert (null (make-sequence 'null 0)))
307 (assert (= (length (make-sequence 'cons 3)) 3))
308 ;; and NIL is not a valid type for MAKE-SEQUENCE
309 (assert-type-error (make-sequence 'nil 0))
311 (assert-type-error (coerce #(1) 'null))
312 (assert-type-error (coerce #() 'cons))
313 (assert (null (coerce #() 'null)))
314 (assert (= (length (coerce #(1) 'cons)) 1))
315 (assert-type-error (coerce #() 'nil))
317 (assert-type-error (merge 'null '(1 3) '(2 4) '<))
318 (assert-type-error (merge 'cons () () '<))
319 (assert (null (merge 'null () () '<)))
320 (assert (= (length (merge 'cons '(1 3) '(2 4) '<)) 4))
321 (assert-type-error (merge 'nil () () '<))
323 (assert-type-error (concatenate 'null '(1) "2"))
324 (assert-type-error (concatenate 'cons #() ()))
325 (assert (null (concatenate 'null () #())))
326 (assert (= (length (concatenate 'cons #() '(1) "2 3")) 4))
327 (assert-type-error (concatenate 'nil '(3)))
328 ;; FIXME: tests for MAP to come when some brave soul implements
329 ;; the analogous type checking for MAP/%MAP.
332 ;;; ELT should signal an error of type TYPE-ERROR if its index
333 ;;; argument isn't a valid sequence index for sequence:
334 (defun test-elt-signal (x)
336 (assert (raises-error? (test-elt-signal "foo") type-error))
337 (assert (eql (test-elt-signal "foob") #\b))
339 (declare (optimize (safety 3)))
340 (assert (raises-error? (elt (list 1 2 3) 3) type-error)))
342 ;;; checks for uniform bounding index handling under SAFETY 3 code.
344 ;;; KLUDGE: not all in one big form because that causes SBCL to spend
345 ;;; an absolute age trying to compile it.
346 (defmacro sequence-bounding-indices-test (&body body)
348 ;; See Issues 332 [and 333(!)] in the CLHS
349 (declare (optimize (safety 3)))
350 (let ((string (make-array 10
353 :element-type 'base-char)))
355 (setf (fill-pointer string) 10)
357 (setf (fill-pointer string) 5)))
358 (declare (ignorable #'reset))
360 (declaim (notinline opaque-identity))
361 (defun opaque-identity (x) x)
363 (sequence-bounding-indices-test
364 (format t "~&/Accessor SUBSEQ~%")
365 (assert (string= (subseq string 0 5) "aaaaa"))
366 (assert (raises-error? (subseq string 0 6)))
367 (assert (raises-error? (subseq string (opaque-identity -1) 5)))
368 (assert (raises-error? (subseq string 4 2)))
369 (assert (raises-error? (subseq string 6)))
370 (assert (string= (setf (subseq string 0 5) "abcde") "abcde"))
371 (assert (string= (subseq string 0 5) "abcde"))
373 (assert (raises-error? (setf (subseq string 0 6) "abcdef")))
374 (assert (raises-error? (setf (subseq string (opaque-identity -1) 5) "abcdef")))
375 (assert (raises-error? (setf (subseq string 4 2) "")))
376 (assert (raises-error? (setf (subseq string 6) "ghij"))))
378 ;;; Function COUNT, COUNT-IF, COUNT-IF-NOT
379 (sequence-bounding-indices-test
380 (format t "~&/Function COUNT, COUNT-IF, COUNT-IF-NOT")
381 (assert (= (count #\a string :start 0 :end nil) 5))
382 (assert (= (count #\a string :start 0 :end 5) 5))
383 (assert (raises-error? (count #\a string :start 0 :end 6)))
384 (assert (raises-error? (count #\a string :start (opaque-identity -1) :end 5)))
385 (assert (raises-error? (count #\a string :start 4 :end 2)))
386 (assert (raises-error? (count #\a string :start 6 :end 9)))
387 (assert (= (count-if #'alpha-char-p string :start 0 :end nil) 5))
388 (assert (= (count-if #'alpha-char-p string :start 0 :end 5) 5))
389 (assert (raises-error?
390 (count-if #'alpha-char-p string :start 0 :end 6)))
391 (assert (raises-error?
392 (count-if #'alpha-char-p string :start (opaque-identity -1) :end 5)))
393 (assert (raises-error?
394 (count-if #'alpha-char-p string :start 4 :end 2)))
395 (assert (raises-error?
396 (count-if #'alpha-char-p string :start 6 :end 9)))
397 (assert (= (count-if-not #'alpha-char-p string :start 0 :end nil) 0))
398 (assert (= (count-if-not #'alpha-char-p string :start 0 :end 5) 0))
399 (assert (raises-error?
400 (count-if-not #'alpha-char-p string :start 0 :end 6)))
401 (assert (raises-error?
402 (count-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)))
403 (assert (raises-error?
404 (count-if-not #'alpha-char-p string :start 4 :end 2)))
405 (assert (raises-error?
406 (count-if-not #'alpha-char-p string :start 6 :end 9))))
409 (sequence-bounding-indices-test
410 (format t "~&/Function FILL~%")
411 (assert (string= (fill string #\b :start 0 :end 5) "bbbbb"))
412 (assert (string= (fill string #\c :start 0 :end nil) "ccccc"))
413 (assert (raises-error? (fill string #\d :start 0 :end 6)))
414 (assert (raises-error? (fill string #\d :start (opaque-identity -1) :end 5)))
415 (assert (raises-error? (fill string #\d :start 4 :end 2)))
416 (assert (raises-error? (fill string #\d :start 6 :end 9))))
418 ;;; Function FIND, FIND-IF, FIND-IF-NOT
419 (sequence-bounding-indices-test
420 (format t "~&/Function FIND, FIND-IF, FIND-IF-NOT~%")
421 (assert (char= (find #\a string :start 0 :end nil) #\a))
422 (assert (char= (find #\a string :start 0 :end 5) #\a))
423 (assert (raises-error? (find #\a string :start 0 :end 6)))
424 (assert (raises-error? (find #\a string :start (opaque-identity -1) :end 5)))
425 (assert (raises-error? (find #\a string :start 4 :end 2)))
426 (assert (raises-error? (find #\a string :start 6 :end 9)))
427 (assert (char= (find-if #'alpha-char-p string :start 0 :end nil) #\a))
428 (assert (char= (find-if #'alpha-char-p string :start 0 :end 5) #\a))
429 (assert (raises-error?
430 (find-if #'alpha-char-p string :start 0 :end 6)))
431 (assert (raises-error?
432 (find-if #'alpha-char-p string :start (opaque-identity -1) :end 5)))
433 (assert (raises-error?
434 (find-if #'alpha-char-p string :start 4 :end 2)))
435 (assert (raises-error?
436 (find-if #'alpha-char-p string :start 6 :end 9)))
437 (assert (eq (find-if-not #'alpha-char-p string :start 0 :end nil) nil))
438 (assert (eq (find-if-not #'alpha-char-p string :start 0 :end 5) nil))
439 (assert (raises-error?
440 (find-if-not #'alpha-char-p string :start 0 :end 6)))
441 (assert (raises-error?
442 (find-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)))
443 (assert (raises-error?
444 (find-if-not #'alpha-char-p string :start 4 :end 2)))
445 (assert (raises-error?
446 (find-if-not #'alpha-char-p string :start 6 :end 9))))
448 ;;; Function MISMATCH
449 (sequence-bounding-indices-test
450 (format t "~&/Function MISMATCH~%")
451 (assert (null (mismatch string "aaaaa" :start1 0 :end1 nil)))
452 (assert (= (mismatch "aaab" string :start2 0 :end2 4) 3))
453 (assert (raises-error? (mismatch "aaaaaa" string :start2 0 :end2 6)))
454 (assert (raises-error? (mismatch string "aaaaaa" :start1 (opaque-identity -1) :end1 5)))
455 (assert (raises-error? (mismatch string "" :start1 4 :end1 2)))
456 (assert (raises-error? (mismatch "aaaa" string :start2 6 :end2 9))))
458 ;;; Function PARSE-INTEGER
459 (sequence-bounding-indices-test
460 (format t "~&/Function PARSE-INTEGER~%")
461 (setf (fill-pointer string) 10)
462 (setf (subseq string 0 10) "1234567890")
463 (setf (fill-pointer string) 5)
464 (assert (= (parse-integer string :start 0 :end 5) 12345))
465 (assert (= (parse-integer string :start 0 :end nil) 12345))
466 (assert (raises-error? (parse-integer string :start 0 :end 6)))
467 (assert (raises-error? (parse-integer string :start (opaque-identity -1) :end 5)))
468 (assert (raises-error? (parse-integer string :start 4 :end 2)))
469 (assert (raises-error? (parse-integer string :start 6 :end 9))))
471 ;;; Function PARSE-NAMESTRING
472 (sequence-bounding-indices-test
473 (format t "~&/Function PARSE-NAMESTRING~%")
474 (setf (fill-pointer string) 10)
475 (setf (subseq string 0 10) "/dev/ /tmp")
476 (setf (fill-pointer string) 5)
477 (assert (truename (parse-namestring string nil *default-pathname-defaults*
479 (assert (truename (parse-namestring string nil *default-pathname-defaults*
481 (assert (raises-error? (parse-namestring string nil
482 *default-pathname-defaults*
484 (assert (raises-error? (parse-namestring string nil
485 *default-pathname-defaults*
486 :start (opaque-identity -1) :end 5)))
487 (assert (raises-error? (parse-namestring string nil
488 *default-pathname-defaults*
490 (assert (raises-error? (parse-namestring string nil
491 *default-pathname-defaults*
494 ;;; Function POSITION, POSITION-IF, POSITION-IF-NOT
495 (sequence-bounding-indices-test
496 (format t "~&/Function POSITION, POSITION-IF, POSITION-IF-NOT~%")
497 (assert (= (position #\a string :start 0 :end nil) 0))
498 (assert (= (position #\a string :start 0 :end 5) 0))
499 (assert (raises-error? (position #\a string :start 0 :end 6)))
500 (assert (raises-error? (position #\a string :start (opaque-identity -1) :end 5)))
501 (assert (raises-error? (position #\a string :start 4 :end 2)))
502 (assert (raises-error? (position #\a string :start 6 :end 9)))
503 (assert (= (position-if #'alpha-char-p string :start 0 :end nil) 0))
504 (assert (= (position-if #'alpha-char-p string :start 0 :end 5) 0))
505 (assert (raises-error?
506 (position-if #'alpha-char-p string :start 0 :end 6)))
507 (assert (raises-error?
508 (position-if #'alpha-char-p string :start (opaque-identity -1) :end 5)))
509 (assert (raises-error?
510 (position-if #'alpha-char-p string :start 4 :end 2)))
511 (assert (raises-error?
512 (position-if #'alpha-char-p string :start 6 :end 9)))
513 (assert (eq (position-if-not #'alpha-char-p string :start 0 :end nil) nil))
514 (assert (eq (position-if-not #'alpha-char-p string :start 0 :end 5) nil))
515 (assert (raises-error?
516 (position-if-not #'alpha-char-p string :start 0 :end 6)))
517 (assert (raises-error?
518 (position-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)))
519 (assert (raises-error?
520 (position-if-not #'alpha-char-p string :start 4 :end 2)))
521 (assert (raises-error?
522 (position-if-not #'alpha-char-p string :start 6 :end 9))))
524 ;;; Function READ-FROM-STRING
525 (sequence-bounding-indices-test
526 (format t "~&/Function READ-FROM-STRING~%")
527 (setf (subseq string 0 5) "(a b)")
528 (assert (equal (read-from-string string nil nil :start 0 :end 5) '(a b)))
529 (assert (equal (read-from-string string nil nil :start 0 :end nil) '(a b)))
530 (assert (raises-error? (read-from-string string nil nil :start 0 :end 6)))
531 (assert (raises-error? (read-from-string string nil nil :start (opaque-identity -1) :end 5)))
532 (assert (raises-error? (read-from-string string nil nil :start 4 :end 2)))
533 (assert (raises-error? (read-from-string string nil nil :start 6 :end 9))))
536 (sequence-bounding-indices-test
537 (format t "~&/Function REDUCE~%")
538 (setf (subseq string 0 5) "abcde")
539 (assert (equal (reduce #'list* string :from-end t :start 0 :end nil)
540 '(#\a #\b #\c #\d . #\e)))
541 (assert (equal (reduce #'list* string :from-end t :start 0 :end 5)
542 '(#\a #\b #\c #\d . #\e)))
543 (assert (raises-error? (reduce #'list* string :start 0 :end 6)))
544 (assert (raises-error? (reduce #'list* string :start (opaque-identity -1) :end 5)))
545 (assert (raises-error? (reduce #'list* string :start 4 :end 2)))
546 (assert (raises-error? (reduce #'list* string :start 6 :end 9))))
548 ;;; Function REMOVE, REMOVE-IF, REMOVE-IF-NOT, DELETE, DELETE-IF,
550 (sequence-bounding-indices-test
551 (format t "~&/Function REMOVE, REMOVE-IF, REMOVE-IF-NOT, ...~%")
552 (assert (equal (remove #\a string :start 0 :end nil) ""))
553 (assert (equal (remove #\a string :start 0 :end 5) ""))
554 (assert (raises-error? (remove #\a string :start 0 :end 6)))
555 (assert (raises-error? (remove #\a string :start (opaque-identity -1) :end 5)))
556 (assert (raises-error? (remove #\a string :start 4 :end 2)))
557 (assert (raises-error? (remove #\a string :start 6 :end 9)))
558 (assert (equal (remove-if #'alpha-char-p string :start 0 :end nil) ""))
559 (assert (equal (remove-if #'alpha-char-p string :start 0 :end 5) ""))
560 (assert (raises-error?
561 (remove-if #'alpha-char-p string :start 0 :end 6)))
562 (assert (raises-error?
563 (remove-if #'alpha-char-p string :start (opaque-identity -1) :end 5)))
564 (assert (raises-error?
565 (remove-if #'alpha-char-p string :start 4 :end 2)))
566 (assert (raises-error?
567 (remove-if #'alpha-char-p string :start 6 :end 9)))
568 (assert (equal (remove-if-not #'alpha-char-p string :start 0 :end nil)
570 (assert (equal (remove-if-not #'alpha-char-p string :start 0 :end 5)
572 (assert (raises-error?
573 (remove-if-not #'alpha-char-p string :start 0 :end 6)))
574 (assert (raises-error?
575 (remove-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)))
576 (assert (raises-error?
577 (remove-if-not #'alpha-char-p string :start 4 :end 2)))
578 (assert (raises-error?
579 (remove-if-not #'alpha-char-p string :start 6 :end 9))))
580 (sequence-bounding-indices-test
581 (format t "~&/... DELETE, DELETE-IF, DELETE-IF-NOT")
582 (assert (equal (delete #\a string :start 0 :end nil) ""))
584 (assert (equal (delete #\a string :start 0 :end 5) ""))
586 (assert (raises-error? (delete #\a string :start 0 :end 6)))
588 (assert (raises-error? (delete #\a string :start (opaque-identity -1) :end 5)))
590 (assert (raises-error? (delete #\a string :start 4 :end 2)))
592 (assert (raises-error? (delete #\a string :start 6 :end 9)))
594 (assert (equal (delete-if #'alpha-char-p string :start 0 :end nil) ""))
596 (assert (equal (delete-if #'alpha-char-p string :start 0 :end 5) ""))
598 (assert (raises-error?
599 (delete-if #'alpha-char-p string :start 0 :end 6)))
601 (assert (raises-error?
602 (delete-if #'alpha-char-p string :start (opaque-identity -1) :end 5)))
604 (assert (raises-error?
605 (delete-if #'alpha-char-p string :start 4 :end 2)))
607 (assert (raises-error?
608 (delete-if #'alpha-char-p string :start 6 :end 9)))
610 (assert (equal (delete-if-not #'alpha-char-p string :start 0 :end nil)
613 (assert (equal (delete-if-not #'alpha-char-p string :start 0 :end 5)
616 (assert (raises-error?
617 (delete-if-not #'alpha-char-p string :start 0 :end 6)))
619 (assert (raises-error?
620 (delete-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)))
622 (assert (raises-error?
623 (delete-if-not #'alpha-char-p string :start 4 :end 2)))
625 (assert (raises-error?
626 (delete-if-not #'alpha-char-p string :start 6 :end 9))))
628 ;;; Function REMOVE-DUPLICATES, DELETE-DUPLICATES
629 (sequence-bounding-indices-test
630 (format t "~&/Function REMOVE-DUPLICATES, DELETE-DUPLICATES~%")
631 (assert (string= (remove-duplicates string :start 0 :end 5) "a"))
632 (assert (string= (remove-duplicates string :start 0 :end nil) "a"))
633 (assert (raises-error? (remove-duplicates string :start 0 :end 6)))
634 (assert (raises-error? (remove-duplicates string :start (opaque-identity -1) :end 5)))
635 (assert (raises-error? (remove-duplicates string :start 4 :end 2)))
636 (assert (raises-error? (remove-duplicates string :start 6 :end 9)))
637 (assert (string= (delete-duplicates string :start 0 :end 5) "a"))
639 (assert (string= (delete-duplicates string :start 0 :end nil) "a"))
641 (assert (raises-error? (delete-duplicates string :start 0 :end 6)))
643 (assert (raises-error? (delete-duplicates string :start (opaque-identity -1) :end 5)))
645 (assert (raises-error? (delete-duplicates string :start 4 :end 2)))
647 (assert (raises-error? (delete-duplicates string :start 6 :end 9))))
650 (sequence-bounding-indices-test
651 (format t "~&/Function REPLACE~%")
652 (assert (string= (replace string "bbbbb" :start1 0 :end1 5) "bbbbb"))
653 (assert (string= (replace (copy-seq "ccccc")
655 :start2 0 :end2 nil) "bbbbb"))
656 (assert (raises-error? (replace string "ccccc" :start1 0 :end1 6)))
657 (assert (raises-error? (replace string "ccccc" :start2 (opaque-identity -1) :end2 5)))
658 (assert (raises-error? (replace string "ccccc" :start1 4 :end1 2)))
659 (assert (raises-error? (replace string "ccccc" :start1 6 :end1 9))))
662 (sequence-bounding-indices-test
663 (format t "~&/Function SEARCH~%")
664 (assert (= (search "aa" string :start2 0 :end2 5) 0))
665 (assert (null (search string "aa" :start1 0 :end2 nil)))
666 (assert (raises-error? (search "aa" string :start2 0 :end2 6)))
667 (assert (raises-error? (search "aa" string :start2 (opaque-identity -1) :end2 5)))
668 (assert (raises-error? (search "aa" string :start2 4 :end2 2)))
669 (assert (raises-error? (search "aa" string :start2 6 :end2 9))))
671 ;;; Function STRING-UPCASE, STRING-DOWNCASE, STRING-CAPITALIZE,
672 ;;; NSTRING-UPCASE, NSTRING-DOWNCASE, NSTRING-CAPITALIZE
673 (defmacro string-case-frob (fn)
675 (assert (raises-error? (,fn string :start 0 :end 6)))
676 (assert (raises-error? (,fn string :start (opaque-identity -1) :end 5)))
677 (assert (raises-error? (,fn string :start 4 :end 2)))
678 (assert (raises-error? (,fn string :start 6 :end 9)))))
680 (sequence-bounding-indices-test
681 (format t "~&/Function STRING-UPCASE, STRING-DOWNCASE, STRING-CAPITALIZE, ...~%")
682 (string-case-frob string-upcase)
683 (string-case-frob string-downcase)
684 (string-case-frob string-capitalize)
685 (format t "~&/... NSTRING-UPCASE, NSTRING-DOWNCASE, NSTRING-CAPITALIZE~%")
686 (string-case-frob nstring-upcase)
687 (string-case-frob nstring-downcase)
688 (string-case-frob nstring-capitalize))
690 ;;; Function STRING=, STRING/=, STRING<, STRING>, STRING<=, STRING>=,
691 ;;; STRING-EQUAL, STRING-NOT-EQUAL, STRING-LESSP, STRING-GREATERP,
692 ;;; STRING-NOT-GREATERP, STRING-NOT-LESSP
693 (defmacro string-predicate-frob (fn)
695 (,fn string "abcde" :start1 0 :end1 5)
696 (,fn "fghij" string :start2 0 :end2 nil)
697 (assert (raises-error? (,fn string "klmno"
699 (assert (raises-error? (,fn "pqrst" string
700 :start2 (opaque-identity -1) :end2 5)))
701 (assert (raises-error? (,fn "uvwxy" string
703 (assert (raises-error? (,fn string "z" :start2 6 :end2 9)))))
704 (sequence-bounding-indices-test
705 (format t "~&/Function STRING=, STRING/=, STRING<, STRING>, STRING<=, STRING>=, ...")
706 (string-predicate-frob string=)
707 (string-predicate-frob string/=)
708 (string-predicate-frob string<)
709 (string-predicate-frob string>)
710 (string-predicate-frob string<=)
711 (string-predicate-frob string>=))
712 (sequence-bounding-indices-test
713 (format t "~&/... STRING-EQUAL, STRING-NOT-EQUAL, STRING-LESSP, ...~%")
714 (string-predicate-frob string-equal)
715 (string-predicate-frob string-not-equal)
716 (string-predicate-frob string-lessp))
717 (sequence-bounding-indices-test
718 (format t "~&/... STRING-GREATERP, STRING-NOT-GREATERP, STRING-NOT-LESSP~%")
719 (string-predicate-frob string-greaterp)
720 (string-predicate-frob string-not-greaterp)
721 (string-predicate-frob string-not-lessp))
723 ;;; Function SUBSTITUTE, SUBSTITUTE-IF, SUBSTITUTE-IF-NOT,
724 ;;; NSUBSTITUTE, NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT
725 (sequence-bounding-indices-test
726 (format t "~&/Function SUBSTITUTE, SUBSTITUTE-IF, SUBSTITUTE-IF-NOT, ...~%")
727 (assert (string= (substitute #\b #\a string :start 0 :end 5) "bbbbb"))
728 (assert (string= (substitute #\c #\a string :start 0 :end nil)
730 (assert (raises-error? (substitute #\b #\a string :start 0 :end 6)))
731 (assert (raises-error? (substitute #\b #\a string :start (opaque-identity -1) :end 5)))
732 (assert (raises-error? (substitute #\b #\a string :start 4 :end 2)))
733 (assert (raises-error? (substitute #\b #\a string :start 6 :end 9)))
734 (assert (string= (substitute-if #\b #'alpha-char-p string
737 (assert (string= (substitute-if #\c #'alpha-char-p string
740 (assert (raises-error? (substitute-if #\b #'alpha-char-p string
742 (assert (raises-error? (substitute-if #\b #'alpha-char-p string
743 :start (opaque-identity -1) :end 5)))
744 (assert (raises-error? (substitute-if #\b #'alpha-char-p string
746 (assert (raises-error? (substitute-if #\b #'alpha-char-p string
748 (assert (string= (substitute-if-not #\b #'alpha-char-p string
751 (assert (string= (substitute-if-not #\c #'alpha-char-p string
754 (assert (raises-error? (substitute-if-not #\b #'alpha-char-p string
756 (assert (raises-error? (substitute-if-not #\b #'alpha-char-p string
757 :start (opaque-identity -1) :end 5)))
758 (assert (raises-error? (substitute-if-not #\b #'alpha-char-p string
760 (assert (raises-error? (substitute-if-not #\b #'alpha-char-p string
762 (sequence-bounding-indices-test
763 (format t "~&/... NSUBSTITUTE, NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT~%")
764 (assert (string= (nsubstitute #\b #\a string :start 0 :end 5) "bbbbb"))
766 (assert (string= (nsubstitute #\c #\a string :start 0 :end nil)
769 (assert (raises-error? (nsubstitute #\b #\a string :start 0 :end 6)))
771 (assert (raises-error? (nsubstitute #\b #\a string :start (opaque-identity -1) :end 5)))
773 (assert (raises-error? (nsubstitute #\b #\a string :start 4 :end 2)))
775 (assert (raises-error? (nsubstitute #\b #\a string :start 6 :end 9)))
777 (assert (string= (nsubstitute-if #\b #'alpha-char-p string
781 (assert (string= (nsubstitute-if #\c #'alpha-char-p string
785 (assert (raises-error? (nsubstitute-if #\b #'alpha-char-p string
788 (assert (raises-error? (nsubstitute-if #\b #'alpha-char-p string
789 :start (opaque-identity -1) :end 5)))
791 (assert (raises-error? (nsubstitute-if #\b #'alpha-char-p string
794 (assert (raises-error? (nsubstitute-if #\b #'alpha-char-p string
797 (assert (string= (nsubstitute-if-not #\b #'alpha-char-p string
801 (assert (string= (nsubstitute-if-not #\c #'alpha-char-p string
805 (assert (raises-error? (nsubstitute-if-not #\b #'alpha-char-p string
808 (assert (raises-error? (nsubstitute-if-not #\b #'alpha-char-p string
809 :start (opaque-identity -1) :end 5)))
811 (assert (raises-error? (nsubstitute-if-not #\b #'alpha-char-p string
814 (assert (raises-error? (nsubstitute-if-not #\b #'alpha-char-p string
816 ;;; Function WRITE-STRING, WRITE-LINE
817 (sequence-bounding-indices-test
818 (format t "~&/Function WRITE-STRING, WRITE-LINE~%")
819 (write-string string *standard-output* :start 0 :end 5)
820 (write-string string *standard-output* :start 0 :end nil)
821 (assert (raises-error? (write-string string *standard-output*
823 (assert (raises-error? (write-string string *standard-output*
824 :start (opaque-identity -1) :end 5)))
825 (assert (raises-error? (write-string string *standard-output*
827 (assert (raises-error? (write-string string *standard-output*
829 (write-line string *standard-output* :start 0 :end 5)
830 (write-line string *standard-output* :start 0 :end nil)
831 (assert (raises-error? (write-line string *standard-output*
833 (assert (raises-error? (write-line string *standard-output*
834 :start (opaque-identity -1) :end 5)))
835 (assert (raises-error? (write-line string *standard-output*
837 (assert (raises-error? (write-line string *standard-output*
840 ;;; Macro WITH-INPUT-FROM-STRING
841 (sequence-bounding-indices-test
842 (format t "~&/Macro WITH-INPUT-FROM-STRING~%")
843 (with-input-from-string (s string :start 0 :end 5)
844 (assert (char= (read-char s) #\a)))
845 (with-input-from-string (s string :start 0 :end nil)
846 (assert (char= (read-char s) #\a)))
847 (assert (raises-error?
848 (with-input-from-string (s string :start 0 :end 6)
850 (assert (raises-error?
851 (with-input-from-string (s string :start (opaque-identity -1) :end 5)
853 (assert (raises-error?
854 (with-input-from-string (s string :start 4 :end 2)
856 (assert (raises-error?
857 (with-input-from-string (s string :start 6 :end 9)
861 (quit :unix-status 104)