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 ;;; helper functions for exercising SEQUENCE code on data of many
25 ;;; specialized types, and in many different optimization scenarios
26 (defun for-every-seq-1 (base-seq snippet
)
27 (dolist (seq-type '(list
30 (simple-array character
1)
32 (simple-array (signed-byte 4) 1)
33 (vector (signed-byte 4))))
34 (flet ((entirely (eltype)
35 (every (lambda (el) (typep el eltype
)) base-seq
)))
36 (dolist (declaredness '(nil t
))
37 (dolist (optimization '(((speed 3) (space 0))
40 ((speed 0) (space 1))))
41 (let* ((seq (if (eq seq-type
'list
)
42 (coerce base-seq
'list
)
43 (destructuring-bind (type-first &rest type-rest
)
47 (destructuring-bind (eltype one
) type-rest
50 (coerce base-seq seq-type
)
53 (destructuring-bind (eltype) type-rest
55 (let ((initial-element
56 (cond ((subtypep eltype
'character
)
58 ((subtypep eltype
'number
)
71 (lambda-expr `(lambda (seq)
73 `((declare (type ,seq-type seq
))))
74 (declare (optimize ,@optimization
))
76 (format t
"~&~S~%" lambda-expr
)
77 (multiple-value-bind (fun warnings-p failure-p
)
78 (compile nil lambda-expr
)
79 (when (or warnings-p failure-p
)
80 (error "~@<failed compilation:~2I ~_LAMBDA-EXPR=~S ~_WARNINGS-P=~S ~_FAILURE-P=~S~:@>"
81 lambda-expr warnings-p failure-p
))
82 (format t
"~&~S ~S~%~S~%~S ~S~%"
83 base-seq snippet seq-type declaredness optimization
)
84 (format t
"~&(TYPEP SEQ 'SIMPLE-ARRAY)=~S~%"
85 (typep seq
'simple-array
))
86 (unless (funcall fun seq
)
87 (error "~@<failed test:~2I ~_BASE-SEQ=~S ~_SNIPPET=~S ~_SEQ-TYPE=~S ~_DECLAREDNESS=~S ~_OPTIMIZATION=~S~:@>"
93 (defun for-every-seq (base-seq snippets
)
94 (dolist (snippet snippets
)
95 (for-every-seq-1 base-seq snippet
)))
97 ;;; a wrapper to hide declared type information from the compiler, so
98 ;;; we don't get stopped by compiler warnings about e.g. compiling
99 ;;; (POSITION 1 #() :KEY #'ABS) when #() has been coerced to a string.
100 (defun indiscriminate (fun)
101 (lambda (&rest rest
) (apply fun rest
)))
103 ;;; asymmetric test arg order example from ANSI FIND definition page
104 (assert (eql #\space
; original example, depends on ASCII character ordering
105 (find #\d
"here are some letters that can be looked at"
107 (assert (eql #\e
; modified example, depends only on standard a-z ordering
108 (find #\f "herearesomeletters" :test
#'char
>)))
109 (assert (eql 4 ; modified more, avoids charset technicalities completely
110 (find 5 '(6 4) :test
'>)))
112 ;;; tests of FIND, POSITION, FIND-IF, and POSITION-IF (and a few for
113 ;;; deprecated FIND-IF-NOT and POSITION-IF-NOT too)
115 '((null (find 1 seq
))
116 (null (find 1 seq
:from-end t
))
117 (null (position 1 seq
:key
(indiscriminate #'abs
)))
118 (null (position nil seq
:test
(constantly t
)))
119 (null (position nil seq
:test nil
))
120 (null (position nil seq
:test-not nil
))
121 (null (find-if #'1+ seq
:key
(indiscriminate #'log
)))
122 (null (position-if #'identity seq
:from-end t
))
123 (null (find-if-not #'packagep seq
))
124 (null (position-if-not #'packagep seq
:key nil
))))
126 '((null (find 2 seq
))
127 ;; Get the argument ordering for asymmetric tests like #'> right.
128 ;; (bug reported and fixed by Alexey Dejneka sbcl-devel 2001-10-17)
129 (eql 1 (find 2 seq
:test
#'>))
130 (find 2 seq
:key
#'1+)
131 (find 1 seq
:from-end t
)
132 (null (find 1 seq
:from-end t
:start
1))
133 (null (find 0 seq
:from-end t
))
134 (eql 0 (position 1 seq
:key
#'abs
))
135 (null (position nil seq
:test
'equal
))
136 (eql 1 (find-if #'1- seq
:key
#'log
))
137 (eql 0 (position-if #'identity seq
:from-end t
))
138 (null (find-if-not #'sin seq
))
139 (eql 0 (position-if-not #'packagep seq
:key
'identity
))))
140 (for-every-seq #(1 2 3 2 1)
142 (find 3 seq
:from-end
'yes
)
143 (eql 1 (position 1.5 seq
:test
#'<))
144 (eql 0 (position 0 seq
:key
'1-
))
145 (eql 4 (position 0 seq
:key
'1-
:from-end t
))
146 (eql 2 (position 4 seq
:key
'1+))
147 (eql 2 (position 4 seq
:key
'1+ :from-end t
))
148 (eql 1 (position 2 seq
))
149 (eql 1 (position 2 seq
:start
1))
150 (null (find 2 seq
:start
1 :end
1))
151 (eql 3 (position 2 seq
:start
2))
152 (eql 3 (position 2 seq
:key nil
:from-end t
))
153 (eql 2 (position 3 seq
:test
'=))
154 (eql 0 (position 3 seq
:test-not
'equalp
))
155 (eql 2 (position 3 seq
:test
'equal
:from-end t
))
156 (null (position 4 seq
:test
#'eql
))
157 (null (find-if #'packagep seq
))
158 (eql 1 (find-if #'plusp seq
))
159 (eql 3 (position-if #'plusp seq
:key
#'1-
:from-end t
))
160 (eql 1 (position-if #'evenp seq
))
161 (eql 3 (position-if #'evenp seq
:from-end t
))
162 (eql 2 (position-if #'plusp seq
:from-end nil
:key
'1-
:start
2))
163 (eql 3 (position-if #'plusp seq
:from-end t
:key
'1-
:start
2))
164 (null (position-if #'plusp seq
:from-end t
:key
'1-
:start
2 :end
2))
165 (null (find-if-not #'plusp seq
))
166 (eql 0 (position-if-not #'evenp seq
))
167 (eql 0 (search #(1) seq
))
168 (eql 1 (search #(4 5) seq
:key
'oddp
))
169 (eql 1 (search #(-2) seq
:test
(lambda (a b
) (= (- a
) b
))))
170 (eql 4 (search #(1) seq
:start2
1))
171 (null (search #(3) seq
:start2
3))
172 (eql 2 (search #(3) seq
:start2
2))
173 (eql 0 (search #(1 2) seq
))
174 (null (search #(2 1 3) seq
))
175 (eql 0 (search #(0 1 2 4) seq
:start1
1 :end1
3))
176 (eql 3 (search #(0 2 1 4) seq
:start1
1 :end1
3))
177 (eql 4 (search #(1) seq
:from-end t
))
178 (eql 0 (search #(1 2) seq
:from-end t
))
179 (null (search #(1 2) seq
:from-end t
:start2
1))
180 (eql 0 (search #(0 1 2 4) seq
:from-end t
:start1
1 :end1
3))
181 (eql 3 (search #(0 2 1 4) seq
:from-end t
:start1
1 :end1
3))
182 (null (search #(2 1 3) seq
:from-end t
))))
183 (for-every-seq "string test"
184 '((null (find 0 seq
))
185 (null (find #\D seq
:key
#'char-upcase
))
186 (find #\E seq
:key
#'char-upcase
)
187 (null (find #\e seq
:key
#'char-upcase
))
188 (eql 3 (position #\i seq
))
189 (eql 0 (position #\s seq
:key
#'char-downcase
))
190 (eql 1 (position #\s seq
:key
#'char-downcase
:test
#'char
/=))
191 (eql 9 (position #\s seq
:from-end t
:test
#'char
=))
192 (eql 10 (position #\s seq
:from-end t
:test
#'char
/=))
193 (eql 4 (position #\N seq
:from-end t
:key
'char-upcase
:test
#'char-equal
))
194 (eql 5 (position-if (lambda (c) (equal #\g c
)) seq
))
195 (eql 5 (position-if (lambda (c) (equal #\g c
)) seq
:from-end t
))
196 (find-if #'characterp seq
)
197 (find-if (lambda (c) (typep c
'base-char
)) seq
:from-end t
)
198 (null (find-if 'upper-case-p seq
))))
201 (let ((avec (make-array 10
203 :initial-contents
'(0 1 2 3 iv v vi vii iix ix
))))
204 ;; These first five always worked AFAIK.
205 (assert (equalp (subseq avec
0 3) #(0 1 2)))
206 (assert (equalp (subseq avec
3 3) #()))
207 (assert (equalp (subseq avec
1 3) #(1 2)))
208 (assert (equalp (subseq avec
1) #(1 2 3)))
209 (assert (equalp (subseq avec
1 4) #(1 2 3)))
210 ;; SBCL bug found ca. 2002-05-01 by OpenMCL's correct handling of
211 ;; SUBSEQ, CSR's driving portable cross-compilation far enough to
212 ;; reach the SUBSEQ calls in assem.lisp, and WHN's sleazy
213 ;; translation of old CMU CL new-assem.lisp into sufficiently grotty
214 ;; portable Lisp that it passed suitable illegal values to SUBSEQ to
215 ;; exercise the bug:-|
217 ;; SUBSEQ should check its END value against logical LENGTH, not
218 ;; physical ARRAY-DIMENSION 0.
220 ;; fixed in sbcl-0.7.4.22 by WHN
221 (assert (null (ignore-errors (aref (subseq avec
1 5) 0)))))
224 (defun test-fill-typecheck (x)
225 (declare (optimize (safety 3) (space 2) (speed 1)))
226 (fill (make-string 10) x
))
228 (assert (string= (test-fill-typecheck #\
@) "@@@@@@@@@@"))
229 ;;; BUG 186, fixed in sbcl-0.7.5.5
230 (assert (null (ignore-errors (test-fill-typecheck 4097))))
232 ;;; MAKE-SEQUENCE, COERCE, CONCATENATE, MERGE, MAP and requested
233 ;;; result type (BUGs 46a, 46b, 66)
234 (macrolet ((assert-type-error (form)
235 `(assert (typep (nth-value 1 (ignore-errors ,form
))
237 (dolist (type-stub '((simple-vector)
239 (vector (signed-byte 8))
240 (vector (unsigned-byte 16))
241 (vector (signed-byte 32))
242 (simple-bit-vector)))
243 (declare (optimize safety
))
244 (format t
"~&~S~%" type-stub
)
246 (assert (= (length (make-sequence `(,@type-stub
) 10)) 10))
247 (assert (= (length (make-sequence `(,@type-stub
10) 10)) 10))
248 (assert-type-error (make-sequence `(,@type-stub
10) 11))
250 (assert (= (length (coerce '(0 0 0) `(,@type-stub
))) 3))
251 (assert (= (length (coerce #(0 0 0) `(,@type-stub
3))) 3))
252 (assert-type-error (coerce #*111 `(,@type-stub
4)))
254 (assert (= (length (concatenate `(,@type-stub
) #(0 0 0) #*111)) 6))
255 (assert (equalp (concatenate `(,@type-stub
) #(0 0 0) #*111)
256 (coerce #(0 0 0 1 1 1) `(,@type-stub
))))
257 (assert (= (length (concatenate `(,@type-stub
6) #(0 0 0) #*111)) 6))
258 (assert (equalp (concatenate `(,@type-stub
6) #(0 0 0) #*111)
259 (coerce #(0 0 0 1 1 1) `(,@type-stub
6))))
260 (assert-type-error (concatenate `(,@type-stub
5) #(0 0 0) #*111))
262 (macrolet ((test (type)
263 `(merge ,type
(copy-seq #(0 1 0)) (copy-seq #*111) #'>)))
264 (assert (= (length (test `(,@type-stub
))) 6))
265 (assert (equalp (test `(,@type-stub
))
266 (coerce #(1 1 1 0 1 0) `(,@type-stub
))))
267 (assert (= (length (test `(,@type-stub
6))) 6))
268 (assert (equalp (test `(,@type-stub
6))
269 (coerce #(1 1 1 0 1 0) `(,@type-stub
6))))
270 (assert-type-error (test `(,@type-stub
4))))
272 (assert (= (length (map `(,@type-stub
) #'logxor
#(0 0 1 1) '(0 1 0 1))) 4))
273 (assert (equalp (map `(,@type-stub
) #'logxor
#(0 0 1 1) '(0 1 0 1))
274 (coerce #(0 1 1 0) `(,@type-stub
))))
275 (assert (= (length (map `(,@type-stub
4) #'logxor
#(0 0 1 1) '(0 1 0 1)))
277 (assert (equalp (map `(,@type-stub
4) #'logxor
#(0 0 1 1) '(0 1 0 1))
278 (coerce #(0 1 1 0) `(,@type-stub
4))))
279 (assert-type-error (map `(,@type-stub
5) #'logxor
#(0 0 1 1) '(0 1 0 1))))
280 ;; some more CONCATENATE tests for strings
282 (declare (optimize safety
))
283 (assert (string= (concatenate 'string
"foo" " " "bar") "foo bar"))
284 (assert (string= (concatenate '(string 7) "foo" " " "bar") "foo bar"))
285 (assert-type-error (concatenate '(string 6) "foo" " " "bar"))
286 (assert (string= (concatenate '(string 6) "foo" #(#\b #\a #\r)) "foobar"))
287 (assert-type-error (concatenate '(string 7) "foo" #(#\b #\a #\r))))
288 ;; Non-VECTOR ARRAY types aren't allowed as vector type specifiers.
290 (declare (optimize safety
))
291 (assert-type-error (concatenate 'simple-array
"foo" "bar"))
292 (assert-type-error (map 'simple-array
#'identity
'(1 2 3)))
293 (assert (equalp #(11 13)
294 (map '(simple-array fixnum
(*)) #'+ '(1 2 3) '(10 11))))
295 (assert-type-error (coerce '(1 2 3) 'simple-array
))
296 (assert-type-error (merge 'simple-array
(list 1 3) (list 2 4) '<))
297 (assert (equalp #(3 2 1) (coerce '(3 2 1) '(vector fixnum
))))
298 (assert-type-error (map 'array
#'identity
'(1 2 3)))
299 (assert-type-error (map '(array fixnum
) #'identity
'(1 2 3)))
300 (assert (equalp #(1 2 3) (coerce '(1 2 3) '(vector fixnum
))))
301 ;; but COERCE has an exemption clause:
302 (assert (string= "foo" (coerce "foo" 'simple-array
)))
303 ;; ... though not in all cases.
304 (assert-type-error (coerce '(#\f #\o
#\o
) 'simple-array
))))
306 ;;; As pointed out by Raymond Toy on #lisp IRC, MERGE had some issues
307 ;;; with user-defined types until sbcl-0.7.8.11
308 (deftype list-typeoid
() 'list
)
309 (assert (equal '(1 2 3 4) (merge 'list-typeoid
(list 1 3) (list 2 4) '<)))
310 ;;; and also with types that weren't precicely LIST
311 (assert (equal '(1 2 3 4) (merge 'cons
(list 1 3) (list 2 4) '<)))
313 ;;; but wait, there's more! The NULL and CONS types also have implicit
314 ;;; length requirements:
315 (macrolet ((assert-type-error (form)
316 `(assert (typep (nth-value 1 (ignore-errors ,form
))
319 (declare (optimize safety
))
321 (assert-type-error (make-sequence 'cons
0))
322 (assert-type-error (make-sequence 'null
1))
323 (assert-type-error (make-sequence '(cons t null
) 0))
324 (assert-type-error (make-sequence '(cons t null
) 2))
325 ;; KLUDGE: I'm not certain that this test actually tests for what
326 ;; it should test, in that the type deriver and optimizers might
327 ;; be too smart for the good of an exhaustive test system.
328 ;; However, it makes me feel good. -- CSR, 2002-10-18
329 (assert (null (make-sequence 'null
0)))
330 (assert (= (length (make-sequence 'cons
3)) 3))
331 (assert (= (length (make-sequence '(cons t null
) 1)) 1))
332 ;; and NIL is not a valid type for MAKE-SEQUENCE
333 (assert-type-error (make-sequence 'nil
0))
335 (assert-type-error (coerce #(1) 'null
))
336 (assert-type-error (coerce #() 'cons
))
337 (assert-type-error (coerce #() '(cons t null
)))
338 (assert-type-error (coerce #(1 2) '(cons t null
)))
339 (assert (null (coerce #() 'null
)))
340 (assert (= (length (coerce #(1) 'cons
)) 1))
341 (assert (= (length (coerce #(1) '(cons t null
))) 1))
342 (assert-type-error (coerce #() 'nil
))
344 (assert-type-error (merge 'null
(list 1 3) (list 2 4) '<))
345 (assert-type-error (merge 'cons
() () '<))
346 (assert (null (merge 'null
() () '<)))
347 (assert (= (length (merge 'cons
(list 1 3) (list 2 4) '<)) 4))
348 (assert (= (length (merge '(cons t
(cons t
(cons t
(cons t null
))))
349 (list 1 3) (list 2 4)
352 (assert-type-error (merge 'nil
() () '<))
354 (assert-type-error (concatenate 'null
'(1) "2"))
355 (assert-type-error (concatenate 'cons
#() ()))
356 (assert-type-error (concatenate '(cons t null
) #(1 2 3) #(4 5 6)))
357 (assert (null (concatenate 'null
() #())))
358 (assert (= (length (concatenate 'cons
#() '(1) "2 3")) 4))
359 (assert (= (length (concatenate '(cons t cons
) '(1) "34")) 3))
360 (assert-type-error (concatenate 'nil
'(3)))
361 ;; FIXME: tests for MAP to come when some brave soul implements
362 ;; the analogous type checking for MAP/%MAP.
365 ;;; ELT should signal an error of type TYPE-ERROR if its index
366 ;;; argument isn't a valid sequence index for sequence:
367 (defun test-elt-signal (x)
369 (assert (raises-error?
(test-elt-signal "foo") type-error
))
370 (assert (eql (test-elt-signal "foob") #\b))
372 (declare (optimize (safety 3)))
373 (assert (raises-error?
(elt (list 1 2 3) 3) type-error
)))
375 ;;; confusion in the refactoring led to this signalling an unbound
376 ;;; variable, not a type error.
377 (defun svrefalike (x)
379 (assert (raises-error?
(svrefalike #*0) type-error
))
381 ;;; checks for uniform bounding index handling.
383 ;;; This used to be SAFETY 3 only, but bypassing these checks with
384 ;;; above-zero speed when SPEED > SAFETY is not The SBCL Way.
386 ;;; KLUDGE: not all in one big form because that causes SBCL to spend
387 ;;; an absolute age trying to compile it.
388 (defmacro sequence-bounding-indices-test
(&body body
)
391 ;; See Issues 332 [and 333(!)] in the CLHS
392 (declare (optimize (speed 3) (safety 1)))
393 (let ((string (make-array 10
396 :element-type
'base-char
)))
398 (format t
"... BASE-CHAR")
401 (setf (fill-pointer string
) 10)
403 (setf (fill-pointer string
) 5)))
404 (declare (ignorable #'reset
))
407 ;; See Issues 332 [and 333(!)] in the CLHS
408 (declare (optimize (speed 3) (safety 1)))
409 (let ((string (make-array 10
412 :element-type
'character
)))
414 (format t
"... CHARACTER")
417 (setf (fill-pointer string
) 10)
419 (setf (fill-pointer string
) 5)))
420 (declare (ignorable #'reset
))
423 (declaim (notinline opaque-identity
))
424 (defun opaque-identity (x) x
)
426 (sequence-bounding-indices-test
427 (format t
"~&/Accessor SUBSEQ")
428 (assert (string= (subseq string
0 5) "aaaaa"))
429 (assert (raises-error?
(subseq string
0 6)))
430 (assert (raises-error?
(subseq string
(opaque-identity -
1) 5)))
431 (assert (raises-error?
(subseq string
4 2)))
432 (assert (raises-error?
(subseq string
6)))
433 (assert (string= (setf (subseq string
0 5) "abcde") "abcde"))
434 (assert (string= (subseq string
0 5) "abcde"))
436 (assert (raises-error?
(setf (subseq string
0 6) "abcdef")))
437 (assert (raises-error?
(setf (subseq string
(opaque-identity -
1) 5) "abcdef")))
438 (assert (raises-error?
(setf (subseq string
4 2) "")))
439 (assert (raises-error?
(setf (subseq string
6) "ghij"))))
441 ;;; Function COUNT, COUNT-IF, COUNT-IF-NOT
442 (sequence-bounding-indices-test
443 (format t
"~&/Function COUNT, COUNT-IF, COUNT-IF-NOT")
444 (assert (= (count #\a string
:start
0 :end nil
) 5))
445 (assert (= (count #\a string
:start
0 :end
5) 5))
446 (assert (raises-error?
(count #\a string
:start
0 :end
6)))
447 (assert (raises-error?
(count #\a string
:start
(opaque-identity -
1) :end
5)))
448 (assert (raises-error?
(count #\a string
:start
4 :end
2)))
449 (assert (raises-error?
(count #\a string
:start
6 :end
9)))
450 (assert (= (count-if #'alpha-char-p string
:start
0 :end nil
) 5))
451 (assert (= (count-if #'alpha-char-p string
:start
0 :end
5) 5))
452 (assert (raises-error?
453 (count-if #'alpha-char-p string
:start
0 :end
6)))
454 (assert (raises-error?
455 (count-if #'alpha-char-p string
:start
(opaque-identity -
1) :end
5)))
456 (assert (raises-error?
457 (count-if #'alpha-char-p string
:start
4 :end
2)))
458 (assert (raises-error?
459 (count-if #'alpha-char-p string
:start
6 :end
9)))
460 (assert (= (count-if-not #'alpha-char-p string
:start
0 :end nil
) 0))
461 (assert (= (count-if-not #'alpha-char-p string
:start
0 :end
5) 0))
462 (assert (raises-error?
463 (count-if-not #'alpha-char-p string
:start
0 :end
6)))
464 (assert (raises-error?
465 (count-if-not #'alpha-char-p string
:start
(opaque-identity -
1) :end
5)))
466 (assert (raises-error?
467 (count-if-not #'alpha-char-p string
:start
4 :end
2)))
468 (assert (raises-error?
469 (count-if-not #'alpha-char-p string
:start
6 :end
9))))
472 (sequence-bounding-indices-test
473 (format t
"~&/Function FILL")
474 (assert (string= (fill string
#\b :start
0 :end
5) "bbbbb"))
475 (assert (string= (fill string
#\c
:start
0 :end nil
) "ccccc"))
476 (assert (raises-error?
(fill string
#\d
:start
0 :end
6)))
477 (assert (raises-error?
(fill string
#\d
:start
(opaque-identity -
1) :end
5)))
478 (assert (raises-error?
(fill string
#\d
:start
4 :end
2)))
479 (assert (raises-error?
(fill string
#\d
:start
6 :end
9))))
481 ;;; Function FIND, FIND-IF, FIND-IF-NOT
482 (sequence-bounding-indices-test
483 (format t
"~&/Function FIND, FIND-IF, FIND-IF-NOT")
484 (assert (char= (find #\a string
:start
0 :end nil
) #\a))
485 (assert (char= (find #\a string
:start
0 :end
5) #\a))
486 (assert (raises-error?
(find #\a string
:start
0 :end
6)))
487 (assert (raises-error?
(find #\a string
:start
(opaque-identity -
1) :end
5)))
488 (assert (raises-error?
(find #\a string
:start
4 :end
2)))
489 (assert (raises-error?
(find #\a string
:start
6 :end
9)))
490 (assert (char= (find-if #'alpha-char-p string
:start
0 :end nil
) #\a))
491 (assert (char= (find-if #'alpha-char-p string
:start
0 :end
5) #\a))
492 (assert (raises-error?
493 (find-if #'alpha-char-p string
:start
0 :end
6)))
494 (assert (raises-error?
495 (find-if #'alpha-char-p string
:start
(opaque-identity -
1) :end
5)))
496 (assert (raises-error?
497 (find-if #'alpha-char-p string
:start
4 :end
2)))
498 (assert (raises-error?
499 (find-if #'alpha-char-p string
:start
6 :end
9)))
500 (assert (eq (find-if-not #'alpha-char-p string
:start
0 :end nil
) nil
))
501 (assert (eq (find-if-not #'alpha-char-p string
:start
0 :end
5) nil
))
502 (assert (raises-error?
503 (find-if-not #'alpha-char-p string
:start
0 :end
6)))
504 (assert (raises-error?
505 (find-if-not #'alpha-char-p string
:start
(opaque-identity -
1) :end
5)))
506 (assert (raises-error?
507 (find-if-not #'alpha-char-p string
:start
4 :end
2)))
508 (assert (raises-error?
509 (find-if-not #'alpha-char-p string
:start
6 :end
9))))
511 ;;; Function MISMATCH
512 (sequence-bounding-indices-test
513 (format t
"~&/Function MISMATCH")
514 (assert (null (mismatch string
"aaaaa" :start1
0 :end1 nil
)))
515 (assert (= (mismatch "aaab" string
:start2
0 :end2
4) 3))
516 (assert (raises-error?
(mismatch "aaaaaa" string
:start2
0 :end2
6)))
517 (assert (raises-error?
(mismatch string
"aaaaaa" :start1
(opaque-identity -
1) :end1
5)))
518 (assert (raises-error?
(mismatch string
"" :start1
4 :end1
2)))
519 (assert (raises-error?
(mismatch "aaaa" string
:start2
6 :end2
9))))
521 ;;; Function PARSE-INTEGER
522 (sequence-bounding-indices-test
523 (format t
"~&/Function PARSE-INTEGER")
524 (setf (fill-pointer string
) 10)
525 (setf (subseq string
0 10) "1234567890")
526 (setf (fill-pointer string
) 5)
527 (assert (= (parse-integer string
:start
0 :end
5) 12345))
528 (assert (= (parse-integer string
:start
0 :end nil
) 12345))
529 (assert (raises-error?
(parse-integer string
:start
0 :end
6)))
530 (assert (raises-error?
(parse-integer string
:start
(opaque-identity -
1) :end
5)))
531 (assert (raises-error?
(parse-integer string
:start
4 :end
2)))
532 (assert (raises-error?
(parse-integer string
:start
6 :end
9))))
534 ;;; Function PARSE-NAMESTRING
535 (sequence-bounding-indices-test
536 (format t
"~&/Function PARSE-NAMESTRING")
537 (setf (fill-pointer string
) 10)
538 (setf (subseq string
0 10)
541 (setf (fill-pointer string
) 5)
542 (assert (truename (parse-namestring string nil
*default-pathname-defaults
*
544 (assert (truename (parse-namestring string nil
*default-pathname-defaults
*
546 (assert (raises-error?
(parse-namestring string nil
547 *default-pathname-defaults
*
549 (assert (raises-error?
(parse-namestring string nil
550 *default-pathname-defaults
*
551 :start
(opaque-identity -
1) :end
5)))
552 (assert (raises-error?
(parse-namestring string nil
553 *default-pathname-defaults
*
555 (assert (raises-error?
(parse-namestring string nil
556 *default-pathname-defaults
*
559 ;;; Function POSITION, POSITION-IF, POSITION-IF-NOT
560 (sequence-bounding-indices-test
561 (format t
"~&/Function POSITION, POSITION-IF, POSITION-IF-NOT")
563 (assert (= (position #\a string
:start
0 :end nil
) 0))
564 (assert (= (position #\a string
:start
0 :end
5) 0))
565 (assert (raises-error?
(position #\a string
:start
0 :end
6)))
566 (assert (raises-error?
(position #\a string
:start
(opaque-identity -
1) :end
5)))
567 (assert (raises-error?
(position #\a string
:start
4 :end
2)))
568 (assert (raises-error?
(position #\a string
:start
6 :end
9)))
569 (assert (= (position-if #'alpha-char-p string
:start
0 :end nil
) 0))
570 (assert (= (position-if #'alpha-char-p string
:start
0 :end
5) 0))
571 (assert (raises-error?
572 (position-if #'alpha-char-p string
:start
0 :end
6)))
573 (assert (raises-error?
574 (position-if #'alpha-char-p string
:start
(opaque-identity -
1) :end
5)))
575 (assert (raises-error?
576 (position-if #'alpha-char-p string
:start
4 :end
2)))
577 (assert (raises-error?
578 (position-if #'alpha-char-p string
:start
6 :end
9)))
579 (assert (eq (position-if-not #'alpha-char-p string
:start
0 :end nil
) nil
))
580 (assert (eq (position-if-not #'alpha-char-p string
:start
0 :end
5) nil
))
581 (assert (raises-error?
582 (position-if-not #'alpha-char-p string
:start
0 :end
6)))
583 (assert (raises-error?
584 (position-if-not #'alpha-char-p string
:start
(opaque-identity -
1) :end
5)))
585 (assert (raises-error?
586 (position-if-not #'alpha-char-p string
:start
4 :end
2)))
587 (assert (raises-error?
588 (position-if-not #'alpha-char-p string
:start
6 :end
9))))
590 ;;; Function READ-FROM-STRING
591 (sequence-bounding-indices-test
592 (format t
"~&/Function READ-FROM-STRING")
593 (setf (subseq string
0 5) "(a b)")
594 (assert (equal (read-from-string string nil nil
:start
0 :end
5) '(a b
)))
595 (assert (equal (read-from-string string nil nil
:start
0 :end nil
) '(a b
)))
596 (assert (raises-error?
(read-from-string string nil nil
:start
0 :end
6)))
597 (assert (raises-error?
(read-from-string string nil nil
:start
(opaque-identity -
1) :end
5)))
598 (assert (raises-error?
(read-from-string string nil nil
:start
4 :end
2)))
599 (assert (raises-error?
(read-from-string string nil nil
:start
6 :end
9))))
602 (sequence-bounding-indices-test
603 (format t
"~&/Function REDUCE")
604 (setf (subseq string
0 5) "abcde")
605 (assert (equal (reduce #'list
* string
:from-end t
:start
0 :end nil
)
606 '(#\a #\b #\c
#\d .
#\e
)))
607 (assert (equal (reduce #'list
* string
:from-end t
:start
0 :end
5)
608 '(#\a #\b #\c
#\d .
#\e
)))
609 (assert (raises-error?
(reduce #'list
* string
:start
0 :end
6)))
610 (assert (raises-error?
(reduce #'list
* string
:start
(opaque-identity -
1) :end
5)))
611 (assert (raises-error?
(reduce #'list
* string
:start
4 :end
2)))
612 (assert (raises-error?
(reduce #'list
* string
:start
6 :end
9))))
614 ;;; Function REMOVE, REMOVE-IF, REMOVE-IF-NOT, DELETE, DELETE-IF,
616 (sequence-bounding-indices-test
617 (format t
"~&/Function REMOVE, REMOVE-IF, REMOVE-IF-NOT, ...")
618 (assert (equal (remove #\a string
:start
0 :end nil
) ""))
619 (assert (equal (remove #\a string
:start
0 :end
5) ""))
620 (assert (raises-error?
(remove #\a string
:start
0 :end
6)))
621 (assert (raises-error?
(remove #\a string
:start
(opaque-identity -
1) :end
5)))
622 (assert (raises-error?
(remove #\a string
:start
4 :end
2)))
623 (assert (raises-error?
(remove #\a string
:start
6 :end
9)))
624 (assert (equal (remove-if #'alpha-char-p string
:start
0 :end nil
) ""))
625 (assert (equal (remove-if #'alpha-char-p string
:start
0 :end
5) ""))
626 (assert (raises-error?
627 (remove-if #'alpha-char-p string
:start
0 :end
6)))
628 (assert (raises-error?
629 (remove-if #'alpha-char-p string
:start
(opaque-identity -
1) :end
5)))
630 (assert (raises-error?
631 (remove-if #'alpha-char-p string
:start
4 :end
2)))
632 (assert (raises-error?
633 (remove-if #'alpha-char-p string
:start
6 :end
9)))
634 (assert (equal (remove-if-not #'alpha-char-p string
:start
0 :end nil
)
636 (assert (equal (remove-if-not #'alpha-char-p string
:start
0 :end
5)
638 (assert (raises-error?
639 (remove-if-not #'alpha-char-p string
:start
0 :end
6)))
640 (assert (raises-error?
641 (remove-if-not #'alpha-char-p string
:start
(opaque-identity -
1) :end
5)))
642 (assert (raises-error?
643 (remove-if-not #'alpha-char-p string
:start
4 :end
2)))
644 (assert (raises-error?
645 (remove-if-not #'alpha-char-p string
:start
6 :end
9))))
646 (sequence-bounding-indices-test
647 (format t
"~&/... DELETE, DELETE-IF, DELETE-IF-NOT")
648 (assert (equal (delete #\a string
:start
0 :end nil
) ""))
650 (assert (equal (delete #\a string
:start
0 :end
5) ""))
652 (assert (raises-error?
(delete #\a string
:start
0 :end
6)))
654 (assert (raises-error?
(delete #\a string
:start
(opaque-identity -
1) :end
5)))
656 (assert (raises-error?
(delete #\a string
:start
4 :end
2)))
658 (assert (raises-error?
(delete #\a string
:start
6 :end
9)))
660 (assert (equal (delete-if #'alpha-char-p string
:start
0 :end nil
) ""))
662 (assert (equal (delete-if #'alpha-char-p string
:start
0 :end
5) ""))
664 (assert (raises-error?
665 (delete-if #'alpha-char-p string
:start
0 :end
6)))
667 (assert (raises-error?
668 (delete-if #'alpha-char-p string
:start
(opaque-identity -
1) :end
5)))
670 (assert (raises-error?
671 (delete-if #'alpha-char-p string
:start
4 :end
2)))
673 (assert (raises-error?
674 (delete-if #'alpha-char-p string
:start
6 :end
9)))
676 (assert (equal (delete-if-not #'alpha-char-p string
:start
0 :end nil
)
679 (assert (equal (delete-if-not #'alpha-char-p string
:start
0 :end
5)
682 (assert (raises-error?
683 (delete-if-not #'alpha-char-p string
:start
0 :end
6)))
685 (assert (raises-error?
686 (delete-if-not #'alpha-char-p string
:start
(opaque-identity -
1) :end
5)))
688 (assert (raises-error?
689 (delete-if-not #'alpha-char-p string
:start
4 :end
2)))
691 (assert (raises-error?
692 (delete-if-not #'alpha-char-p string
:start
6 :end
9))))
694 ;;; Function REMOVE-DUPLICATES, DELETE-DUPLICATES
695 (sequence-bounding-indices-test
696 (format t
"~&/Function REMOVE-DUPLICATES, DELETE-DUPLICATES")
697 (assert (string= (remove-duplicates string
:start
0 :end
5) "a"))
698 (assert (string= (remove-duplicates string
:start
0 :end nil
) "a"))
699 (assert (raises-error?
(remove-duplicates string
:start
0 :end
6)))
700 (assert (raises-error?
(remove-duplicates string
:start
(opaque-identity -
1) :end
5)))
701 (assert (raises-error?
(remove-duplicates string
:start
4 :end
2)))
702 (assert (raises-error?
(remove-duplicates string
:start
6 :end
9)))
703 (assert (string= (delete-duplicates string
:start
0 :end
5) "a"))
705 (assert (string= (delete-duplicates string
:start
0 :end nil
) "a"))
707 (assert (raises-error?
(delete-duplicates string
:start
0 :end
6)))
709 (assert (raises-error?
(delete-duplicates string
:start
(opaque-identity -
1) :end
5)))
711 (assert (raises-error?
(delete-duplicates string
:start
4 :end
2)))
713 (assert (raises-error?
(delete-duplicates string
:start
6 :end
9))))
716 (sequence-bounding-indices-test
717 (format t
"~&/Function REPLACE")
718 (assert (string= (replace string
"bbbbb" :start1
0 :end1
5) "bbbbb"))
719 (assert (string= (replace (copy-seq "ccccc")
721 :start2
0 :end2 nil
) "bbbbb"))
722 (assert (raises-error?
(replace string
"ccccc" :start1
0 :end1
6)))
723 (assert (raises-error?
(replace string
"ccccc" :start2
(opaque-identity -
1) :end2
5)))
724 (assert (raises-error?
(replace string
"ccccc" :start1
4 :end1
2)))
725 (assert (raises-error?
(replace string
"ccccc" :start1
6 :end1
9))))
728 (sequence-bounding-indices-test
729 (format t
"~&/Function SEARCH")
730 (assert (= (search "aa" string
:start2
0 :end2
5) 0))
731 (assert (null (search string
"aa" :start1
0 :end2 nil
)))
732 (assert (raises-error?
(search "aa" string
:start2
0 :end2
6)))
733 (assert (raises-error?
(search "aa" string
:start2
(opaque-identity -
1) :end2
5)))
734 (assert (raises-error?
(search "aa" string
:start2
4 :end2
2)))
735 (assert (raises-error?
(search "aa" string
:start2
6 :end2
9))))
737 ;;; Function STRING-UPCASE, STRING-DOWNCASE, STRING-CAPITALIZE,
738 ;;; NSTRING-UPCASE, NSTRING-DOWNCASE, NSTRING-CAPITALIZE
739 (defmacro string-case-frob
(fn)
741 (assert (raises-error?
(,fn string
:start
0 :end
6)))
742 (assert (raises-error?
(,fn string
:start
(opaque-identity -
1) :end
5)))
743 (assert (raises-error?
(,fn string
:start
4 :end
2)))
744 (assert (raises-error?
(,fn string
:start
6 :end
9)))))
746 (sequence-bounding-indices-test
747 (format t
"~&/Function STRING-UPCASE, STRING-DOWNCASE, STRING-CAPITALIZE, ...")
748 (string-case-frob string-upcase
)
749 (string-case-frob string-downcase
)
750 (string-case-frob string-capitalize
)
751 (format t
"~&/... NSTRING-UPCASE, NSTRING-DOWNCASE, NSTRING-CAPITALIZE")
752 (string-case-frob nstring-upcase
)
753 (string-case-frob nstring-downcase
)
754 (string-case-frob nstring-capitalize
))
756 ;;; Function STRING=, STRING/=, STRING<, STRING>, STRING<=, STRING>=,
757 ;;; STRING-EQUAL, STRING-NOT-EQUAL, STRING-LESSP, STRING-GREATERP,
758 ;;; STRING-NOT-GREATERP, STRING-NOT-LESSP
759 (defmacro string-predicate-frob
(fn)
761 (,fn string
"abcde" :start1
0 :end1
5)
762 (,fn
"fghij" string
:start2
0 :end2 nil
)
763 (assert (raises-error?
(,fn string
"klmno"
765 (assert (raises-error?
(,fn
"pqrst" string
766 :start2
(opaque-identity -
1) :end2
5)))
767 (assert (raises-error?
(,fn
"uvwxy" string
769 (assert (raises-error?
(,fn string
"z" :start2
6 :end2
9)))))
770 (sequence-bounding-indices-test
771 (format t
"~&/Function STRING=, STRING/=, STRING<, STRING>, STRING<=, STRING>=, ...")
772 (string-predicate-frob string
=)
773 (string-predicate-frob string
/=)
774 (string-predicate-frob string
<)
775 (string-predicate-frob string
>)
776 (string-predicate-frob string
<=)
777 (string-predicate-frob string
>=))
778 (sequence-bounding-indices-test
779 (format t
"~&/... STRING-EQUAL, STRING-NOT-EQUAL, STRING-LESSP, ...")
780 (string-predicate-frob string-equal
)
781 (string-predicate-frob string-not-equal
)
782 (string-predicate-frob string-lessp
))
783 (sequence-bounding-indices-test
784 (format t
"~&/... STRING-GREATERP, STRING-NOT-GREATERP, STRING-NOT-LESSP")
785 (string-predicate-frob string-greaterp
)
786 (string-predicate-frob string-not-greaterp
)
787 (string-predicate-frob string-not-lessp
))
789 ;;; Function SUBSTITUTE, SUBSTITUTE-IF, SUBSTITUTE-IF-NOT,
790 ;;; NSUBSTITUTE, NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT
791 (sequence-bounding-indices-test
792 (format t
"~&/Function SUBSTITUTE, SUBSTITUTE-IF, SUBSTITUTE-IF-NOT, ...")
793 (assert (string= (substitute #\b #\a string
:start
0 :end
5) "bbbbb"))
794 (assert (string= (substitute #\c
#\a string
:start
0 :end nil
)
796 (assert (raises-error?
(substitute #\b #\a string
:start
0 :end
6)))
797 (assert (raises-error?
(substitute #\b #\a string
:start
(opaque-identity -
1) :end
5)))
798 (assert (raises-error?
(substitute #\b #\a string
:start
4 :end
2)))
799 (assert (raises-error?
(substitute #\b #\a string
:start
6 :end
9)))
800 (assert (string= (substitute-if #\b #'alpha-char-p string
803 (assert (string= (substitute-if #\c
#'alpha-char-p string
806 (assert (raises-error?
(substitute-if #\b #'alpha-char-p string
808 (assert (raises-error?
(substitute-if #\b #'alpha-char-p string
809 :start
(opaque-identity -
1) :end
5)))
810 (assert (raises-error?
(substitute-if #\b #'alpha-char-p string
812 (assert (raises-error?
(substitute-if #\b #'alpha-char-p string
814 (assert (string= (substitute-if-not #\b #'alpha-char-p string
817 (assert (string= (substitute-if-not #\c
#'alpha-char-p string
820 (assert (raises-error?
(substitute-if-not #\b #'alpha-char-p string
822 (assert (raises-error?
(substitute-if-not #\b #'alpha-char-p string
823 :start
(opaque-identity -
1) :end
5)))
824 (assert (raises-error?
(substitute-if-not #\b #'alpha-char-p string
826 (assert (raises-error?
(substitute-if-not #\b #'alpha-char-p string
828 (sequence-bounding-indices-test
829 (format t
"~&/... NSUBSTITUTE, NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT")
830 (assert (string= (nsubstitute #\b #\a string
:start
0 :end
5) "bbbbb"))
832 (assert (string= (nsubstitute #\c
#\a string
:start
0 :end nil
)
835 (assert (raises-error?
(nsubstitute #\b #\a string
:start
0 :end
6)))
837 (assert (raises-error?
(nsubstitute #\b #\a string
:start
(opaque-identity -
1) :end
5)))
839 (assert (raises-error?
(nsubstitute #\b #\a string
:start
4 :end
2)))
841 (assert (raises-error?
(nsubstitute #\b #\a string
:start
6 :end
9)))
843 (assert (string= (nsubstitute-if #\b #'alpha-char-p string
847 (assert (string= (nsubstitute-if #\c
#'alpha-char-p string
851 (assert (raises-error?
(nsubstitute-if #\b #'alpha-char-p string
854 (assert (raises-error?
(nsubstitute-if #\b #'alpha-char-p string
855 :start
(opaque-identity -
1) :end
5)))
857 (assert (raises-error?
(nsubstitute-if #\b #'alpha-char-p string
860 (assert (raises-error?
(nsubstitute-if #\b #'alpha-char-p string
863 (assert (string= (nsubstitute-if-not #\b #'alpha-char-p string
867 (assert (string= (nsubstitute-if-not #\c
#'alpha-char-p string
871 (assert (raises-error?
(nsubstitute-if-not #\b #'alpha-char-p string
874 (assert (raises-error?
(nsubstitute-if-not #\b #'alpha-char-p string
875 :start
(opaque-identity -
1) :end
5)))
877 (assert (raises-error?
(nsubstitute-if-not #\b #'alpha-char-p string
880 (assert (raises-error?
(nsubstitute-if-not #\b #'alpha-char-p string
882 ;;; Function WRITE-STRING, WRITE-LINE
883 (sequence-bounding-indices-test
884 (format t
"~&/Function WRITE-STRING, WRITE-LINE")
885 (write-string string
*standard-output
* :start
0 :end
5)
886 (write-string string
*standard-output
* :start
0 :end nil
)
887 (assert (raises-error?
(write-string string
*standard-output
*
889 (assert (raises-error?
(write-string string
*standard-output
*
890 :start
(opaque-identity -
1) :end
5)))
891 (assert (raises-error?
(write-string string
*standard-output
*
893 (assert (raises-error?
(write-string string
*standard-output
*
895 (write-line string
*standard-output
* :start
0 :end
5)
896 (write-line string
*standard-output
* :start
0 :end nil
)
897 (assert (raises-error?
(write-line string
*standard-output
*
899 (assert (raises-error?
(write-line string
*standard-output
*
900 :start
(opaque-identity -
1) :end
5)))
901 (assert (raises-error?
(write-line string
*standard-output
*
903 (assert (raises-error?
(write-line string
*standard-output
*
906 ;;; Macro WITH-INPUT-FROM-STRING
907 (sequence-bounding-indices-test
908 (format t
"~&/Macro WITH-INPUT-FROM-STRING")
909 (with-input-from-string (s string
:start
0 :end
5)
910 (assert (char= (read-char s
) #\a)))
911 (with-input-from-string (s string
:start
0 :end nil
)
912 (assert (char= (read-char s
) #\a)))
913 (assert (raises-error?
914 (with-input-from-string (s string
:start
0 :end
6)
916 (assert (raises-error?
917 (with-input-from-string (s string
:start
(opaque-identity -
1) :end
5)
919 (assert (raises-error?
920 (with-input-from-string (s string
:start
4 :end
2)
922 (assert (raises-error?
923 (with-input-from-string (s string
:start
6 :end
9)
926 ;;; testing bit-bashing according to _The Practice of Programming_
927 (defun fill-bytes-for-testing (bitsize)
928 "Return a list of 'bytes' of type (MOD BITSIZE)."
929 (remove-duplicates (list 0
930 (1- (ash 1 (1- bitsize
)))
932 (1- (ash 1 bitsize
)))))
934 (defun fill-with-known-value (value size
&rest vectors
)
935 (dolist (vec vectors
)
937 (setf (aref vec i
) value
))))
939 (defun collect-fill-amounts (n-power)
941 (loop for i from
0 upto n-power
942 collect
(1- (expt 2 i
))
944 collect
(1+ (expt 2 i
)))))
946 (defun test-fill-bashing (bitsize padding-amount n-power
)
947 (let* ((size (+ (* padding-amount
2) (expt 2 n-power
) (* padding-amount
2)))
948 (standard (make-array size
:element-type
`(unsigned-byte ,bitsize
)))
949 (bashed (make-array size
:element-type
`(unsigned-byte ,bitsize
)))
950 (fill-amounts (collect-fill-amounts n-power
))
951 (bash-function (intern (format nil
"UB~A-BASH-FILL" bitsize
)
952 (find-package "SB-KERNEL"))))
953 (format t
"~&/Function ~A..." bash-function
)
954 (loop for offset from padding-amount below
(* 2 padding-amount
) do
955 (dolist (c (fill-bytes-for-testing bitsize
))
956 (dolist (n fill-amounts
)
957 (fill-with-known-value (mod (lognot c
) (ash 1 bitsize
)) n
960 ;; a) the standard slow way
961 (locally (declare (notinline fill
))
962 (fill standard c
:start offset
:end
(+ offset n
)))
963 ;; b) the blazingly fast way
964 (let ((value (loop for i from
0 by bitsize
965 until
(= i sb-vm
:n-word-bits
)
967 (funcall bash-function value bashed offset n
))
969 (when (mismatch standard bashed
)
970 (format t
"Test with offset ~A, fill ~A and length ~A failed.~%"
972 (format t
"Mismatch: ~A ~A~%"
973 (subseq standard
0 (+ offset n
1))
974 (subseq bashed
0 (+ offset n
1)))
975 (return-from test-fill-bashing nil
))))
976 finally
(return t
))))
978 (defun test-copy-bashing (bitsize padding-amount n-power
)
979 (let* ((size (+ (* padding-amount
2) (expt 2 n-power
) (* padding-amount
2)))
980 (standard-dst (make-array size
:element-type
`(unsigned-byte ,bitsize
)))
981 (bashed-dst (make-array size
:element-type
`(unsigned-byte ,bitsize
)))
982 (source (make-array size
:element-type
`(unsigned-byte ,bitsize
)))
983 (fill-amounts (collect-fill-amounts n-power
))
984 (bash-function (intern (format nil
"UB~A-BASH-COPY" bitsize
)
985 (find-package "SB-KERNEL"))))
986 (format t
"~&/Function ~A..." bash-function
)
987 (do ((source-offset padding-amount
(1+ source-offset
)))
988 ((>= source-offset
(* padding-amount
2))
991 (do ((target-offset padding-amount
(1+ target-offset
)))
992 ((>= target-offset
(* padding-amount
2)))
993 (dolist (c (fill-bytes-for-testing bitsize
))
994 (dolist (n fill-amounts
)
995 (fill-with-known-value (mod (lognot c
) (ash 1 bitsize
)) size
996 source standard-dst bashed-dst
)
997 ;; fill with test data
998 (fill source c
:start source-offset
:end
(+ source-offset n
))
999 ;; copy filled test data to test vectors
1001 (replace standard-dst source
1002 :start1 target-offset
:end1
(+ target-offset n
)
1003 :start2 source-offset
:end2
(+ source-offset n
))
1004 ;; b) the blazingly fast way
1005 (funcall bash-function source source-offset
1006 bashed-dst target-offset n
)
1008 (when (mismatch standard-dst bashed-dst
)
1009 (format t
"Test with target-offset ~A, source-offset ~A, fill ~A, and length ~A failed.~%"
1010 target-offset source-offset c n
)
1011 (format t
"Mismatch:~% correct ~A~% actual ~A~%"
1014 (return-from test-copy-bashing nil
))))))))
1016 ;; Too slow for the interpreter
1017 #+#.
(cl:if
(cl:eq sb-ext
:*evaluator-mode
* :compile
) '(and) '(or))
1018 (loop for i
= 1 then
(* i
2) do
1019 ;; the bare '13' here is fairly arbitrary, except that it's been
1020 ;; reduced from '32', which made the tests take aeons; '8' provides
1021 ;; a good range of lengths over which to fill and copy, which
1022 ;; should tease out most errors in the code (if any exist). (It
1023 ;; also makes this part of the test suite finish reasonably
1025 (assert (time (test-fill-bashing i
13 8)))
1026 (assert (time (test-copy-bashing i
13 8)))
1027 until
(= i sb-vm
:n-word-bits
))
1029 (defun test-inlined-bashing (bitsize)
1030 ;; We have to compile things separately for each bitsize so the
1031 ;; compiler will work out the array type and trigger the REPLACE
1035 (let* ((n-elements-per-word ,(truncate sb-vm
:n-word-bits bitsize
))
1036 (size (* 3 n-elements-per-word
))
1037 (standard-dst (make-array size
:element-type
'(unsigned-byte ,bitsize
)))
1038 (bashed-dst (make-array size
:element-type
'(unsigned-byte ,bitsize
)))
1039 (source (make-array size
:element-type
'(unsigned-byte ,bitsize
))))
1040 (declare (type (simple-array (unsigned-byte ,bitsize
) (*))
1041 source standard-dst bashed-dst
))
1043 (offset n-elements-per-word
(1+ offset
)))
1044 ((>= offset
(* 2 n-elements-per-word
)) t
)
1045 (dolist (c (fill-bytes-for-testing ,bitsize
))
1046 (fill-with-known-value (mod (lognot c
) (ash 1 ,bitsize
)) size
1047 source standard-dst bashed-dst
)
1048 ;; fill with test-data
1049 (fill source c
:start offset
:end
(+ offset n-elements-per-word
))
1050 ;; copy filled data to test vectors
1052 ;; a) the slow way (which is actually fast, since this
1053 ;; should be transformed into UB*-BASH-COPY)
1054 (replace standard-dst source
1055 :start1
(- offset n-elements-per-word i
)
1056 :start2
(- offset n-elements-per-word i
)
1057 :end1 offset
:end2 offset
)
1058 ;; b) the fast way--we fold the
1059 ;; :START{1,2} arguments above ourselves
1060 ;; to trigger the REPLACE transform
1061 (replace bashed-dst source
1062 :start1
0 :start2
0 :end1 offset
:end2 offset
)
1064 (when (or (mismatch standard-dst bashed-dst
)
1065 ;; trigger COPY-SEQ transform
1066 (mismatch (copy-seq standard-dst
) bashed-dst
)
1067 ;; trigger SUBSEQ transform
1068 (mismatch (subseq standard-dst
(- offset n-elements-per-word i
))
1070 (format t
"Test with target-offset ~A, source-offset ~A, fill ~A, and length ~A failed.~%"
1072 (format t
"Mismatch:~% correct ~A~% actual ~A~%"
1075 (return-from nil nil
))))))))
1076 (funcall (compile nil lambda-form
))))
1078 #+#.
(cl:if
(cl:eq sb-ext
:*evaluator-mode
* :compile
) '(and) '(or))
1079 (loop for i
= 1 then
(* i
2) do
1080 (assert (test-inlined-bashing i
))
1081 until
(= i sb-vm
:n-word-bits
))
1083 ;;; tests from the Sacla test suite via Eric Marsden, 2007-05-07
1084 (remove-duplicates (vector 1 2 2 1) :test-not
(lambda (a b
) (not (= a b
))))
1086 (delete-duplicates (vector #\a #\b #\c
#\a)
1087 :test-not
(lambda (a b
) (not (char-equal a b
))))
1090 (let ((l (list 1 2 3)))
1091 (assert (eq l
(fill l
0 :start
1 :end
2)))
1092 (assert (equal l
'(1 0 3)))
1093 (assert (eq l
(fill l
'x
:start
2 :end
3)))
1094 (assert (equal l
'(1 0 x
)))
1095 (assert (eq l
(fill l
'y
:start
1)))
1096 (assert (equal l
'(1 y y
)))
1097 (assert (eq l
(fill l
'z
:end
2)))
1098 (assert (equal l
'(z z y
)))
1099 (assert (eq l
(fill l
1)))
1100 (assert (equal l
'(1 1 1)))
1101 (assert (raises-error?
(fill l
0 :start
4)))
1102 (assert (raises-error?
(fill l
0 :end
4)))
1103 (assert (raises-error?
(fill l
0 :start
2 :end
1))))
1105 ;;; Both :TEST and :TEST-NOT provided
1106 (with-test (:name
:test-and-test-not-to-adjoin
)
1109 (handler-bind (((and warning
(not style-warning
))
1110 (lambda (w) (incf wc
))))
1111 (compile nil
`(lambda (item test test-not
) (adjoin item
'(1 2 3 :foo
)
1113 :test-not test-not
))))))
1117 (funcall fun
1 #'eql
(complement #'eql
))