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