1 ;;;; tests related to sequences
3 ;;;; This file is impure because we want to be able to use DEFUN.
5 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; While most of SBCL is derived from the CMU CL system, the test
9 ;;;; files (like this one) were written from scratch after the fork
12 ;;;; This software is in the public domain and is provided with
13 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
14 ;;;; more information.
18 ;;; user-defined mock sequence class for testing generic versions of
19 ;;; sequence functions.
20 (defclass list-backed-sequence
(standard-object
22 ((elements :initarg
:elements
:type list
:accessor %elements
)))
24 (defmethod sequence:make-sequence-like
((sequence list-backed-sequence
) length
26 initial-element initial-contents
)
27 (declare (ignore initial-element initial-contents
))
28 (make-instance 'list-backed-sequence
29 :elements
(apply #'sequence
:make-sequence-like
32 (defmethod sequence:length
((sequence list-backed-sequence
))
33 (length (%elements sequence
)))
35 (defmethod sequence:elt
36 ((sequence list-backed-sequence
) index
)
37 (nth index
(%elements sequence
)))
39 (defmethod (setf sequence
:elt
)
40 (new-value (sequence list-backed-sequence
) index
)
41 (setf (nth index
(%elements sequence
)) new-value
))
43 ;;; helper functions for exercising SEQUENCE code on data of many
44 ;;; specialized types, and in many different optimization scenarios
45 (defun for-every-seq-1 (base-seq snippet
)
48 (every (lambda (el) (typep el eltype
)) base-seq
))
49 (make-sequence-for-type (type)
51 ((member list list-backed-sequence
)
52 (coerce base-seq type
))
53 ((cons (eql simple-array
) (cons * (cons (eql 1) null
)))
54 (destructuring-bind (eltype one
) (rest type
)
55 (declare (ignore one
))
56 (when (entirely eltype
)
57 (coerce base-seq type
))))
59 (destructuring-bind (eltype) (rest type
)
60 (when (entirely eltype
)
61 (let ((initial-element
62 (cond ((subtypep eltype
'character
)
64 ((subtypep eltype
'number
)
76 (dolist (seq-type '(list
79 (simple-array character
1)
81 (simple-array (signed-byte 4) 1)
82 (vector (signed-byte 4))
83 list-backed-sequence
))
84 (dolist (declaredness '(nil t
))
85 (map-optimize-declarations
86 (lambda (optimization)
87 (let ((seq (make-sequence-for-type seq-type
))
88 (lambda-expr `(lambda (seq)
89 (declare (sb-ext:muffle-conditions
90 sb-ext
:compiler-note
))
92 `((declare (type ,seq-type seq
))))
93 (declare (optimize ,@optimization
))
97 ;(format t "~&~S~%" lambda-expr)
98 (let ((fun (checked-compile lambda-expr
:allow-style-warnings t
)))
99 ;(format t "~&~S ~S~%~S~%~S ~S~%"
100 ; base-seq snippet seq-type declaredness optimization)
101 ;(format t "~&(TYPEP SEQ 'SIMPLE-ARRAY)=~S~%"
102 ; (typep seq 'simple-array))
103 (unless (funcall fun seq
)
104 (error "~@<failed test:~2I ~_BASE-SEQ=~S ~_SNIPPET=~S ~_SEQ-TYPE=~S ~_DECLAREDNESS=~S ~_OPTIMIZATION=~S~:@>"
110 :safety nil
:debug nil
:compilation-speed nil
)))))
111 (defun for-every-seq (base-seq snippets
)
112 (dolist (snippet snippets
)
113 (for-every-seq-1 base-seq snippet
)))
115 ;;; a wrapper to hide declared type information from the compiler, so
116 ;;; we don't get stopped by compiler warnings about e.g. compiling
117 ;;; (POSITION 1 #() :KEY #'ABS) when #() has been coerced to a string.
118 (defun indiscriminate (fun)
119 (lambda (&rest rest
) (apply fun rest
)))
121 ;;; asymmetric test arg order example from ANSI FIND definition page
122 (assert (eql #\space
; original example, depends on ASCII character ordering
123 (find #\d
"here are some letters that can be looked at"
125 (assert (eql #\e
; modified example, depends only on standard a-z ordering
126 (find #\f "herearesomeletters" :test
#'char
>)))
127 (assert (eql 4 ; modified more, avoids charset technicalities completely
128 (find 5 '(6 4) :test
'>)))
130 (with-test (:name sequence
:emptyp
)
132 '((eq t
(sequence:emptyp seq
))))
134 '((eq nil
(sequence:emptyp seq
)))))
136 ;;; tests of FIND, POSITION, FIND-IF, and POSITION-IF (and a few for
137 ;;; deprecated FIND-IF-NOT and POSITION-IF-NOT too)
139 (with-test (:name
:seq
.1)
141 '((null (find 1 seq
))
142 (null (find 1 seq
:from-end t
))
143 (null (position 1 seq
:key
(indiscriminate #'abs
)))
144 (null (position nil seq
:test
(constantly t
)))
145 (null (position nil seq
:test nil
))
146 (null (position nil seq
:test-not nil
))
147 (null (find-if #'1+ seq
:key
(indiscriminate #'log
)))
148 (null (position-if #'identity seq
:from-end t
))
149 (null (find-if-not #'packagep seq
))
150 (null (position-if-not #'packagep seq
:key nil
)))))
152 (with-test (:name
:seq
.2)
154 '((null (find 2 seq
))
155 ;; Get the argument ordering for asymmetric tests like #'> right.
156 ;; (bug reported and fixed by Alexey Dejneka sbcl-devel 2001-10-17)
157 (eql 1 (find 2 seq
:test
#'>))
158 (find 2 seq
:key
#'1+)
159 (find 1 seq
:from-end t
)
160 (null (find 1 seq
:from-end t
:start
1))
161 (null (find 0 seq
:from-end t
))
162 (eql 0 (position 1 seq
:key
#'abs
))
163 (null (position nil seq
:test
'equal
))
164 (eql 1 (find-if #'1- seq
:key
#'log
))
165 (eql 0 (position-if #'identity seq
:from-end t
))
166 (null (find-if-not #'sin seq
))
167 (eql 0 (position-if-not #'packagep seq
:key
'identity
)))))
169 (with-test (:name
:seq
.3)
170 (for-every-seq #(1 2 3 2 1)
172 (find 3 seq
:from-end
'yes
)
173 (eql 1 (position 1.5 seq
:test
#'<))
174 (eql 0 (position 0 seq
:key
'1-
))
175 (eql 4 (position 0 seq
:key
'1-
:from-end t
))
176 (eql 2 (position 4 seq
:key
'1+))
177 (eql 2 (position 4 seq
:key
'1+ :from-end t
))
178 (eql 1 (position 2 seq
))
179 (eql 1 (position 2 seq
:start
1))
180 (null (find 2 seq
:start
1 :end
1))
181 (eql 3 (position 2 seq
:start
2))
182 (eql 3 (position 2 seq
:key nil
:from-end t
))
183 (eql 2 (position 3 seq
:test
'=))
184 (eql 0 (position 3 seq
:test-not
'equalp
))
185 (eql 2 (position 3 seq
:test
'equal
:from-end t
))
186 (null (position 4 seq
:test
#'eql
))
187 (null (find-if #'packagep seq
))
188 (eql 1 (find-if #'plusp seq
))
189 (eql 3 (position-if #'plusp seq
:key
#'1-
:from-end t
))
190 (eql 1 (position-if #'evenp seq
))
191 (eql 3 (position-if #'evenp seq
:from-end t
))
192 (eql 2 (position-if #'plusp seq
:from-end nil
:key
'1-
:start
2))
193 (eql 3 (position-if #'plusp seq
:from-end t
:key
'1-
:start
2))
194 (null (position-if #'plusp seq
:from-end t
:key
'1-
:start
2 :end
2))
195 (null (find-if-not #'plusp seq
))
196 (eql 0 (position-if-not #'evenp seq
))
197 (eql 0 (search #(1) seq
))
198 (eql 1 (search #(4 5) seq
:key
'oddp
))
199 (eql 1 (search #(-2) seq
:test
(lambda (a b
) (= (- a
) b
))))
200 (eql 4 (search #(1) seq
:start2
1))
201 (null (search #(3) seq
:start2
3))
202 (eql 2 (search #(3) seq
:start2
2))
203 (eql 0 (search #(1 2) seq
))
204 (null (search #(2 1 3) seq
))
205 (eql 0 (search #(0 1 2 4) seq
:start1
1 :end1
3))
206 (eql 3 (search #(0 2 1 4) seq
:start1
1 :end1
3))
207 (eql 4 (search #(1) seq
:from-end t
))
208 (eql 0 (search #(1 2) seq
:from-end t
))
209 (null (search #(1 2) seq
:from-end t
:start2
1))
210 (eql 0 (search #(0 1 2 4) seq
:from-end t
:start1
1 :end1
3))
211 (eql 3 (search #(0 2 1 4) seq
:from-end t
:start1
1 :end1
3))
212 (null (search #(2 1 3) seq
:from-end t
)))))
214 (with-test (:name
:seq
.4)
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
)))))
232 (with-test (:name
:subseq
)
233 (let ((avec (make-array 10
235 :initial-contents
'(0 1 2 3 iv v vi vii iix ix
))))
236 ;; These first five always worked AFAIK.
237 (assert (equalp (subseq avec
0 3) #(0 1 2)))
238 (assert (equalp (subseq avec
3 3) #()))
239 (assert (equalp (subseq avec
1 3) #(1 2)))
240 (assert (equalp (subseq avec
1) #(1 2 3)))
241 (assert (equalp (subseq avec
1 4) #(1 2 3)))
242 ;; SBCL bug found ca. 2002-05-01 by OpenMCL's correct handling of
243 ;; SUBSEQ, CSR's driving portable cross-compilation far enough to
244 ;; reach the SUBSEQ calls in assem.lisp, and WHN's sleazy
245 ;; translation of old CMU CL new-assem.lisp into sufficiently grotty
246 ;; portable Lisp that it passed suitable illegal values to SUBSEQ to
247 ;; exercise the bug:-|
249 ;; SUBSEQ should check its END value against logical LENGTH, not
250 ;; physical ARRAY-DIMENSION 0.
252 ;; fixed in sbcl-0.7.4.22 by WHN
253 (assert (null (ignore-errors (aref (subseq avec
1 5) 0))))))
255 (with-test (:name
:fill-typecheck
)
256 (checked-compile-and-assert
259 (fill (make-string 10) x
))
260 ((#\
@) "@@@@@@@@@@" :test
#'equal
)
261 ;; BUG 186, fixed in sbcl-0.7.5.5
262 ((4097) (condition 'type-error
))))
264 ;;; MAKE-SEQUENCE, COERCE, CONCATENATE, MERGE, MAP and requested
265 ;;; result type (BUGs 46a, 46b, 66)
266 (with-test (:name
:sequence-functions
)
267 (macrolet ((assert-type-error (form)
268 `(assert-error ,form type-error
)))
269 (dolist (type-stub '((simple-vector)
271 (vector (signed-byte 8))
272 (vector (unsigned-byte 16))
273 (vector (signed-byte 32))
274 (simple-bit-vector)))
275 (declare (optimize safety
))
277 (assert (= (length (make-sequence `(,@type-stub
) 10)) 10))
278 (assert (= (length (make-sequence `(,@type-stub
10) 10)) 10))
279 (assert-type-error (make-sequence `(,@type-stub
10) 11))
281 (assert (= (length (coerce '(0 0 0) `(,@type-stub
))) 3))
282 (assert (= (length (coerce #(0 0 0) `(,@type-stub
3))) 3))
283 (assert-type-error (coerce #*111 `(,@type-stub
4)))
285 (assert (= (length (concatenate `(,@type-stub
) #(0 0 0) #*111)) 6))
286 (assert (equalp (concatenate `(,@type-stub
) #(0 0 0) #*111)
287 (coerce #(0 0 0 1 1 1) `(,@type-stub
))))
288 (assert (= (length (concatenate `(,@type-stub
6) #(0 0 0) #*111)) 6))
289 (assert (equalp (concatenate `(,@type-stub
6) #(0 0 0) #*111)
290 (coerce #(0 0 0 1 1 1) `(,@type-stub
6))))
291 (assert-type-error (concatenate `(,@type-stub
5) #(0 0 0) #*111))
293 (macrolet ((test (type)
294 `(merge ,type
(copy-seq #(0 1 0)) (copy-seq #*111) #'>)))
295 (assert (= (length (test `(,@type-stub
))) 6))
296 (assert (equalp (test `(,@type-stub
))
297 (coerce #(1 1 1 0 1 0) `(,@type-stub
))))
298 (assert (= (length (test `(,@type-stub
6))) 6))
299 (assert (equalp (test `(,@type-stub
6))
300 (coerce #(1 1 1 0 1 0) `(,@type-stub
6))))
301 (assert-type-error (test `(,@type-stub
4))))
303 (assert (= (length (map `(,@type-stub
) #'logxor
#(0 0 1 1) '(0 1 0 1))) 4))
304 (assert (equalp (map `(,@type-stub
) #'logxor
#(0 0 1 1) '(0 1 0 1))
305 (coerce #(0 1 1 0) `(,@type-stub
))))
306 (assert (= (length (map `(,@type-stub
4) #'logxor
#(0 0 1 1) '(0 1 0 1)))
308 (assert (equalp (map `(,@type-stub
4) #'logxor
#(0 0 1 1) '(0 1 0 1))
309 (coerce #(0 1 1 0) `(,@type-stub
4))))
310 (assert-type-error (map `(,@type-stub
5) #'logxor
#(0 0 1 1) '(0 1 0 1))))
311 ;; some more CONCATENATE tests for strings
313 (declare (optimize safety
))
314 (assert (string= (concatenate 'string
"foo" " " "bar") "foo bar"))
315 (assert (string= (concatenate '(string 7) "foo" " " "bar") "foo bar"))
316 (assert-type-error (concatenate '(string 6) "foo" " " "bar"))
317 (assert (string= (concatenate '(string 6) "foo" #(#\b #\a #\r)) "foobar"))
318 (assert (string= (concatenate '(string 6) #(#\b #\a #\r) "foo") "barfoo"))
319 (assert-type-error (concatenate '(string 7) "foo" #(#\b #\a #\r))))
320 ;; Non-VECTOR ARRAY types aren't allowed as vector type specifiers.
322 (declare (optimize safety
))
323 (assert-type-error (concatenate 'simple-array
"foo" "bar"))
324 (assert-type-error (map 'simple-array
#'identity
'(1 2 3)))
325 (assert (equalp #(11 13)
326 (map '(simple-array fixnum
(*)) #'+ '(1 2 3) '(10 11))))
327 (assert-type-error (coerce '(1 2 3) 'simple-array
))
328 (assert-type-error (merge 'simple-array
(list 1 3) (list 2 4) '<))
329 (assert (equalp #(3 2 1) (coerce '(3 2 1) '(vector fixnum
))))
330 (assert-type-error (map 'array
#'identity
'(1 2 3)))
331 (assert-type-error (map '(array fixnum
) #'identity
'(1 2 3)))
332 (assert (equalp #(1 2 3) (coerce '(1 2 3) '(vector fixnum
))))
333 ;; but COERCE has an exemption clause:
334 (assert (string= "foo" (coerce "foo" 'simple-array
)))
335 ;; ... though not in all cases.
336 (assert-type-error (coerce '(#\f #\o
#\o
) 'simple-array
)))))
338 ;; CONCATENATE used to fail for generic sequences for result-type NULL.
339 (with-test (:name
(concatenate :result-type-null
:bug-1162301
))
340 (assert (sequence:emptyp
(concatenate 'null
)))
343 '((sequence:emptyp
(concatenate 'null seq
))
344 (sequence:emptyp
(concatenate 'null seq seq
))
345 (sequence:emptyp
(concatenate 'null seq
#()))
346 (sequence:emptyp
(concatenate 'null seq
""))))
349 (mapcar (lambda (form)
350 `(typep (nth-value 1 (ignore-errors ,form
)) 'type-error
))
351 '((concatenate 'null seq
)
352 (concatenate 'null seq seq
)
353 (concatenate 'null seq
#())
354 (concatenate 'null seq
"2")))))
356 ;;; As pointed out by Raymond Toy on #lisp IRC, MERGE had some issues
357 ;;; with user-defined types until sbcl-0.7.8.11
358 (deftype list-typeoid
() 'list
)
359 (with-test (:name
:merge-user-types
)
360 (assert (equal '(1 2 3 4) (merge 'list-typeoid
(list 1 3) (list 2 4) '<)))
361 ;; and also with types that weren't precicely LIST
362 (assert (equal '(1 2 3 4) (merge 'cons
(list 1 3) (list 2 4) '<))))
364 ;;; but wait, there's more! The NULL and CONS types also have implicit
365 ;;; length requirements:
366 (with-test (:name
:sequence-functions-list-types
)
367 (macrolet ((assert-type-error (form)
368 `(assert (typep (nth-value 1 (ignore-errors ,form
))
371 (declare (optimize safety
))
373 (assert-type-error (make-sequence 'cons
0))
374 (assert-type-error (make-sequence 'null
1))
375 (assert-type-error (make-sequence '(cons t null
) 0))
376 (assert-type-error (make-sequence '(cons t null
) 2))
377 ;; KLUDGE: I'm not certain that this test actually tests for what
378 ;; it should test, in that the type deriver and optimizers might
379 ;; be too smart for the good of an exhaustive test system.
380 ;; However, it makes me feel good. -- CSR, 2002-10-18
381 (assert (null (make-sequence 'null
0)))
382 (assert (= (length (make-sequence 'cons
3)) 3))
383 (assert (= (length (make-sequence '(cons t null
) 1)) 1))
384 ;; and NIL is not a valid type for MAKE-SEQUENCE
385 (assert-type-error (make-sequence 'nil
0))
387 (assert-type-error (coerce #(1) 'null
))
388 (assert-type-error (coerce #() 'cons
))
389 (assert-type-error (coerce #() '(cons t null
)))
390 (assert-type-error (coerce #(1 2) '(cons t null
)))
391 (assert (null (coerce #() 'null
)))
392 (assert (= (length (coerce #(1) 'cons
)) 1))
393 (assert (= (length (coerce #(1) '(cons t null
))) 1))
394 (assert-type-error (coerce #() 'nil
))
396 (assert-type-error (merge 'null
(list 1 3) (list 2 4) '<))
397 (assert-type-error (merge 'cons
() () '<))
398 (assert (null (merge 'null
() () '<)))
399 (assert (= (length (merge 'cons
(list 1 3) (list 2 4) '<)) 4))
400 (assert (= (length (merge '(cons t
(cons t
(cons t
(cons t null
))))
401 (list 1 3) (list 2 4)
404 (assert-type-error (merge 'nil
() () '<))
406 (assert-type-error (concatenate 'cons
#() ()))
407 (assert-type-error (concatenate '(cons t null
) #(1 2 3) #(4 5 6)))
408 (assert (= (length (concatenate 'cons
#() '(1) "2 3")) 4))
409 (assert (= (length (concatenate '(cons t cons
) '(1) "34")) 3))
410 (assert-type-error (concatenate 'nil
'(3)))
411 ;; FIXME: tests for MAP to come when some brave soul implements
412 ;; the analogous type checking for MAP/%MAP.
415 ;;; ELT should signal an error of type TYPE-ERROR if its index
416 ;;; argument isn't a valid sequence index for sequence:
417 (with-test (:name
:elt-signal
)
418 (checked-compile-and-assert
420 `(lambda (x) (elt x
3))
421 (("foo") (condition 'type-error
))
424 (declare (optimize (safety 3)))
425 (assert-error (elt (list 1 2 3) 3) type-error
)))
427 ;;; confusion in the refactoring led to this signalling an unbound
428 ;;; variable, not a type error.
429 (with-test (:name
:svref-type-error
)
430 (checked-compile-and-assert
432 `(lambda (x) (svref x
0))
433 ((#*0) (condition 'type-error
))))
435 ;;; checks for uniform bounding index handling.
437 ;;; This used to be SAFETY 3 only, but bypassing these checks with
438 ;;; above-zero speed when SPEED > SAFETY is not The SBCL Way.
440 ;;; KLUDGE: not all in one big form because that causes SBCL to spend
441 ;;; an absolute age trying to compile it.
442 (defmacro sequence-bounding-indices-test
(&body body
)
445 ;; See Issues 332 [and 333(!)] in the CLHS
446 (declare (optimize (speed 3) (safety 1)))
447 (let ((string (make-array 10
450 :element-type
'base-char
)))
453 (setf (fill-pointer string
) 10)
455 (setf (fill-pointer string
) 5)))
456 (declare (ignorable #'reset
))
459 ;; See Issues 332 [and 333(!)] in the CLHS
460 (declare (optimize (speed 3) (safety 1)))
461 (let ((string (make-array 10
464 :element-type
'character
)))
467 (setf (fill-pointer string
) 10)
469 (setf (fill-pointer string
) 5)))
470 (declare (ignorable #'reset
))
473 (with-test (:name
(:bounding-index subseq
))
474 (sequence-bounding-indices-test
475 (assert (string= (subseq string
0 5) "aaaaa"))
476 (assert-error (subseq string
0 6))
477 (assert-error (subseq string
(opaque-identity -
1) 5))
478 (assert-error (subseq string
4 2))
479 (assert-error (subseq string
6))
480 (assert (string= (setf (subseq string
0 5) "abcde") "abcde"))
481 (assert (string= (subseq string
0 5) "abcde"))
483 (assert-error (setf (subseq string
0 6) "abcdef"))
484 (assert-error (setf (subseq string
(opaque-identity -
1) 5) "abcdef"))
485 (assert-error (setf (subseq string
4 2) ""))
486 (assert-error (setf (subseq string
6) "ghij"))))
488 (with-test (:name
(:bounding-index count
))
489 (sequence-bounding-indices-test
490 (assert (= (count #\a string
:start
0 :end nil
) 5))
491 (assert (= (count #\a string
:start
0 :end
5) 5))
492 (assert-error (count #\a string
:start
0 :end
6))
493 (assert-error (count #\a string
:start
(opaque-identity -
1) :end
5))
494 (assert-error (count #\a string
:start
4 :end
2))
495 (assert-error (count #\a string
:start
6 :end
9))
496 (assert (= (count-if #'alpha-char-p string
:start
0 :end nil
) 5))
497 (assert (= (count-if #'alpha-char-p string
:start
0 :end
5) 5))
499 (count-if #'alpha-char-p string
:start
0 :end
6))
501 (count-if #'alpha-char-p string
:start
(opaque-identity -
1) :end
5))
503 (count-if #'alpha-char-p string
:start
4 :end
2))
505 (count-if #'alpha-char-p string
:start
6 :end
9))
506 (assert (= (count-if-not #'alpha-char-p string
:start
0 :end nil
) 0))
507 (assert (= (count-if-not #'alpha-char-p string
:start
0 :end
5) 0))
509 (count-if-not #'alpha-char-p string
:start
0 :end
6))
511 (count-if-not #'alpha-char-p string
:start
(opaque-identity -
1) :end
5))
513 (count-if-not #'alpha-char-p string
:start
4 :end
2))
515 (count-if-not #'alpha-char-p string
:start
6 :end
9))))
517 (with-test (:name
(:bounding-index fill
))
518 (sequence-bounding-indices-test
519 (assert (string= (fill string
#\b :start
0 :end
5) "bbbbb"))
520 (assert (string= (fill string
#\c
:start
0 :end nil
) "ccccc"))
521 (assert-error (fill string
#\d
:start
0 :end
6))
522 (assert-error (fill string
#\d
:start
(opaque-identity -
1) :end
5))
523 (assert-error (fill string
#\d
:start
4 :end
2))
524 (assert-error (fill string
#\d
:start
6 :end
9))))
526 (with-test (:name
(:bounding-index find
))
527 (sequence-bounding-indices-test
528 (assert (char= (find #\a string
:start
0 :end nil
) #\a))
529 (assert (char= (find #\a string
:start
0 :end
5) #\a))
530 (assert-error (find #\a string
:start
0 :end
6))
531 (assert-error (find #\a string
:start
(opaque-identity -
1) :end
5))
532 (assert-error (find #\a string
:start
4 :end
2))
533 (assert-error (find #\a string
:start
6 :end
9))
534 (assert (char= (find-if #'alpha-char-p string
:start
0 :end nil
) #\a))
535 (assert (char= (find-if #'alpha-char-p string
:start
0 :end
5) #\a))
537 (find-if #'alpha-char-p string
:start
0 :end
6))
539 (find-if #'alpha-char-p string
:start
(opaque-identity -
1) :end
5))
541 (find-if #'alpha-char-p string
:start
4 :end
2))
543 (find-if #'alpha-char-p string
:start
6 :end
9))
544 (assert (eq (find-if-not #'alpha-char-p string
:start
0 :end nil
) nil
))
545 (assert (eq (find-if-not #'alpha-char-p string
:start
0 :end
5) nil
))
547 (find-if-not #'alpha-char-p string
:start
0 :end
6))
549 (find-if-not #'alpha-char-p string
:start
(opaque-identity -
1) :end
5))
551 (find-if-not #'alpha-char-p string
:start
4 :end
2))
553 (find-if-not #'alpha-char-p string
:start
6 :end
9))))
555 (with-test (:name
(:bounding-index mismatch
))
556 (sequence-bounding-indices-test
557 (assert (null (mismatch string
"aaaaa" :start1
0 :end1 nil
)))
558 (assert (= (mismatch "aaab" string
:start2
0 :end2
4) 3))
559 (assert-error (mismatch "aaaaaa" string
:start2
0 :end2
6))
560 (assert-error (mismatch string
"aaaaaa" :start1
(opaque-identity -
1) :end1
5))
561 (assert-error (mismatch string
"" :start1
4 :end1
2))
562 (assert-error (mismatch "aaaa" string
:start2
6 :end2
9))))
564 (with-test (:name
(:bounding-index parse-integer
))
565 (sequence-bounding-indices-test
566 (setf (fill-pointer string
) 10)
567 (setf (subseq string
0 10) "1234567890")
568 (setf (fill-pointer string
) 5)
569 (assert (= (parse-integer string
:start
0 :end
5) 12345))
570 (assert (= (parse-integer string
:start
0 :end nil
) 12345))
571 (assert-error (parse-integer string
:start
0 :end
6))
572 (assert-error (parse-integer string
:start
(opaque-identity -
1) :end
5))
573 (assert-error (parse-integer string
:start
4 :end
2))
574 (assert-error (parse-integer string
:start
6 :end
9))))
576 (with-test (:name
(:bounding-index parse-namestring
))
577 (sequence-bounding-indices-test
578 (setf (fill-pointer string
) 10)
579 (setf (subseq string
0 10)
582 (setf (fill-pointer string
) 5)
583 (assert (truename (parse-namestring string nil
*default-pathname-defaults
*
585 (assert (truename (parse-namestring string nil
*default-pathname-defaults
*
587 (assert-error (parse-namestring string nil
588 *default-pathname-defaults
*
590 (assert-error (parse-namestring string nil
591 *default-pathname-defaults
*
592 :start
(opaque-identity -
1) :end
5))
593 (assert-error (parse-namestring string nil
594 *default-pathname-defaults
*
596 (assert-error (parse-namestring string nil
597 *default-pathname-defaults
*
600 (with-test (:name
(:bounding-index position
))
601 (sequence-bounding-indices-test
602 (assert (= (position #\a string
:start
0 :end nil
) 0))
603 (assert (= (position #\a string
:start
0 :end
5) 0))
604 (assert-error (position #\a string
:start
0 :end
6))
605 (assert-error (position #\a string
:start
(opaque-identity -
1) :end
5))
606 (assert-error (position #\a string
:start
4 :end
2))
607 (assert-error (position #\a string
:start
6 :end
9))
608 (assert (= (position-if #'alpha-char-p string
:start
0 :end nil
) 0))
609 (assert (= (position-if #'alpha-char-p string
:start
0 :end
5) 0))
611 (position-if #'alpha-char-p string
:start
0 :end
6))
613 (position-if #'alpha-char-p string
:start
(opaque-identity -
1) :end
5))
615 (position-if #'alpha-char-p string
:start
4 :end
2))
617 (position-if #'alpha-char-p string
:start
6 :end
9))
618 (assert (eq (position-if-not #'alpha-char-p string
:start
0 :end nil
) nil
))
619 (assert (eq (position-if-not #'alpha-char-p string
:start
0 :end
5) nil
))
621 (position-if-not #'alpha-char-p string
:start
0 :end
6))
623 (position-if-not #'alpha-char-p string
:start
(opaque-identity -
1) :end
5))
625 (position-if-not #'alpha-char-p string
:start
4 :end
2))
627 (position-if-not #'alpha-char-p string
:start
6 :end
9))))
629 (with-test (:name
(:bounding-index read-from-string
))
630 (sequence-bounding-indices-test
631 (setf (subseq string
0 5) "(a b)")
632 (assert (equal (read-from-string string nil nil
:start
0 :end
5) '(a b
)))
633 (assert (equal (read-from-string string nil nil
:start
0 :end nil
) '(a b
)))
634 (assert-error (read-from-string string nil nil
:start
0 :end
6))
635 (assert-error (read-from-string string nil nil
:start
(opaque-identity -
1) :end
5))
636 (assert-error (read-from-string string nil nil
:start
4 :end
2))
637 (assert-error (read-from-string string nil nil
:start
6 :end
9))))
639 (with-test (:name
(:bounding-index reduce
))
640 (sequence-bounding-indices-test
641 (setf (subseq string
0 5) "abcde")
642 (assert (equal (reduce #'list
* string
:from-end t
:start
0 :end nil
)
643 '(#\a #\b #\c
#\d .
#\e
)))
644 (assert (equal (reduce #'list
* string
:from-end t
:start
0 :end
5)
645 '(#\a #\b #\c
#\d .
#\e
)))
646 (assert-error (reduce #'list
* string
:start
0 :end
6))
647 (assert-error (reduce #'list
* string
:start
(opaque-identity -
1) :end
5))
648 (assert-error (reduce #'list
* string
:start
4 :end
2))
649 (assert-error (reduce #'list
* string
:start
6 :end
9))))
651 (with-test (:name
(:bounding-index remove
))
652 (sequence-bounding-indices-test
653 (assert (equal (remove #\a string
:start
0 :end nil
) ""))
654 (assert (equal (remove #\a string
:start
0 :end
5) ""))
655 (assert-error (remove #\a string
:start
0 :end
6))
656 (assert-error (remove #\a string
:start
(opaque-identity -
1) :end
5))
657 (assert-error (remove #\a string
:start
4 :end
2))
658 (assert-error (remove #\a string
:start
6 :end
9))
659 (assert (equal (remove-if #'alpha-char-p string
:start
0 :end nil
) ""))
660 (assert (equal (remove-if #'alpha-char-p string
:start
0 :end
5) ""))
662 (remove-if #'alpha-char-p string
:start
0 :end
6))
664 (remove-if #'alpha-char-p string
:start
(opaque-identity -
1) :end
5))
666 (remove-if #'alpha-char-p string
:start
4 :end
2))
668 (remove-if #'alpha-char-p string
:start
6 :end
9))
669 (assert (equal (remove-if-not #'alpha-char-p string
:start
0 :end nil
)
671 (assert (equal (remove-if-not #'alpha-char-p string
:start
0 :end
5)
674 (remove-if-not #'alpha-char-p string
:start
0 :end
6))
676 (remove-if-not #'alpha-char-p string
:start
(opaque-identity -
1) :end
5))
678 (remove-if-not #'alpha-char-p string
:start
4 :end
2))
680 (remove-if-not #'alpha-char-p string
:start
6 :end
9))))
682 (with-test (:name
(:bounding-index delete
))
683 (sequence-bounding-indices-test
684 (assert (equal (delete #\a string
:start
0 :end nil
) ""))
686 (assert (equal (delete #\a string
:start
0 :end
5) ""))
688 (assert-error (delete #\a string
:start
0 :end
6))
690 (assert-error (delete #\a string
:start
(opaque-identity -
1) :end
5))
692 (assert-error (delete #\a string
:start
4 :end
2))
694 (assert-error (delete #\a string
:start
6 :end
9))
696 (assert (equal (delete-if #'alpha-char-p string
:start
0 :end nil
) ""))
698 (assert (equal (delete-if #'alpha-char-p string
:start
0 :end
5) ""))
701 (delete-if #'alpha-char-p string
:start
0 :end
6))
704 (delete-if #'alpha-char-p string
:start
(opaque-identity -
1) :end
5))
707 (delete-if #'alpha-char-p string
:start
4 :end
2))
710 (delete-if #'alpha-char-p string
:start
6 :end
9))
712 (assert (equal (delete-if-not #'alpha-char-p string
:start
0 :end nil
)
715 (assert (equal (delete-if-not #'alpha-char-p string
:start
0 :end
5)
719 (delete-if-not #'alpha-char-p string
:start
0 :end
6))
722 (delete-if-not #'alpha-char-p string
:start
(opaque-identity -
1) :end
5))
725 (delete-if-not #'alpha-char-p string
:start
4 :end
2))
728 (delete-if-not #'alpha-char-p string
:start
6 :end
9))))
730 (with-test (:name
(:bounding-index remove-duplicates
))
731 (sequence-bounding-indices-test
732 (assert (string= (remove-duplicates string
:start
0 :end
5) "a"))
733 (assert (string= (remove-duplicates string
:start
0 :end nil
) "a"))
734 (assert-error (remove-duplicates string
:start
0 :end
6))
735 (assert-error (remove-duplicates string
:start
(opaque-identity -
1) :end
5))
736 (assert-error (remove-duplicates string
:start
4 :end
2))
737 (assert-error (remove-duplicates string
:start
6 :end
9))
738 (assert (string= (delete-duplicates string
:start
0 :end
5) "a"))
740 (assert (string= (delete-duplicates string
:start
0 :end nil
) "a"))
742 (assert-error (delete-duplicates string
:start
0 :end
6))
744 (assert-error (delete-duplicates string
:start
(opaque-identity -
1) :end
5))
746 (assert-error (delete-duplicates string
:start
4 :end
2))
748 (assert-error (delete-duplicates string
:start
6 :end
9))))
750 (with-test (:name
(:bounding-index replace
))
751 (sequence-bounding-indices-test
752 (assert (string= (replace string
"bbbbb" :start1
0 :end1
5) "bbbbb"))
753 (assert (string= (replace (copy-seq "ccccc")
755 :start2
0 :end2 nil
) "bbbbb"))
756 (assert-error (replace string
"ccccc" :start1
0 :end1
6))
757 (assert-error (replace string
"ccccc" :start2
(opaque-identity -
1) :end2
5))
758 (assert-error (replace string
"ccccc" :start1
4 :end1
2))
759 (assert-error (replace string
"ccccc" :start1
6 :end1
9))))
761 (with-test (:name
(:bounding-index search
))
762 (sequence-bounding-indices-test
763 (assert (= (search "aa" string
:start2
0 :end2
5) 0))
764 (assert (null (search string
"aa" :start1
0 :end2 nil
)))
765 (assert-error (search "aa" string
:start2
0 :end2
6))
766 (assert-error (search "aa" string
:start2
(opaque-identity -
1) :end2
5))
767 (assert-error (search "aa" string
:start2
4 :end2
2))
768 (assert-error (search "aa" string
:start2
6 :end2
9))))
770 (defmacro string-case-frob
(fn)
772 (assert-error (,fn string
:start
0 :end
6))
773 (assert-error (,fn string
:start
(opaque-identity -
1) :end
5))
774 (assert-error (,fn string
:start
4 :end
2))
775 (assert-error (,fn string
:start
6 :end
9))))
777 (with-test (:name
(:bounding-index
:string-case
))
778 (sequence-bounding-indices-test
779 (string-case-frob string-upcase
)
780 (string-case-frob string-downcase
)
781 (string-case-frob string-capitalize
)
782 (string-case-frob nstring-upcase
)
783 (string-case-frob nstring-downcase
)
784 (string-case-frob nstring-capitalize
)))
786 (defmacro string-predicate-frob
(fn)
788 (,fn string
"abcde" :start1
0 :end1
5)
789 (,fn
"fghij" string
:start2
0 :end2 nil
)
790 (assert-error (,fn string
"klmno"
792 (assert-error (,fn
"pqrst" string
793 :start2
(opaque-identity -
1) :end2
5))
794 (assert-error (,fn
"uvwxy" string
796 (assert-error (,fn string
"z" :start2
6 :end2
9))))
797 (with-test (:name
(:bounding-index string
=))
798 (sequence-bounding-indices-test
799 (string-predicate-frob string
=)
800 (string-predicate-frob string
/=)
801 (string-predicate-frob string
<)
802 (string-predicate-frob string
>)
803 (string-predicate-frob string
<=)
804 (string-predicate-frob string
>=)))
806 (with-test (:name
(:bounding-index string-equal
))
807 (sequence-bounding-indices-test
808 (string-predicate-frob string-equal
)
809 (string-predicate-frob string-not-equal
)
810 (string-predicate-frob string-lessp
)))
812 (with-test (:name
(:bounding-index string-greaterp
))
813 (sequence-bounding-indices-test
814 (string-predicate-frob string-greaterp
)
815 (string-predicate-frob string-not-greaterp
)
816 (string-predicate-frob string-not-lessp
)))
818 (with-test (:name
(:bounding-index substitute
))
819 (sequence-bounding-indices-test
820 (assert (string= (substitute #\b #\a string
:start
0 :end
5) "bbbbb"))
821 (assert (string= (substitute #\c
#\a string
:start
0 :end nil
)
823 (assert-error (substitute #\b #\a string
:start
0 :end
6))
824 (assert-error (substitute #\b #\a string
:start
(opaque-identity -
1) :end
5))
825 (assert-error (substitute #\b #\a string
:start
4 :end
2))
826 (assert-error (substitute #\b #\a string
:start
6 :end
9))
827 (assert (string= (substitute-if #\b #'alpha-char-p string
830 (assert (string= (substitute-if #\c
#'alpha-char-p string
833 (assert-error (substitute-if #\b #'alpha-char-p string
835 (assert-error (substitute-if #\b #'alpha-char-p string
836 :start
(opaque-identity -
1) :end
5))
837 (assert-error (substitute-if #\b #'alpha-char-p string
839 (assert-error (substitute-if #\b #'alpha-char-p string
841 (assert (string= (substitute-if-not #\b #'alpha-char-p string
844 (assert (string= (substitute-if-not #\c
#'alpha-char-p string
847 (assert-error (substitute-if-not #\b #'alpha-char-p string
849 (assert-error (substitute-if-not #\b #'alpha-char-p string
850 :start
(opaque-identity -
1) :end
5))
851 (assert-error (substitute-if-not #\b #'alpha-char-p string
853 (assert-error (substitute-if-not #\b #'alpha-char-p string
856 (with-test (:name
(:bounding-index nsubstitute
))
857 (sequence-bounding-indices-test
858 (assert (string= (nsubstitute #\b #\a string
:start
0 :end
5) "bbbbb"))
860 (assert (string= (nsubstitute #\c
#\a string
:start
0 :end nil
)
863 (assert-error (nsubstitute #\b #\a string
:start
0 :end
6))
865 (assert-error (nsubstitute #\b #\a string
:start
(opaque-identity -
1) :end
5))
867 (assert-error (nsubstitute #\b #\a string
:start
4 :end
2))
869 (assert-error (nsubstitute #\b #\a string
:start
6 :end
9))
871 (assert (string= (nsubstitute-if #\b #'alpha-char-p string
875 (assert (string= (nsubstitute-if #\c
#'alpha-char-p string
879 (assert-error (nsubstitute-if #\b #'alpha-char-p string
882 (assert-error (nsubstitute-if #\b #'alpha-char-p string
883 :start
(opaque-identity -
1) :end
5))
885 (assert-error (nsubstitute-if #\b #'alpha-char-p string
888 (assert-error (nsubstitute-if #\b #'alpha-char-p string
891 (assert (string= (nsubstitute-if-not #\b #'alpha-char-p string
895 (assert (string= (nsubstitute-if-not #\c
#'alpha-char-p string
899 (assert-error (nsubstitute-if-not #\b #'alpha-char-p string
902 (assert-error (nsubstitute-if-not #\b #'alpha-char-p string
903 :start
(opaque-identity -
1) :end
5))
905 (assert-error (nsubstitute-if-not #\b #'alpha-char-p string
908 (assert-error (nsubstitute-if-not #\b #'alpha-char-p string
911 (with-test (:name
(:bounding-index write-string
))
912 (sequence-bounding-indices-test
913 (write-string string
*standard-output
* :start
0 :end
5)
914 (write-string string
*standard-output
* :start
0 :end nil
)
915 (assert-error (write-string string
*standard-output
*
917 (assert-error (write-string string
*standard-output
*
918 :start
(opaque-identity -
1) :end
5))
919 (assert-error (write-string string
*standard-output
*
921 (assert-error (write-string string
*standard-output
*
923 (write-line string
*standard-output
* :start
0 :end
5)
924 (write-line string
*standard-output
* :start
0 :end nil
)
925 (assert-error (write-line string
*standard-output
*
927 (assert-error (write-line string
*standard-output
*
928 :start
(opaque-identity -
1) :end
5))
929 (assert-error (write-line string
*standard-output
*
931 (assert-error (write-line string
*standard-output
*
934 (with-test (:name
(:bounding-index with-input-from-string
))
935 (sequence-bounding-indices-test
936 (with-input-from-string (s string
:start
0 :end
5)
937 (assert (char= (read-char s
) #\a)))
938 (with-input-from-string (s string
:start
0 :end nil
)
939 (assert (char= (read-char s
) #\a)))
941 (with-input-from-string (s string
:start
0 :end
6)
944 (with-input-from-string (s string
:start
(opaque-identity -
1) :end
5)
947 (with-input-from-string (s string
:start
4 :end
2)
950 (with-input-from-string (s string
:start
6 :end
9)
953 ;;; testing bit-bashing according to _The Practice of Programming_
954 (defun fill-bytes-for-testing (bitsize)
955 "Return a list of 'bytes' of type (MOD BITSIZE)."
956 (remove-duplicates (list 0
957 (1- (ash 1 (1- bitsize
)))
959 (1- (ash 1 bitsize
)))))
961 (defun fill-with-known-value (value size
&rest vectors
)
962 (dolist (vec vectors
)
964 (setf (aref vec i
) value
))))
966 (defun collect-fill-amounts (n-power)
968 (loop for i from
0 upto n-power
969 collect
(1- (expt 2 i
))
971 collect
(1+ (expt 2 i
)))))
973 (defun test-fill-bashing (bitsize padding-amount n-power
)
974 (let* ((size (+ (* padding-amount
2) (expt 2 n-power
) (* padding-amount
2)))
975 (standard (make-array size
:element-type
`(unsigned-byte ,bitsize
)))
976 (bashed (make-array size
:element-type
`(unsigned-byte ,bitsize
)))
977 (fill-amounts (collect-fill-amounts n-power
))
978 (bash-function (intern (format nil
"UB~A-BASH-FILL" bitsize
)
979 (find-package "SB-KERNEL"))))
980 (loop for offset from padding-amount below
(* 2 padding-amount
) do
981 (dolist (c (fill-bytes-for-testing bitsize
))
982 (dolist (n fill-amounts
)
983 (fill-with-known-value (mod (lognot c
) (ash 1 bitsize
)) n
986 ;; a) the standard slow way
987 (locally (declare (notinline fill
))
988 (fill standard c
:start offset
:end
(+ offset n
)))
989 ;; b) the blazingly fast way
990 (let ((value (loop for i from
0 by bitsize
991 until
(= i sb-vm
:n-word-bits
)
993 (funcall bash-function value bashed offset n
))
995 (when (mismatch standard bashed
)
996 (format t
"Test with offset ~A, fill ~A and length ~A failed.~%"
998 (format t
"Mismatch: ~A ~A~%"
999 (subseq standard
0 (+ offset n
1))
1000 (subseq bashed
0 (+ offset n
1)))
1001 (return-from test-fill-bashing nil
))))
1002 finally
(return t
))))
1004 (defun test-copy-bashing (bitsize padding-amount n-power
)
1005 (let* ((size (+ (* padding-amount
2) (expt 2 n-power
) (* padding-amount
2)))
1006 (standard-dst (make-array size
:element-type
`(unsigned-byte ,bitsize
)))
1007 (bashed-dst (make-array size
:element-type
`(unsigned-byte ,bitsize
)))
1008 (source (make-array size
:element-type
`(unsigned-byte ,bitsize
)))
1009 (fill-amounts (collect-fill-amounts n-power
))
1010 (bash-function (intern (format nil
"UB~A-BASH-COPY" bitsize
)
1011 (find-package "SB-KERNEL"))))
1012 (do ((source-offset padding-amount
(1+ source-offset
)))
1013 ((>= source-offset
(* padding-amount
2))
1016 (do ((target-offset padding-amount
(1+ target-offset
)))
1017 ((>= target-offset
(* padding-amount
2)))
1018 (dolist (c (fill-bytes-for-testing bitsize
))
1019 (dolist (n fill-amounts
)
1020 (fill-with-known-value (mod (lognot c
) (ash 1 bitsize
)) size
1021 source standard-dst bashed-dst
)
1022 ;; fill with test data
1023 (fill source c
:start source-offset
:end
(+ source-offset n
))
1024 ;; copy filled test data to test vectors
1026 (replace standard-dst source
1027 :start1 target-offset
:end1
(+ target-offset n
)
1028 :start2 source-offset
:end2
(+ source-offset n
))
1029 ;; b) the blazingly fast way
1030 (funcall bash-function source source-offset
1031 bashed-dst target-offset n
)
1033 (when (mismatch standard-dst bashed-dst
)
1034 (format t
"Test with target-offset ~A, source-offset ~A, fill ~A, and length ~A failed.~%"
1035 target-offset source-offset c n
)
1036 (format t
"Mismatch:~% correct ~A~% actual ~A~%"
1039 (return-from test-copy-bashing nil
))))))))
1041 (with-test (:name
:bash
1042 ;; Too slow for the interpreter
1043 :skipped-on
:interpreter
)
1044 (loop for i
= 1 then
(* i
2) do
1045 ;; the bare '13' here is fairly arbitrary, except that it's been
1046 ;; reduced from '32', which made the tests take aeons; '8' provides
1047 ;; a good range of lengths over which to fill and copy, which
1048 ;; should tease out most errors in the code (if any exist). (It
1049 ;; also makes this part of the test suite finish reasonably
1051 (assert (test-fill-bashing i
13 8))
1052 (assert (test-copy-bashing i
13 8))
1053 until
(= i sb-vm
:n-word-bits
)))
1055 (defun test-inlined-bashing (bitsize)
1056 ;; We have to compile things separately for each bitsize so the
1057 ;; compiler will work out the array type and trigger the REPLACE
1061 (let* ((n-elements-per-word ,(truncate sb-vm
:n-word-bits bitsize
))
1062 (size (* 3 n-elements-per-word
))
1063 (standard-dst (make-array size
:element-type
'(unsigned-byte ,bitsize
)))
1064 (bashed-dst (make-array size
:element-type
'(unsigned-byte ,bitsize
)))
1065 (source (make-array size
:element-type
'(unsigned-byte ,bitsize
))))
1066 (declare (type (simple-array (unsigned-byte ,bitsize
) (*))
1067 source standard-dst bashed-dst
))
1069 (offset n-elements-per-word
(1+ offset
)))
1070 ((>= offset
(* 2 n-elements-per-word
)) t
)
1071 (dolist (c (fill-bytes-for-testing ,bitsize
))
1072 (fill-with-known-value (mod (lognot c
) (ash 1 ,bitsize
)) size
1073 source standard-dst bashed-dst
)
1074 ;; fill with test-data
1075 (fill source c
:start offset
:end
(+ offset n-elements-per-word
))
1076 ;; copy filled data to test vectors
1078 ;; a) the slow way (which is actually fast, since this
1079 ;; should be transformed into UB*-BASH-COPY)
1080 (replace standard-dst source
1081 :start1
(- offset n-elements-per-word i
)
1082 :start2
(- offset n-elements-per-word i
)
1083 :end1 offset
:end2 offset
)
1084 ;; b) the fast way--we fold the
1085 ;; :START{1,2} arguments above ourselves
1086 ;; to trigger the REPLACE transform
1087 (replace bashed-dst source
1088 :start1
0 :start2
0 :end1 offset
:end2 offset
)
1090 (when (or (mismatch standard-dst bashed-dst
)
1091 ;; trigger COPY-SEQ transform
1092 (mismatch (copy-seq standard-dst
) bashed-dst
)
1093 ;; trigger SUBSEQ transform
1094 (mismatch (subseq standard-dst
(- offset n-elements-per-word i
))
1096 (format t
"Test with target-offset ~A, source-offset ~A, fill ~A, and length ~A failed.~%"
1098 (format t
"Mismatch:~% correct ~A~% actual ~A~%"
1101 (return-from nil nil
))))))))
1102 (funcall (checked-compile lambda-form
))))
1104 (with-test (:name
:inline-bash
1105 :skipped-on
:interpreter
)
1106 (loop for i
= 1 then
(* i
2) do
1107 (assert (test-inlined-bashing i
))
1108 until
(= i sb-vm
:n-word-bits
)))
1110 ;;; tests from the Sacla test suite via Eric Marsden, 2007-05-07
1111 (with-test (:name
:remove-duplicates-test-not
)
1112 (remove-duplicates (vector 1 2 2 1) :test-not
(lambda (a b
) (not (= a b
))))
1113 (delete-duplicates (vector #\a #\b #\c
#\a)
1114 :test-not
(lambda (a b
) (not (char-equal a b
)))))
1116 (with-test (:name
:fill-list
)
1117 (let ((l (list 1 2 3)))
1118 (assert (eq l
(fill l
0 :start
1 :end
2)))
1119 (assert (equal l
'(1 0 3)))
1120 (assert (eq l
(fill l
'x
:start
2 :end
3)))
1121 (assert (equal l
'(1 0 x
)))
1122 (assert (eq l
(fill l
'y
:start
1)))
1123 (assert (equal l
'(1 y y
)))
1124 (assert (eq l
(fill l
'z
:end
2)))
1125 (assert (equal l
'(z z y
)))
1126 (assert (eq l
(fill l
1)))
1127 (assert (equal l
'(1 1 1)))
1128 (assert-error (fill l
0 :start
4))
1129 (assert-error (fill l
0 :end
4))
1130 (assert-error (fill l
0 :start
2 :end
1))))
1132 ;;; Both :TEST and :TEST-NOT provided
1133 (with-test (:name
:test-and-test-not-to-adjoin
)
1134 (multiple-value-bind (fun failure-p warnings
)
1135 (checked-compile `(lambda (item test test-not
)
1136 (adjoin item
'(1 2 3 :foo
)
1138 :test-not test-not
))
1140 (declare (ignore failure-p
))
1141 (assert (= 1 (length warnings
)))
1142 (assert-error (funcall fun
1 #'eql
(complement #'eql
)))))
1144 ;;; tests of deftype types equivalent to STRING or SIMPLE-STRING
1145 (deftype %string
() 'string
)
1146 (deftype %simple-string
() 'simple-string
)
1147 (deftype string-3
() '(string 3))
1148 (deftype simple-string-3
() '(simple-string 3))
1150 (with-test (:name
:user-defined-string-types-map-etc
)
1151 (dolist (type '(%string %simple-string string-3 simple-string-3
))
1152 (assert (string= "foo" (coerce '(#\f #\o
#\o
) type
)))
1153 (assert (string= "foo" (map type
'identity
#(#\f #\o
#\o
))))
1154 (assert (string= "foo" (merge type
(copy-seq '(#\o
)) (copy-seq '(#\f #\o
))
1156 (assert (string= "foo" (concatenate type
'(#\f) "oo")))
1157 (assert (string= "ooo" (make-sequence type
3 :initial-element
#\o
)))))
1158 (with-test (:name
:user-defined-string-types-map-etc-error
)
1159 (dolist (type '(string-3 simple-string-3
))
1160 (assert-error (coerce '(#\q
#\u
#\u
#\x
) type
))
1161 (assert-error (map type
'identity
#(#\q
#\u
#\u
#\x
)))
1162 (assert-error (merge type
(copy-seq '(#\q
#\x
)) (copy-seq "uu") 'char
<))
1163 (assert-error (concatenate type
"qu" '(#\u
#\x
)))
1164 (assert-error (make-sequence type
4 :initial-element
#\u
))))
1166 (defun test-bit-position (size set start end from-end res
)
1167 (let ((v (make-array size
:element-type
'bit
:initial-element
0)))
1170 (dolist (f (list (checked-compile
1171 `(lambda (b v s e fe
)
1172 (position b
(the bit-vector v
) :start s
:end e
:from-end fe
)))
1174 `(lambda (b v s e fe
)
1176 (position 1 (the bit-vector v
) :start s
:end e
:from-end fe
)))
1178 `(lambda (b v s e fe
)
1179 (position b
(the vector v
) :start s
:end e
:from-end fe
)))))
1180 (let ((got (funcall f
1 v start end from-end
)))
1181 (unless (eql res got
)
1182 (cerror "Continue" "POSITION 1, Wanted ~S, got ~S.~% size = ~S, set = ~S, from-end = ~S"
1184 size set from-end
)))))
1185 (let ((v (make-array size
:element-type
'bit
:initial-element
1)))
1188 (dolist (f (list (checked-compile
1189 `(lambda (b v s e fe
)
1190 (position b
(the bit-vector v
) :start s
:end e
:from-end fe
)))
1192 `(lambda (b v s e fe
)
1194 (position 0 (the bit-vector v
) :start s
:end e
:from-end fe
)))
1196 `(lambda (b v s e fe
)
1197 (position b
(the vector v
) :start s
:end e
:from-end fe
)))))
1198 (let ((got (funcall f
0 v start end from-end
)))
1199 (unless (eql res got
)
1200 (cerror "Continue" "POSITION 0, Wanted ~S, got ~S.~% size = ~S, set = ~S, from-end = ~S"
1202 size set from-end
))))))
1204 (defun random-test-bit-position (n)
1206 do
(let* ((vector (make-array (+ 2 (random 5000)) :element-type
'bit
1207 :initial-element
0))
1208 (offset (random (1- (length vector
))))
1209 (size (1+ (random (- (length vector
) offset
))))
1210 (disp (make-array size
:element-type
'bit
:displaced-to vector
1211 :displaced-index-offset offset
)))
1212 (assert (plusp size
))
1214 do
(setf (bit vector
(random (length vector
))) 1))
1216 (declare (bit-vector orig
))
1217 (let ((copy (coerce orig
'simple-vector
))
1218 (p0 (random (length orig
)))
1219 (p1 (1+ (random (length orig
)))))
1220 (multiple-value-bind (s e
)
1224 (assert (eql (position 1 copy
:start s
:end e
)
1225 (position 1 orig
:start s
:end e
)))
1226 (assert (eql (position 1 copy
:start s
:end e
:from-end t
)
1227 (position 1 orig
:start s
:end e
:from-end t
)))))))
1231 (with-test (:name
:bit-position
)
1232 (test-bit-position 0 (list) 0 0 nil nil
)
1233 (test-bit-position 0 (list) 0 0 t nil
)
1234 (test-bit-position 1 (list 0) 0 0 nil nil
)
1235 (test-bit-position 1 (list 0) 0 0 t nil
)
1236 (test-bit-position 1 (list 0) 0 1 nil
0)
1237 (test-bit-position 1 (list 0) 0 1 t
0)
1238 (test-bit-position 10 (list 0 1) 0 1 nil
0)
1239 (test-bit-position 10 (list 0 1) 1 1 nil nil
)
1240 (test-bit-position 10 (list 0 1) 0 1 t
0)
1241 (test-bit-position 10 (list 0 1) 1 1 t nil
)
1242 (test-bit-position 10 (list 0 3) 1 4 nil
3)
1243 (test-bit-position 10 (list 0 3) 1 4 t
3)
1244 (test-bit-position 10 (list 0 3 6) 1 10 nil
3)
1245 (test-bit-position 10 (list 0 3 6) 1 10 t
6)
1246 (test-bit-position 1000 (list 128 700) 20 500 nil
128)
1247 (test-bit-position 1000 (list 128 700) 20 500 t
128)
1248 (test-bit-position 1000 (list 423 762) 200 800 nil
423)
1249 (test-bit-position 1000 (list 423 762) 200 800 t
762)
1250 (test-bit-position 1000 (list 298 299) 100 400 nil
298)
1251 (test-bit-position 1000 (list 298 299) 100 400 t
299))
1253 (with-test (:name
(:bit-position
:random-test
))
1254 (random-test-bit-position 10000))
1256 ;; REVERSE and NREVERSE should assert that the returned value
1257 ;; from a generic sequence operation is of type SEQUENCE.
1258 (defclass bogus-reversal-seq
(sequence standard-object
) ())
1259 (defmethod sequence:reverse
((self bogus-reversal-seq
))
1261 (with-test (:name
:generic-sequence-reverse
)
1262 (assert-error (reverse (make-instance 'bogus-reversal-seq
))))
1264 (with-test (:name
:abstract-base-sequence-satisfies-sequencep
)
1265 (assert (typep (sb-pcl::class-prototype
(find-class 'sequence
)) 'sequence
)))
1267 (defvar *macro-invocations
* 0)
1268 ;; in case someone adds more tests after this, don't mess up OPAQUE-IDENTITY
1269 (defun opaque-id-again (x) x
)
1270 (define-compiler-macro opaque-id-again
(x) (incf *macro-invocations
*) x
)
1271 (with-test (:name
:mapfoo-admits-compiler-macros
)
1272 (checked-compile '(lambda (l) (mapcar #'opaque-id-again l
)))
1273 (assert (= *macro-invocations
* 1))
1274 (checked-compile '(lambda (l) (some #'opaque-id-again l
)))
1275 (assert (= *macro-invocations
* 2)))