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.
16 (load "assertoid.lisp")
19 (:use :cl :assertoid))
21 (in-package :seq-test)
23 ;;; helper functions for exercising SEQUENCE code on data of many
24 ;;; specialized types, and in many different optimization scenarios
25 (defun for-every-seq-1 (base-seq snippet)
26 (dolist (seq-type '(list
29 (simple-array character 1)
31 (simple-array (signed-byte 4) 1)
32 (vector (signed-byte 4))))
33 (flet ((entirely (eltype)
34 (every (lambda (el) (typep el eltype)) base-seq)))
35 (dolist (declaredness '(nil t))
36 (dolist (optimization '(((speed 3) (space 0))
39 ((speed 0) (space 1))))
40 (let* ((seq (if (eq seq-type 'list)
41 (coerce base-seq 'list)
42 (destructuring-bind (type-first &rest type-rest)
46 (destructuring-bind (eltype one) type-rest
49 (coerce base-seq seq-type)
52 (destructuring-bind (eltype) type-rest
54 (let ((initial-element
55 (cond ((subtypep eltype 'character)
57 ((subtypep eltype 'number)
70 (lambda-expr `(lambda (seq)
72 `((declare (type ,seq-type seq))))
73 (declare (optimize ,@optimization))
75 (format t "~&~S~%" lambda-expr)
76 (multiple-value-bind (fun warnings-p failure-p)
77 (compile nil lambda-expr)
78 (when (or warnings-p failure-p)
79 (error "~@<failed compilation:~2I ~_LAMBDA-EXPR=~S ~_WARNINGS-P=~S ~_FAILURE-P=~S~:@>"
80 lambda-expr warnings-p failure-p))
81 (format t "~&~S ~S~%~S~%~S ~S~%"
82 base-seq snippet seq-type declaredness optimization)
83 (format t "~&(TYPEP SEQ 'SIMPLE-ARRAY)=~S~%"
84 (typep seq 'simple-array))
85 (unless (funcall fun seq)
86 (error "~@<failed test:~2I ~_BASE-SEQ=~S ~_SNIPPET=~S ~_SEQ-TYPE=~S ~_DECLAREDNESS=~S ~_OPTIMIZATION=~S~:@>"
92 (defun for-every-seq (base-seq snippets)
93 (dolist (snippet snippets)
94 (for-every-seq-1 base-seq snippet)))
96 ;;; a wrapper to hide declared type information from the compiler, so
97 ;;; we don't get stopped by compiler warnings about e.g. compiling
98 ;;; (POSITION 1 #() :KEY #'ABS) when #() has been coerced to a string.
99 (defun indiscriminate (fun)
100 (lambda (&rest rest) (apply fun rest)))
102 ;;; asymmetric test arg order example from ANSI FIND definition page
103 (assert (eql #\space ; original example, depends on ASCII character ordering
104 (find #\d "here are some letters that can be looked at"
106 (assert (eql #\e ; modified example, depends only on standard a-z ordering
107 (find #\f "herearesomeletters" :test #'char>)))
108 (assert (eql 4 ; modified more, avoids charset technicalities completely
109 (find 5 '(6 4) :test '>)))
111 ;;; tests of FIND, POSITION, FIND-IF, and POSITION-IF (and a few for
112 ;;; deprecated FIND-IF-NOT and POSITION-IF-NOT too)
114 '((null (find 1 seq))
115 (null (find 1 seq :from-end t))
116 (null (position 1 seq :key (indiscriminate #'abs)))
117 (null (position nil seq :test (constantly t)))
118 (null (position nil seq :test nil))
119 (null (position nil seq :test-not nil))
120 (null (find-if #'1+ seq :key (indiscriminate #'log)))
121 (null (position-if #'identity seq :from-end t))
122 (null (find-if-not #'packagep seq))
123 (null (position-if-not #'packagep seq :key nil))))
125 '((null (find 2 seq))
126 ;; Get the argument ordering for asymmetric tests like #'> right.
127 ;; (bug reported and fixed by Alexey Dejneka sbcl-devel 2001-10-17)
128 (eql 1 (find 2 seq :test #'>))
129 (find 2 seq :key #'1+)
130 (find 1 seq :from-end t)
131 (null (find 1 seq :from-end t :start 1))
132 (null (find 0 seq :from-end t))
133 (eql 0 (position 1 seq :key #'abs))
134 (null (position nil seq :test 'equal))
135 (eql 1 (find-if #'1- seq :key #'log))
136 (eql 0 (position-if #'identity seq :from-end t))
137 (null (find-if-not #'sin seq))
138 (eql 0 (position-if-not #'packagep seq :key 'identity))))
139 (for-every-seq #(1 2 3 2 1)
141 (find 3 seq :from-end 'yes)
142 (eql 1 (position 1.5 seq :test #'<))
143 (eql 0 (position 0 seq :key '1-))
144 (eql 4 (position 0 seq :key '1- :from-end t))
145 (eql 2 (position 4 seq :key '1+))
146 (eql 2 (position 4 seq :key '1+ :from-end t))
147 (eql 1 (position 2 seq))
148 (eql 1 (position 2 seq :start 1))
149 (null (find 2 seq :start 1 :end 1))
150 (eql 3 (position 2 seq :start 2))
151 (eql 3 (position 2 seq :key nil :from-end t))
152 (eql 2 (position 3 seq :test '=))
153 (eql 0 (position 3 seq :test-not 'equalp))
154 (eql 2 (position 3 seq :test 'equal :from-end t))
155 (null (position 4 seq :test #'eql))
156 (null (find-if #'packagep seq))
157 (eql 1 (find-if #'plusp seq))
158 (eql 3 (position-if #'plusp seq :key #'1- :from-end t))
159 (eql 1 (position-if #'evenp seq))
160 (eql 3 (position-if #'evenp seq :from-end t))
161 (eql 2 (position-if #'plusp seq :from-end nil :key '1- :start 2))
162 (eql 3 (position-if #'plusp seq :from-end t :key '1- :start 2))
163 (null (position-if #'plusp seq :from-end t :key '1- :start 2 :end 2))
164 (null (find-if-not #'plusp seq))
165 (eql 0 (position-if-not #'evenp seq))))
166 (for-every-seq "string test"
167 '((null (find 0 seq))
168 (null (find #\D seq :key #'char-upcase))
169 (find #\E seq :key #'char-upcase)
170 (null (find #\e seq :key #'char-upcase))
171 (eql 3 (position #\i seq))
172 (eql 0 (position #\s seq :key #'char-downcase))
173 (eql 1 (position #\s seq :key #'char-downcase :test #'char/=))
174 (eql 9 (position #\s seq :from-end t :test #'char=))
175 (eql 10 (position #\s seq :from-end t :test #'char/=))
176 (eql 4 (position #\N seq :from-end t :key 'char-upcase :test #'char-equal))
177 (eql 5 (position-if (lambda (c) (equal #\g c)) seq))
178 (eql 5 (position-if (lambda (c) (equal #\g c)) seq :from-end t))
179 (find-if #'characterp seq)
180 (find-if (lambda (c) (typep c 'base-char)) seq :from-end t)
181 (null (find-if 'upper-case-p seq))))
184 (let ((avec (make-array 10
186 :initial-contents '(0 1 2 3 iv v vi vii iix ix))))
187 ;; These first five always worked AFAIK.
188 (assert (equalp (subseq avec 0 3) #(0 1 2)))
189 (assert (equalp (subseq avec 3 3) #()))
190 (assert (equalp (subseq avec 1 3) #(1 2)))
191 (assert (equalp (subseq avec 1) #(1 2 3)))
192 (assert (equalp (subseq avec 1 4) #(1 2 3)))
193 ;; SBCL bug found ca. 2002-05-01 by OpenMCL's correct handling of
194 ;; SUBSEQ, CSR's driving portable cross-compilation far enough to
195 ;; reach the SUBSEQ calls in assem.lisp, and WHN's sleazy
196 ;; translation of old CMU CL new-assem.lisp into sufficiently grotty
197 ;; portable Lisp that it passed suitable illegal values to SUBSEQ to
198 ;; exercise the bug:-|
200 ;; SUBSEQ should check its END value against logical LENGTH, not
201 ;; physical ARRAY-DIMENSION 0.
203 ;; fixed in sbcl-0.7.4.22 by WHN
204 (assert (null (ignore-errors (aref (subseq avec 1 5) 0)))))
207 (defun test-fill-typecheck (x)
208 (declare (optimize (safety 3) (space 2) (speed 1)))
209 (fill (make-string 10) x))
211 (assert (string= (test-fill-typecheck #\@) "@@@@@@@@@@"))
212 ;;; BUG 186, fixed in sbcl-0.7.5.5
213 (assert (null (ignore-errors (test-fill-typecheck 4097))))
215 ;;; MAKE-SEQUENCE, COERCE, CONCATENATE, MERGE, MAP and requested
216 ;;; result type (BUGs 46a, 46b, 66)
217 (macrolet ((assert-type-error (form)
218 `(assert (typep (nth-value 1 (ignore-errors ,form))
220 (dolist (type-stub '((simple-vector)
222 (vector (signed-byte 8))
223 (vector (unsigned-byte 16))
224 (vector (signed-byte 32))
225 (simple-bit-vector)))
226 (declare (optimize safety))
227 (format t "~&~S~%" type-stub)
229 (assert (= (length (make-sequence `(,@type-stub) 10)) 10))
230 (assert (= (length (make-sequence `(,@type-stub 10) 10)) 10))
231 (assert-type-error (make-sequence `(,@type-stub 10) 11))
233 (assert (= (length (coerce '(0 0 0) `(,@type-stub))) 3))
234 (assert (= (length (coerce #(0 0 0) `(,@type-stub 3))) 3))
235 (assert-type-error (coerce #*111 `(,@type-stub 4)))
237 (assert (= (length (concatenate `(,@type-stub) #(0 0 0) #*111)) 6))
238 (assert (equalp (concatenate `(,@type-stub) #(0 0 0) #*111)
239 (coerce #(0 0 0 1 1 1) `(,@type-stub))))
240 (assert (= (length (concatenate `(,@type-stub 6) #(0 0 0) #*111)) 6))
241 (assert (equalp (concatenate `(,@type-stub 6) #(0 0 0) #*111)
242 (coerce #(0 0 0 1 1 1) `(,@type-stub 6))))
243 (assert-type-error (concatenate `(,@type-stub 5) #(0 0 0) #*111))
245 (assert (= (length (merge `(,@type-stub) #(0 1 0) #*111 #'>)) 6))
246 (assert (equalp (merge `(,@type-stub) #(0 1 0) #*111 #'>)
247 (coerce #(1 1 1 0 1 0) `(,@type-stub))))
248 (assert (= (length (merge `(,@type-stub 6) #(0 1 0) #*111 #'>)) 6))
249 (assert (equalp (merge `(,@type-stub 6) #(0 1 0) #*111 #'>)
250 (coerce #(1 1 1 0 1 0) `(,@type-stub 6))))
251 (assert-type-error (merge `(,@type-stub 4) #(0 1 0) #*111 #'>))
253 (assert (= (length (map `(,@type-stub) #'logxor #(0 0 1 1) '(0 1 0 1))) 4))
254 (assert (equalp (map `(,@type-stub) #'logxor #(0 0 1 1) '(0 1 0 1))
255 (coerce #(0 1 1 0) `(,@type-stub))))
256 (assert (= (length (map `(,@type-stub 4) #'logxor #(0 0 1 1) '(0 1 0 1)))
258 (assert (equalp (map `(,@type-stub 4) #'logxor #(0 0 1 1) '(0 1 0 1))
259 (coerce #(0 1 1 0) `(,@type-stub 4))))
260 (assert-type-error (map `(,@type-stub 5) #'logxor #(0 0 1 1) '(0 1 0 1))))
261 ;; some more CONCATENATE tests for strings
263 (declare (optimize safety))
264 (assert (string= (concatenate 'string "foo" " " "bar") "foo bar"))
265 (assert (string= (concatenate '(string 7) "foo" " " "bar") "foo bar"))
266 (assert-type-error (concatenate '(string 6) "foo" " " "bar"))
267 (assert (string= (concatenate '(string 6) "foo" #(#\b #\a #\r)) "foobar"))
268 (assert-type-error (concatenate '(string 7) "foo" #(#\b #\a #\r))))
269 ;; Non-VECTOR ARRAY types aren't allowed as vector type specifiers.
271 (declare (optimize safety))
272 (assert-type-error (concatenate 'simple-array "foo" "bar"))
273 (assert-type-error (map 'simple-array #'identity '(1 2 3)))
274 (assert (equalp #(11 13)
275 (map '(simple-array fixnum (*)) #'+ '(1 2 3) '(10 11))))
276 (assert-type-error (coerce '(1 2 3) 'simple-array))
277 (assert-type-error (merge 'simple-array '(1 3) '(2 4) '<))
278 (assert (equalp #(3 2 1) (coerce '(3 2 1) '(vector fixnum))))
279 (assert-type-error (map 'array #'identity '(1 2 3)))
280 (assert-type-error (map '(array fixnum) #'identity '(1 2 3)))
281 (assert (equalp #(1 2 3) (coerce '(1 2 3) '(vector fixnum))))
282 ;; but COERCE has an exemption clause:
283 (assert (string= "foo" (coerce "foo" 'simple-array)))
284 ;; ... though not in all cases.
285 (assert-type-error (coerce '(#\f #\o #\o) 'simple-array))))
287 ;;; As pointed out by Raymond Toy on #lisp IRC, MERGE had some issues
288 ;;; with user-defined types until sbcl-0.7.8.11
289 (deftype list-typeoid () 'list)
290 (assert (equal '(1 2 3 4) (merge 'list-typeoid '(1 3) '(2 4) '<)))
291 ;;; and also with types that weren't precicely LIST
292 (assert (equal '(1 2 3 4) (merge 'cons '(1 3) '(2 4) '<)))
294 ;;; but wait, there's more! The NULL and CONS types also have implicit
295 ;;; length requirements:
296 (macrolet ((assert-type-error (form)
297 `(assert (typep (nth-value 1 (ignore-errors ,form))
300 (declare (optimize safety))
302 (assert-type-error (make-sequence 'cons 0))
303 (assert-type-error (make-sequence 'null 1))
304 (assert-type-error (make-sequence '(cons t null) 0))
305 (assert-type-error (make-sequence '(cons t null) 2))
306 ;; KLUDGE: I'm not certain that this test actually tests for what
307 ;; it should test, in that the type deriver and optimizers might
308 ;; be too smart for the good of an exhaustive test system.
309 ;; However, it makes me feel good. -- CSR, 2002-10-18
310 (assert (null (make-sequence 'null 0)))
311 (assert (= (length (make-sequence 'cons 3)) 3))
312 (assert (= (length (make-sequence '(cons t null) 1)) 1))
313 ;; and NIL is not a valid type for MAKE-SEQUENCE
314 (assert-type-error (make-sequence 'nil 0))
316 (assert-type-error (coerce #(1) 'null))
317 (assert-type-error (coerce #() 'cons))
318 (assert-type-error (coerce #() '(cons t null)))
319 (assert-type-error (coerce #(1 2) '(cons t null)))
320 (assert (null (coerce #() 'null)))
321 (assert (= (length (coerce #(1) 'cons)) 1))
322 (assert (= (length (coerce #(1) '(cons t null))) 1))
323 (assert-type-error (coerce #() 'nil))
325 (assert-type-error (merge 'null '(1 3) '(2 4) '<))
326 (assert-type-error (merge 'cons () () '<))
327 (assert (null (merge 'null () () '<)))
328 (assert (= (length (merge 'cons '(1 3) '(2 4) '<)) 4))
329 (assert (= (length (merge '(cons t (cons t (cons t (cons t null))))
330 '(1 3) '(2 4) '<)) 4))
331 (assert-type-error (merge 'nil () () '<))
333 (assert-type-error (concatenate 'null '(1) "2"))
334 (assert-type-error (concatenate 'cons #() ()))
335 (assert-type-error (concatenate '(cons t null) #(1 2 3) #(4 5 6)))
336 (assert (null (concatenate 'null () #())))
337 (assert (= (length (concatenate 'cons #() '(1) "2 3")) 4))
338 (assert (= (length (concatenate '(cons t cons) '(1) "34")) 3))
339 (assert-type-error (concatenate 'nil '(3)))
340 ;; FIXME: tests for MAP to come when some brave soul implements
341 ;; the analogous type checking for MAP/%MAP.
344 ;;; ELT should signal an error of type TYPE-ERROR if its index
345 ;;; argument isn't a valid sequence index for sequence:
346 (defun test-elt-signal (x)
348 (assert (raises-error? (test-elt-signal "foo") type-error))
349 (assert (eql (test-elt-signal "foob") #\b))
351 (declare (optimize (safety 3)))
352 (assert (raises-error? (elt (list 1 2 3) 3) type-error)))
354 ;;; confusion in the refactoring led to this signalling an unbound
355 ;;; variable, not a type error.
356 (defun svrefalike (x)
358 (assert (raises-error? (svrefalike #*0) type-error))
360 ;;; checks for uniform bounding index handling under SAFETY 3 code.
362 ;;; KLUDGE: not all in one big form because that causes SBCL to spend
363 ;;; an absolute age trying to compile it.
364 (defmacro sequence-bounding-indices-test (&body body)
366 ;; See Issues 332 [and 333(!)] in the CLHS
367 (declare (optimize (safety 3)))
368 (let ((string (make-array 10
371 :element-type 'base-char)))
373 (setf (fill-pointer string) 10)
375 (setf (fill-pointer string) 5)))
376 (declare (ignorable #'reset))
378 (declaim (notinline opaque-identity))
379 (defun opaque-identity (x) x)
381 (sequence-bounding-indices-test
382 (format t "~&/Accessor SUBSEQ~%")
383 (assert (string= (subseq string 0 5) "aaaaa"))
384 (assert (raises-error? (subseq string 0 6)))
385 (assert (raises-error? (subseq string (opaque-identity -1) 5)))
386 (assert (raises-error? (subseq string 4 2)))
387 (assert (raises-error? (subseq string 6)))
388 (assert (string= (setf (subseq string 0 5) "abcde") "abcde"))
389 (assert (string= (subseq string 0 5) "abcde"))
391 (assert (raises-error? (setf (subseq string 0 6) "abcdef")))
392 (assert (raises-error? (setf (subseq string (opaque-identity -1) 5) "abcdef")))
393 (assert (raises-error? (setf (subseq string 4 2) "")))
394 (assert (raises-error? (setf (subseq string 6) "ghij"))))
396 ;;; Function COUNT, COUNT-IF, COUNT-IF-NOT
397 (sequence-bounding-indices-test
398 (format t "~&/Function COUNT, COUNT-IF, COUNT-IF-NOT")
399 (assert (= (count #\a string :start 0 :end nil) 5))
400 (assert (= (count #\a string :start 0 :end 5) 5))
401 (assert (raises-error? (count #\a string :start 0 :end 6)))
402 (assert (raises-error? (count #\a string :start (opaque-identity -1) :end 5)))
403 (assert (raises-error? (count #\a string :start 4 :end 2)))
404 (assert (raises-error? (count #\a string :start 6 :end 9)))
405 (assert (= (count-if #'alpha-char-p string :start 0 :end nil) 5))
406 (assert (= (count-if #'alpha-char-p string :start 0 :end 5) 5))
407 (assert (raises-error?
408 (count-if #'alpha-char-p string :start 0 :end 6)))
409 (assert (raises-error?
410 (count-if #'alpha-char-p string :start (opaque-identity -1) :end 5)))
411 (assert (raises-error?
412 (count-if #'alpha-char-p string :start 4 :end 2)))
413 (assert (raises-error?
414 (count-if #'alpha-char-p string :start 6 :end 9)))
415 (assert (= (count-if-not #'alpha-char-p string :start 0 :end nil) 0))
416 (assert (= (count-if-not #'alpha-char-p string :start 0 :end 5) 0))
417 (assert (raises-error?
418 (count-if-not #'alpha-char-p string :start 0 :end 6)))
419 (assert (raises-error?
420 (count-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)))
421 (assert (raises-error?
422 (count-if-not #'alpha-char-p string :start 4 :end 2)))
423 (assert (raises-error?
424 (count-if-not #'alpha-char-p string :start 6 :end 9))))
427 (sequence-bounding-indices-test
428 (format t "~&/Function FILL~%")
429 (assert (string= (fill string #\b :start 0 :end 5) "bbbbb"))
430 (assert (string= (fill string #\c :start 0 :end nil) "ccccc"))
431 (assert (raises-error? (fill string #\d :start 0 :end 6)))
432 (assert (raises-error? (fill string #\d :start (opaque-identity -1) :end 5)))
433 (assert (raises-error? (fill string #\d :start 4 :end 2)))
434 (assert (raises-error? (fill string #\d :start 6 :end 9))))
436 ;;; Function FIND, FIND-IF, FIND-IF-NOT
437 (sequence-bounding-indices-test
438 (format t "~&/Function FIND, FIND-IF, FIND-IF-NOT~%")
439 (assert (char= (find #\a string :start 0 :end nil) #\a))
440 (assert (char= (find #\a string :start 0 :end 5) #\a))
441 (assert (raises-error? (find #\a string :start 0 :end 6)))
442 (assert (raises-error? (find #\a string :start (opaque-identity -1) :end 5)))
443 (assert (raises-error? (find #\a string :start 4 :end 2)))
444 (assert (raises-error? (find #\a string :start 6 :end 9)))
445 (assert (char= (find-if #'alpha-char-p string :start 0 :end nil) #\a))
446 (assert (char= (find-if #'alpha-char-p string :start 0 :end 5) #\a))
447 (assert (raises-error?
448 (find-if #'alpha-char-p string :start 0 :end 6)))
449 (assert (raises-error?
450 (find-if #'alpha-char-p string :start (opaque-identity -1) :end 5)))
451 (assert (raises-error?
452 (find-if #'alpha-char-p string :start 4 :end 2)))
453 (assert (raises-error?
454 (find-if #'alpha-char-p string :start 6 :end 9)))
455 (assert (eq (find-if-not #'alpha-char-p string :start 0 :end nil) nil))
456 (assert (eq (find-if-not #'alpha-char-p string :start 0 :end 5) nil))
457 (assert (raises-error?
458 (find-if-not #'alpha-char-p string :start 0 :end 6)))
459 (assert (raises-error?
460 (find-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)))
461 (assert (raises-error?
462 (find-if-not #'alpha-char-p string :start 4 :end 2)))
463 (assert (raises-error?
464 (find-if-not #'alpha-char-p string :start 6 :end 9))))
466 ;;; Function MISMATCH
467 (sequence-bounding-indices-test
468 (format t "~&/Function MISMATCH~%")
469 (assert (null (mismatch string "aaaaa" :start1 0 :end1 nil)))
470 (assert (= (mismatch "aaab" string :start2 0 :end2 4) 3))
471 (assert (raises-error? (mismatch "aaaaaa" string :start2 0 :end2 6)))
472 (assert (raises-error? (mismatch string "aaaaaa" :start1 (opaque-identity -1) :end1 5)))
473 (assert (raises-error? (mismatch string "" :start1 4 :end1 2)))
474 (assert (raises-error? (mismatch "aaaa" string :start2 6 :end2 9))))
476 ;;; Function PARSE-INTEGER
477 (sequence-bounding-indices-test
478 (format t "~&/Function PARSE-INTEGER~%")
479 (setf (fill-pointer string) 10)
480 (setf (subseq string 0 10) "1234567890")
481 (setf (fill-pointer string) 5)
482 (assert (= (parse-integer string :start 0 :end 5) 12345))
483 (assert (= (parse-integer string :start 0 :end nil) 12345))
484 (assert (raises-error? (parse-integer string :start 0 :end 6)))
485 (assert (raises-error? (parse-integer string :start (opaque-identity -1) :end 5)))
486 (assert (raises-error? (parse-integer string :start 4 :end 2)))
487 (assert (raises-error? (parse-integer string :start 6 :end 9))))
489 ;;; Function PARSE-NAMESTRING
490 (sequence-bounding-indices-test
491 (format t "~&/Function PARSE-NAMESTRING~%")
492 (setf (fill-pointer string) 10)
493 (setf (subseq string 0 10) "/dev/ /tmp")
494 (setf (fill-pointer string) 5)
495 (assert (truename (parse-namestring string nil *default-pathname-defaults*
497 (assert (truename (parse-namestring string nil *default-pathname-defaults*
499 (assert (raises-error? (parse-namestring string nil
500 *default-pathname-defaults*
502 (assert (raises-error? (parse-namestring string nil
503 *default-pathname-defaults*
504 :start (opaque-identity -1) :end 5)))
505 (assert (raises-error? (parse-namestring string nil
506 *default-pathname-defaults*
508 (assert (raises-error? (parse-namestring string nil
509 *default-pathname-defaults*
512 ;;; Function POSITION, POSITION-IF, POSITION-IF-NOT
513 (sequence-bounding-indices-test
514 (format t "~&/Function POSITION, POSITION-IF, POSITION-IF-NOT~%")
515 (assert (= (position #\a string :start 0 :end nil) 0))
516 (assert (= (position #\a string :start 0 :end 5) 0))
517 (assert (raises-error? (position #\a string :start 0 :end 6)))
518 (assert (raises-error? (position #\a string :start (opaque-identity -1) :end 5)))
519 (assert (raises-error? (position #\a string :start 4 :end 2)))
520 (assert (raises-error? (position #\a string :start 6 :end 9)))
521 (assert (= (position-if #'alpha-char-p string :start 0 :end nil) 0))
522 (assert (= (position-if #'alpha-char-p string :start 0 :end 5) 0))
523 (assert (raises-error?
524 (position-if #'alpha-char-p string :start 0 :end 6)))
525 (assert (raises-error?
526 (position-if #'alpha-char-p string :start (opaque-identity -1) :end 5)))
527 (assert (raises-error?
528 (position-if #'alpha-char-p string :start 4 :end 2)))
529 (assert (raises-error?
530 (position-if #'alpha-char-p string :start 6 :end 9)))
531 (assert (eq (position-if-not #'alpha-char-p string :start 0 :end nil) nil))
532 (assert (eq (position-if-not #'alpha-char-p string :start 0 :end 5) nil))
533 (assert (raises-error?
534 (position-if-not #'alpha-char-p string :start 0 :end 6)))
535 (assert (raises-error?
536 (position-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)))
537 (assert (raises-error?
538 (position-if-not #'alpha-char-p string :start 4 :end 2)))
539 (assert (raises-error?
540 (position-if-not #'alpha-char-p string :start 6 :end 9))))
542 ;;; Function READ-FROM-STRING
543 (sequence-bounding-indices-test
544 (format t "~&/Function READ-FROM-STRING~%")
545 (setf (subseq string 0 5) "(a b)")
546 (assert (equal (read-from-string string nil nil :start 0 :end 5) '(a b)))
547 (assert (equal (read-from-string string nil nil :start 0 :end nil) '(a b)))
548 (assert (raises-error? (read-from-string string nil nil :start 0 :end 6)))
549 (assert (raises-error? (read-from-string string nil nil :start (opaque-identity -1) :end 5)))
550 (assert (raises-error? (read-from-string string nil nil :start 4 :end 2)))
551 (assert (raises-error? (read-from-string string nil nil :start 6 :end 9))))
554 (sequence-bounding-indices-test
555 (format t "~&/Function REDUCE~%")
556 (setf (subseq string 0 5) "abcde")
557 (assert (equal (reduce #'list* string :from-end t :start 0 :end nil)
558 '(#\a #\b #\c #\d . #\e)))
559 (assert (equal (reduce #'list* string :from-end t :start 0 :end 5)
560 '(#\a #\b #\c #\d . #\e)))
561 (assert (raises-error? (reduce #'list* string :start 0 :end 6)))
562 (assert (raises-error? (reduce #'list* string :start (opaque-identity -1) :end 5)))
563 (assert (raises-error? (reduce #'list* string :start 4 :end 2)))
564 (assert (raises-error? (reduce #'list* string :start 6 :end 9))))
566 ;;; Function REMOVE, REMOVE-IF, REMOVE-IF-NOT, DELETE, DELETE-IF,
568 (sequence-bounding-indices-test
569 (format t "~&/Function REMOVE, REMOVE-IF, REMOVE-IF-NOT, ...~%")
570 (assert (equal (remove #\a string :start 0 :end nil) ""))
571 (assert (equal (remove #\a string :start 0 :end 5) ""))
572 (assert (raises-error? (remove #\a string :start 0 :end 6)))
573 (assert (raises-error? (remove #\a string :start (opaque-identity -1) :end 5)))
574 (assert (raises-error? (remove #\a string :start 4 :end 2)))
575 (assert (raises-error? (remove #\a string :start 6 :end 9)))
576 (assert (equal (remove-if #'alpha-char-p string :start 0 :end nil) ""))
577 (assert (equal (remove-if #'alpha-char-p string :start 0 :end 5) ""))
578 (assert (raises-error?
579 (remove-if #'alpha-char-p string :start 0 :end 6)))
580 (assert (raises-error?
581 (remove-if #'alpha-char-p string :start (opaque-identity -1) :end 5)))
582 (assert (raises-error?
583 (remove-if #'alpha-char-p string :start 4 :end 2)))
584 (assert (raises-error?
585 (remove-if #'alpha-char-p string :start 6 :end 9)))
586 (assert (equal (remove-if-not #'alpha-char-p string :start 0 :end nil)
588 (assert (equal (remove-if-not #'alpha-char-p string :start 0 :end 5)
590 (assert (raises-error?
591 (remove-if-not #'alpha-char-p string :start 0 :end 6)))
592 (assert (raises-error?
593 (remove-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)))
594 (assert (raises-error?
595 (remove-if-not #'alpha-char-p string :start 4 :end 2)))
596 (assert (raises-error?
597 (remove-if-not #'alpha-char-p string :start 6 :end 9))))
598 (sequence-bounding-indices-test
599 (format t "~&/... DELETE, DELETE-IF, DELETE-IF-NOT")
600 (assert (equal (delete #\a string :start 0 :end nil) ""))
602 (assert (equal (delete #\a string :start 0 :end 5) ""))
604 (assert (raises-error? (delete #\a string :start 0 :end 6)))
606 (assert (raises-error? (delete #\a string :start (opaque-identity -1) :end 5)))
608 (assert (raises-error? (delete #\a string :start 4 :end 2)))
610 (assert (raises-error? (delete #\a string :start 6 :end 9)))
612 (assert (equal (delete-if #'alpha-char-p string :start 0 :end nil) ""))
614 (assert (equal (delete-if #'alpha-char-p string :start 0 :end 5) ""))
616 (assert (raises-error?
617 (delete-if #'alpha-char-p string :start 0 :end 6)))
619 (assert (raises-error?
620 (delete-if #'alpha-char-p string :start (opaque-identity -1) :end 5)))
622 (assert (raises-error?
623 (delete-if #'alpha-char-p string :start 4 :end 2)))
625 (assert (raises-error?
626 (delete-if #'alpha-char-p string :start 6 :end 9)))
628 (assert (equal (delete-if-not #'alpha-char-p string :start 0 :end nil)
631 (assert (equal (delete-if-not #'alpha-char-p string :start 0 :end 5)
634 (assert (raises-error?
635 (delete-if-not #'alpha-char-p string :start 0 :end 6)))
637 (assert (raises-error?
638 (delete-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5)))
640 (assert (raises-error?
641 (delete-if-not #'alpha-char-p string :start 4 :end 2)))
643 (assert (raises-error?
644 (delete-if-not #'alpha-char-p string :start 6 :end 9))))
646 ;;; Function REMOVE-DUPLICATES, DELETE-DUPLICATES
647 (sequence-bounding-indices-test
648 (format t "~&/Function REMOVE-DUPLICATES, DELETE-DUPLICATES~%")
649 (assert (string= (remove-duplicates string :start 0 :end 5) "a"))
650 (assert (string= (remove-duplicates string :start 0 :end nil) "a"))
651 (assert (raises-error? (remove-duplicates string :start 0 :end 6)))
652 (assert (raises-error? (remove-duplicates string :start (opaque-identity -1) :end 5)))
653 (assert (raises-error? (remove-duplicates string :start 4 :end 2)))
654 (assert (raises-error? (remove-duplicates string :start 6 :end 9)))
655 (assert (string= (delete-duplicates string :start 0 :end 5) "a"))
657 (assert (string= (delete-duplicates string :start 0 :end nil) "a"))
659 (assert (raises-error? (delete-duplicates string :start 0 :end 6)))
661 (assert (raises-error? (delete-duplicates string :start (opaque-identity -1) :end 5)))
663 (assert (raises-error? (delete-duplicates string :start 4 :end 2)))
665 (assert (raises-error? (delete-duplicates string :start 6 :end 9))))
668 (sequence-bounding-indices-test
669 (format t "~&/Function REPLACE~%")
670 (assert (string= (replace string "bbbbb" :start1 0 :end1 5) "bbbbb"))
671 (assert (string= (replace (copy-seq "ccccc")
673 :start2 0 :end2 nil) "bbbbb"))
674 (assert (raises-error? (replace string "ccccc" :start1 0 :end1 6)))
675 (assert (raises-error? (replace string "ccccc" :start2 (opaque-identity -1) :end2 5)))
676 (assert (raises-error? (replace string "ccccc" :start1 4 :end1 2)))
677 (assert (raises-error? (replace string "ccccc" :start1 6 :end1 9))))
680 (sequence-bounding-indices-test
681 (format t "~&/Function SEARCH~%")
682 (assert (= (search "aa" string :start2 0 :end2 5) 0))
683 (assert (null (search string "aa" :start1 0 :end2 nil)))
684 (assert (raises-error? (search "aa" string :start2 0 :end2 6)))
685 (assert (raises-error? (search "aa" string :start2 (opaque-identity -1) :end2 5)))
686 (assert (raises-error? (search "aa" string :start2 4 :end2 2)))
687 (assert (raises-error? (search "aa" string :start2 6 :end2 9))))
689 ;;; Function STRING-UPCASE, STRING-DOWNCASE, STRING-CAPITALIZE,
690 ;;; NSTRING-UPCASE, NSTRING-DOWNCASE, NSTRING-CAPITALIZE
691 (defmacro string-case-frob (fn)
693 (assert (raises-error? (,fn string :start 0 :end 6)))
694 (assert (raises-error? (,fn string :start (opaque-identity -1) :end 5)))
695 (assert (raises-error? (,fn string :start 4 :end 2)))
696 (assert (raises-error? (,fn string :start 6 :end 9)))))
698 (sequence-bounding-indices-test
699 (format t "~&/Function STRING-UPCASE, STRING-DOWNCASE, STRING-CAPITALIZE, ...~%")
700 (string-case-frob string-upcase)
701 (string-case-frob string-downcase)
702 (string-case-frob string-capitalize)
703 (format t "~&/... NSTRING-UPCASE, NSTRING-DOWNCASE, NSTRING-CAPITALIZE~%")
704 (string-case-frob nstring-upcase)
705 (string-case-frob nstring-downcase)
706 (string-case-frob nstring-capitalize))
708 ;;; Function STRING=, STRING/=, STRING<, STRING>, STRING<=, STRING>=,
709 ;;; STRING-EQUAL, STRING-NOT-EQUAL, STRING-LESSP, STRING-GREATERP,
710 ;;; STRING-NOT-GREATERP, STRING-NOT-LESSP
711 (defmacro string-predicate-frob (fn)
713 (,fn string "abcde" :start1 0 :end1 5)
714 (,fn "fghij" string :start2 0 :end2 nil)
715 (assert (raises-error? (,fn string "klmno"
717 (assert (raises-error? (,fn "pqrst" string
718 :start2 (opaque-identity -1) :end2 5)))
719 (assert (raises-error? (,fn "uvwxy" string
721 (assert (raises-error? (,fn string "z" :start2 6 :end2 9)))))
722 (sequence-bounding-indices-test
723 (format t "~&/Function STRING=, STRING/=, STRING<, STRING>, STRING<=, STRING>=, ...")
724 (string-predicate-frob string=)
725 (string-predicate-frob string/=)
726 (string-predicate-frob string<)
727 (string-predicate-frob string>)
728 (string-predicate-frob string<=)
729 (string-predicate-frob string>=))
730 (sequence-bounding-indices-test
731 (format t "~&/... STRING-EQUAL, STRING-NOT-EQUAL, STRING-LESSP, ...~%")
732 (string-predicate-frob string-equal)
733 (string-predicate-frob string-not-equal)
734 (string-predicate-frob string-lessp))
735 (sequence-bounding-indices-test
736 (format t "~&/... STRING-GREATERP, STRING-NOT-GREATERP, STRING-NOT-LESSP~%")
737 (string-predicate-frob string-greaterp)
738 (string-predicate-frob string-not-greaterp)
739 (string-predicate-frob string-not-lessp))
741 ;;; Function SUBSTITUTE, SUBSTITUTE-IF, SUBSTITUTE-IF-NOT,
742 ;;; NSUBSTITUTE, NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT
743 (sequence-bounding-indices-test
744 (format t "~&/Function SUBSTITUTE, SUBSTITUTE-IF, SUBSTITUTE-IF-NOT, ...~%")
745 (assert (string= (substitute #\b #\a string :start 0 :end 5) "bbbbb"))
746 (assert (string= (substitute #\c #\a string :start 0 :end nil)
748 (assert (raises-error? (substitute #\b #\a string :start 0 :end 6)))
749 (assert (raises-error? (substitute #\b #\a string :start (opaque-identity -1) :end 5)))
750 (assert (raises-error? (substitute #\b #\a string :start 4 :end 2)))
751 (assert (raises-error? (substitute #\b #\a string :start 6 :end 9)))
752 (assert (string= (substitute-if #\b #'alpha-char-p string
755 (assert (string= (substitute-if #\c #'alpha-char-p string
758 (assert (raises-error? (substitute-if #\b #'alpha-char-p string
760 (assert (raises-error? (substitute-if #\b #'alpha-char-p string
761 :start (opaque-identity -1) :end 5)))
762 (assert (raises-error? (substitute-if #\b #'alpha-char-p string
764 (assert (raises-error? (substitute-if #\b #'alpha-char-p string
766 (assert (string= (substitute-if-not #\b #'alpha-char-p string
769 (assert (string= (substitute-if-not #\c #'alpha-char-p string
772 (assert (raises-error? (substitute-if-not #\b #'alpha-char-p string
774 (assert (raises-error? (substitute-if-not #\b #'alpha-char-p string
775 :start (opaque-identity -1) :end 5)))
776 (assert (raises-error? (substitute-if-not #\b #'alpha-char-p string
778 (assert (raises-error? (substitute-if-not #\b #'alpha-char-p string
780 (sequence-bounding-indices-test
781 (format t "~&/... NSUBSTITUTE, NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT~%")
782 (assert (string= (nsubstitute #\b #\a string :start 0 :end 5) "bbbbb"))
784 (assert (string= (nsubstitute #\c #\a string :start 0 :end nil)
787 (assert (raises-error? (nsubstitute #\b #\a string :start 0 :end 6)))
789 (assert (raises-error? (nsubstitute #\b #\a string :start (opaque-identity -1) :end 5)))
791 (assert (raises-error? (nsubstitute #\b #\a string :start 4 :end 2)))
793 (assert (raises-error? (nsubstitute #\b #\a string :start 6 :end 9)))
795 (assert (string= (nsubstitute-if #\b #'alpha-char-p string
799 (assert (string= (nsubstitute-if #\c #'alpha-char-p string
803 (assert (raises-error? (nsubstitute-if #\b #'alpha-char-p string
806 (assert (raises-error? (nsubstitute-if #\b #'alpha-char-p string
807 :start (opaque-identity -1) :end 5)))
809 (assert (raises-error? (nsubstitute-if #\b #'alpha-char-p string
812 (assert (raises-error? (nsubstitute-if #\b #'alpha-char-p string
815 (assert (string= (nsubstitute-if-not #\b #'alpha-char-p string
819 (assert (string= (nsubstitute-if-not #\c #'alpha-char-p string
823 (assert (raises-error? (nsubstitute-if-not #\b #'alpha-char-p string
826 (assert (raises-error? (nsubstitute-if-not #\b #'alpha-char-p string
827 :start (opaque-identity -1) :end 5)))
829 (assert (raises-error? (nsubstitute-if-not #\b #'alpha-char-p string
832 (assert (raises-error? (nsubstitute-if-not #\b #'alpha-char-p string
834 ;;; Function WRITE-STRING, WRITE-LINE
835 (sequence-bounding-indices-test
836 (format t "~&/Function WRITE-STRING, WRITE-LINE~%")
837 (write-string string *standard-output* :start 0 :end 5)
838 (write-string string *standard-output* :start 0 :end nil)
839 (assert (raises-error? (write-string string *standard-output*
841 (assert (raises-error? (write-string string *standard-output*
842 :start (opaque-identity -1) :end 5)))
843 (assert (raises-error? (write-string string *standard-output*
845 (assert (raises-error? (write-string string *standard-output*
847 (write-line string *standard-output* :start 0 :end 5)
848 (write-line string *standard-output* :start 0 :end nil)
849 (assert (raises-error? (write-line string *standard-output*
851 (assert (raises-error? (write-line string *standard-output*
852 :start (opaque-identity -1) :end 5)))
853 (assert (raises-error? (write-line string *standard-output*
855 (assert (raises-error? (write-line string *standard-output*
858 ;;; Macro WITH-INPUT-FROM-STRING
859 (sequence-bounding-indices-test
860 (format t "~&/Macro WITH-INPUT-FROM-STRING~%")
861 (with-input-from-string (s string :start 0 :end 5)
862 (assert (char= (read-char s) #\a)))
863 (with-input-from-string (s string :start 0 :end nil)
864 (assert (char= (read-char s) #\a)))
865 (assert (raises-error?
866 (with-input-from-string (s string :start 0 :end 6)
868 (assert (raises-error?
869 (with-input-from-string (s string :start (opaque-identity -1) :end 5)
871 (assert (raises-error?
872 (with-input-from-string (s string :start 4 :end 2)
874 (assert (raises-error?
875 (with-input-from-string (s string :start 6 :end 9)
879 (sb-ext:quit :unix-status 104)