tests/seq.impure.lisp

   1 ;;;; tests related to sequences
   2
   3 ;;;; This file is impure because we want to be able to use DEFUN.
   4
   5 ;;;; This software is part of the SBCL system. See the README file for
   6 ;;;; more information.
   7 ;;;;
   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
  10 ;;;; from CMU CL.
  11 ;;;;
  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.
  15
  16 (shadow 'reset)
  17
  18 ;;; user-defined mock sequence class for testing generic versions of
  19 ;;; sequence functions.
  20 (defclass list-backed-sequence (standard-object
  21                                 sequence)
  22   ((elements :initarg :elements :type list :accessor %elements)))
  23
  24 (defmethod sequence:make-sequence-like ((sequence list-backed-sequence) length
  25                                         &rest args &key
  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
  30                                   '() length args)))
  31
  32 (defmethod sequence:length ((sequence list-backed-sequence))
  33   (length (%elements sequence)))
  34
  35 (defmethod sequence:elt
  36     ((sequence list-backed-sequence) index)
  37   (nth index (%elements sequence)))
  38
  39 (defmethod (setf sequence:elt)
  40     (new-value (sequence list-backed-sequence) index)
  41   (setf (nth index (%elements sequence)) new-value))
  42
  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)
  46   (labels
  47       ((entirely (eltype)
  48          (every (lambda (el) (typep el eltype)) base-seq))
  49        (make-sequence-for-type (type)
  50          (etypecase 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))))
  58            ((cons (eql vector))
  59             (destructuring-bind (eltype) (rest type)
  60               (when (entirely eltype)
  61                 (let ((initial-element
  62                         (cond ((subtypep eltype 'character)
  63                                #\!)
  64                               ((subtypep eltype 'number)
  65                                0)
  66                                 (t #'error))))
  67                   (replace (make-array
  68                             (+ (length base-seq)
  69                                (random 3))
  70                             :element-type eltype
  71                             :fill-pointer
  72                             (length base-seq)
  73                             :initial-element
  74                             initial-element)
  75                            base-seq))))))))
  76     (dolist (seq-type '(list
  77                         (simple-array t 1)
  78                         (vector t)
  79                         (simple-array character 1)
  80                         (vector character)
  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))
  91                                  ,@(when declaredness
  92                                      `((declare (type ,seq-type seq))))
  93                                  (declare (optimize ,@optimization))
  94                                  ,snippet)))
  95              (when (not seq)
  96                (return))
  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~:@>"
 105                        base-seq
 106                        snippet
 107                        seq-type
 108                        declaredness
 109                        optimization)))))
 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)))
 114
 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)))
 120
 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"
 124                    :test #'char>)))
 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 '>)))
 129
 130 (with-test (:name sequence:emptyp)
 131   (for-every-seq #()
 132     '((eq t (sequence:emptyp seq))))
 133   (for-every-seq #(1)
 134     '((eq nil (sequence:emptyp seq)))))
 135
 136 ;;; tests of FIND, POSITION, FIND-IF, and POSITION-IF (and a few for
 137 ;;; deprecated FIND-IF-NOT and POSITION-IF-NOT too)
 138
 139 (with-test (:name :seq.1)
 140   (for-every-seq #()
 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)))))
 151
 152 (with-test (:name :seq.2)
 153   (for-every-seq #(1)
 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)))))
 168
 169 (with-test (:name :seq.3)
 170   (for-every-seq #(1 2 3 2 1)
 171     '((find 3 seq)
 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)))))
 213
 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)))))
 231
 232 (with-test (:name :subseq)
 233   (let ((avec (make-array 10
 234                           :fill-pointer 4
 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:-|
 248     ;;
 249     ;; SUBSEQ should check its END value against logical LENGTH, not
 250     ;; physical ARRAY-DIMENSION 0.
 251     ;;
 252     ;; fixed in sbcl-0.7.4.22 by WHN
 253     (assert (null (ignore-errors (aref (subseq avec 1 5) 0))))))
 254
 255 (with-test (:name :fill-typecheck)
 256   (checked-compile-and-assert
 257       (:optimize :safe)
 258       `(lambda (x)
 259          (fill (make-string 10) x))
 260     ((#\@) "@@@@@@@@@@" :test #'equal)
 261     ;; BUG 186, fixed in sbcl-0.7.5.5
 262     ((4097) (condition 'type-error))))
 263
 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)
 270                          (vector *)
 271                          (vector (signed-byte 8))
 272                          (vector (unsigned-byte 16))
 273                          (vector (signed-byte 32))
 274                          (simple-bit-vector)))
 275       (declare (optimize safety))
 276       ;; MAKE-SEQUENCE
 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))
 280       ;; COERCE
 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)))
 284       ;; CONCATENATE
 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))
 292       ;; MERGE
 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))))
 302       ;; MAP
 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)))
 307                  4))
 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
 312     (locally
 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.
 321     (locally
 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)))))
 337
 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)))
 341
 342   (for-every-seq #()
 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 ""))))
 347
 348   (for-every-seq #(1)
 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")))))
 355
 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) '<))))
 363
 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))
 369                                'type-error))))
 370     (locally
 371         (declare (optimize safety))
 372       ;; MAKE-SEQUENCE
 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))
 386       ;; COERCE
 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))
 395       ;; MERGE
 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)
 402                                 '<))
 403                  4))
 404       (assert-type-error (merge 'nil () () '<))
 405       ;; CONCATENATE
 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.
 413       )))
 414 \f
 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
 419       (:optimize :safe)
 420       `(lambda (x) (elt x 3))
 421     (("foo") (condition 'type-error))
 422     (("foob") #\b))
 423   (locally
 424       (declare (optimize (safety 3)))
 425     (assert-error (elt (list 1 2 3) 3) type-error)))
 426 \f
 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
 431       (:optimize :safe)
 432       `(lambda (x) (svref x 0))
 433     ((#*0) (condition 'type-error))))
 434 \f
 435 ;;; checks for uniform bounding index handling.
 436 ;;;
 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.
 439 ;;;
 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)
 443   `(progn
 444      (locally
 445     ;; See Issues 332 [and 333(!)] in the CLHS
 446     (declare (optimize (speed 3) (safety 1)))
 447     (let ((string (make-array 10
 448                               :fill-pointer 5
 449                               :initial-element #\a
 450                               :element-type 'base-char)))
 451         ,(car body)
 452         (flet ((reset ()
 453                  (setf (fill-pointer string) 10)
 454                  (fill string #\a)
 455                  (setf (fill-pointer string) 5)))
 456           (declare (ignorable #'reset))
 457           ,@(cdr body))))
 458     (locally
 459       ;; See Issues 332 [and 333(!)] in the CLHS
 460       (declare (optimize (speed 3) (safety 1)))
 461       (let ((string (make-array 10
 462                                 :fill-pointer 5
 463                                 :initial-element #\a
 464                                 :element-type 'character)))
 465         ,(car body)
 466       (flet ((reset ()
 467                (setf (fill-pointer string) 10)
 468                (fill string #\a)
 469                (setf (fill-pointer string) 5)))
 470         (declare (ignorable #'reset))
 471           ,@(cdr body))))))
 472
 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"))
 482    (reset)
 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"))))
 487
 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))
 498    (assert-error
 499     (count-if #'alpha-char-p string :start 0 :end 6))
 500    (assert-error
 501     (count-if #'alpha-char-p string :start (opaque-identity -1) :end 5))
 502    (assert-error
 503     (count-if #'alpha-char-p string :start 4 :end 2))
 504    (assert-error
 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))
 508    (assert-error
 509     (count-if-not #'alpha-char-p string :start 0 :end 6))
 510    (assert-error
 511     (count-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5))
 512    (assert-error
 513     (count-if-not #'alpha-char-p string :start 4 :end 2))
 514    (assert-error
 515     (count-if-not #'alpha-char-p string :start 6 :end 9))))
 516
 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))))
 525
 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))
 536    (assert-error
 537     (find-if #'alpha-char-p string :start 0 :end 6))
 538    (assert-error
 539     (find-if #'alpha-char-p string :start (opaque-identity -1) :end 5))
 540    (assert-error
 541     (find-if #'alpha-char-p string :start 4 :end 2))
 542    (assert-error
 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))
 546    (assert-error
 547     (find-if-not #'alpha-char-p string :start 0 :end 6))
 548    (assert-error
 549     (find-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5))
 550    (assert-error
 551     (find-if-not #'alpha-char-p string :start 4 :end 2))
 552    (assert-error
 553     (find-if-not #'alpha-char-p string :start 6 :end 9))))
 554
 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))))
 563
 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))))
 575
 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)
 580          #-win32 "/dev/ /tmp"
 581          #+win32 "C:/   NUL")
 582    (setf (fill-pointer string) 5)
 583    (assert (truename (parse-namestring string nil *default-pathname-defaults*
 584                                        :start 0 :end 5)))
 585    (assert (truename (parse-namestring string nil *default-pathname-defaults*
 586                                        :start 0 :end nil)))
 587    (assert-error (parse-namestring string nil
 588                                    *default-pathname-defaults*
 589                                    :start 0 :end 6))
 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*
 595                                    :start 4 :end 2))
 596    (assert-error (parse-namestring string nil
 597                                    *default-pathname-defaults*
 598                                    :start 6 :end 9))))
 599
 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))
 610    (assert-error
 611     (position-if #'alpha-char-p string :start 0 :end 6))
 612    (assert-error
 613     (position-if #'alpha-char-p string :start (opaque-identity -1) :end 5))
 614    (assert-error
 615     (position-if #'alpha-char-p string :start 4 :end 2))
 616    (assert-error
 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))
 620    (assert-error
 621     (position-if-not #'alpha-char-p string :start 0 :end 6))
 622    (assert-error
 623     (position-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5))
 624    (assert-error
 625     (position-if-not #'alpha-char-p string :start 4 :end 2))
 626    (assert-error
 627     (position-if-not #'alpha-char-p string :start 6 :end 9))))
 628
 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))))
 638
 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))))
 650
 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) ""))
 661    (assert-error
 662     (remove-if #'alpha-char-p string :start 0 :end 6))
 663    (assert-error
 664     (remove-if #'alpha-char-p string :start (opaque-identity -1) :end 5))
 665    (assert-error
 666     (remove-if #'alpha-char-p string :start 4 :end 2))
 667    (assert-error
 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)
 670                   "aaaaa"))
 671    (assert (equal (remove-if-not #'alpha-char-p string :start 0 :end 5)
 672                   "aaaaa"))
 673    (assert-error
 674     (remove-if-not #'alpha-char-p string :start 0 :end 6))
 675    (assert-error
 676     (remove-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5))
 677    (assert-error
 678     (remove-if-not #'alpha-char-p string :start 4 :end 2))
 679    (assert-error
 680     (remove-if-not #'alpha-char-p string :start 6 :end 9))))
 681
 682 (with-test (:name (:bounding-index delete))
 683   (sequence-bounding-indices-test
 684    (assert (equal (delete #\a string :start 0 :end nil) ""))
 685    (reset)
 686    (assert (equal (delete #\a string :start 0 :end 5) ""))
 687    (reset)
 688    (assert-error (delete #\a string :start 0 :end 6))
 689    (reset)
 690    (assert-error (delete #\a string :start (opaque-identity -1) :end 5))
 691    (reset)
 692    (assert-error (delete #\a string :start 4 :end 2))
 693    (reset)
 694    (assert-error (delete #\a string :start 6 :end 9))
 695    (reset)
 696    (assert (equal (delete-if #'alpha-char-p string :start 0 :end nil) ""))
 697    (reset)
 698    (assert (equal (delete-if #'alpha-char-p string :start 0 :end 5) ""))
 699    (reset)
 700    (assert-error
 701     (delete-if #'alpha-char-p string :start 0 :end 6))
 702    (reset)
 703    (assert-error
 704     (delete-if #'alpha-char-p string :start (opaque-identity -1) :end 5))
 705    (reset)
 706    (assert-error
 707     (delete-if #'alpha-char-p string :start 4 :end 2))
 708    (reset)
 709    (assert-error
 710     (delete-if #'alpha-char-p string :start 6 :end 9))
 711    (reset)
 712    (assert (equal (delete-if-not #'alpha-char-p string :start 0 :end nil)
 713                   "aaaaa"))
 714    (reset)
 715    (assert (equal (delete-if-not #'alpha-char-p string :start 0 :end 5)
 716                   "aaaaa"))
 717    (reset)
 718    (assert-error
 719     (delete-if-not #'alpha-char-p string :start 0 :end 6))
 720    (reset)
 721    (assert-error
 722     (delete-if-not #'alpha-char-p string :start (opaque-identity -1) :end 5))
 723    (reset)
 724    (assert-error
 725     (delete-if-not #'alpha-char-p string :start 4 :end 2))
 726    (reset)
 727    (assert-error
 728     (delete-if-not #'alpha-char-p string :start 6 :end 9))))
 729
 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"))
 739    (reset)
 740    (assert (string= (delete-duplicates string :start 0 :end nil) "a"))
 741    (reset)
 742    (assert-error (delete-duplicates string :start 0 :end 6))
 743    (reset)
 744    (assert-error (delete-duplicates string :start (opaque-identity -1) :end 5))
 745    (reset)
 746    (assert-error (delete-duplicates string :start 4 :end 2))
 747    (reset)
 748    (assert-error (delete-duplicates string :start 6 :end 9))))
 749
 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")
 754                              string
 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))))
 760
 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))))
 769
 770 (defmacro string-case-frob (fn)
 771   `(progn
 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))))
 776
 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)))
 785
 786 (defmacro string-predicate-frob (fn)
 787   `(progn
 788      (,fn string "abcde" :start1 0 :end1 5)
 789      (,fn "fghij" string :start2 0 :end2 nil)
 790      (assert-error (,fn string "klmno"
 791                         :start1 0 :end1 6))
 792      (assert-error (,fn "pqrst" string
 793                         :start2 (opaque-identity -1) :end2 5))
 794      (assert-error (,fn "uvwxy" string
 795                         :start1 4 :end1 2))
 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>=)))
 805
 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)))
 811
 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)))
 817
 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)
 822                     "ccccc"))
 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
 828                                    :start 0 :end 5)
 829                     "bbbbb"))
 830    (assert (string= (substitute-if #\c #'alpha-char-p string
 831                                    :start 0 :end nil)
 832                     "ccccc"))
 833    (assert-error (substitute-if #\b #'alpha-char-p string
 834                                 :start 0 :end 6))
 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
 838                                 :start 4 :end 2))
 839    (assert-error (substitute-if #\b #'alpha-char-p string
 840                                 :start 6 :end 9))
 841    (assert (string= (substitute-if-not #\b #'alpha-char-p string
 842                                        :start 0 :end 5)
 843                     "aaaaa"))
 844    (assert (string= (substitute-if-not #\c #'alpha-char-p string
 845                                        :start 0 :end nil)
 846                     "aaaaa"))
 847    (assert-error (substitute-if-not #\b #'alpha-char-p string
 848                                     :start 0 :end 6))
 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
 852                                     :start 4 :end 2))
 853    (assert-error (substitute-if-not #\b #'alpha-char-p string
 854                                     :start 6 :end 9))))
 855
 856 (with-test (:name (:bounding-index nsubstitute))
 857   (sequence-bounding-indices-test
 858    (assert (string= (nsubstitute #\b #\a string :start 0 :end 5) "bbbbb"))
 859    (reset)
 860    (assert (string= (nsubstitute #\c #\a string :start 0 :end nil)
 861                     "ccccc"))
 862    (reset)
 863    (assert-error (nsubstitute #\b #\a string :start 0 :end 6))
 864    (reset)
 865    (assert-error (nsubstitute #\b #\a string :start (opaque-identity -1) :end 5))
 866    (reset)
 867    (assert-error (nsubstitute #\b #\a string :start 4 :end 2))
 868    (reset)
 869    (assert-error (nsubstitute #\b #\a string :start 6 :end 9))
 870    (reset)
 871    (assert (string= (nsubstitute-if #\b #'alpha-char-p string
 872                                     :start 0 :end 5)
 873                     "bbbbb"))
 874    (reset)
 875    (assert (string= (nsubstitute-if #\c #'alpha-char-p string
 876                                     :start 0 :end nil)
 877                     "ccccc"))
 878    (reset)
 879    (assert-error (nsubstitute-if #\b #'alpha-char-p string
 880                                  :start 0 :end 6))
 881    (reset)
 882    (assert-error (nsubstitute-if #\b #'alpha-char-p string
 883                                  :start (opaque-identity -1) :end 5))
 884    (reset)
 885    (assert-error (nsubstitute-if #\b #'alpha-char-p string
 886                                  :start 4 :end 2))
 887    (reset)
 888    (assert-error (nsubstitute-if #\b #'alpha-char-p string
 889                                  :start 6 :end 9))
 890    (reset)
 891    (assert (string= (nsubstitute-if-not #\b #'alpha-char-p string
 892                                         :start 0 :end 5)
 893                     "aaaaa"))
 894    (reset)
 895    (assert (string= (nsubstitute-if-not #\c #'alpha-char-p string
 896                                         :start 0 :end nil)
 897                     "aaaaa"))
 898    (reset)
 899    (assert-error (nsubstitute-if-not #\b #'alpha-char-p string
 900                                      :start 0 :end 6))
 901    (reset)
 902    (assert-error (nsubstitute-if-not #\b #'alpha-char-p string
 903                                      :start (opaque-identity -1) :end 5))
 904    (reset)
 905    (assert-error (nsubstitute-if-not #\b #'alpha-char-p string
 906                                      :start 4 :end 2))
 907    (reset)
 908    (assert-error (nsubstitute-if-not #\b #'alpha-char-p string
 909                                      :start 6 :end 9))))
 910
 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*
 916                                :start 0 :end 6))
 917    (assert-error (write-string string *standard-output*
 918                                :start (opaque-identity -1) :end 5))
 919    (assert-error (write-string string *standard-output*
 920                                :start 4 :end 2))
 921    (assert-error (write-string string *standard-output*
 922                                :start 6 :end 9))
 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*
 926                              :start 0 :end 6))
 927    (assert-error (write-line string *standard-output*
 928                              :start (opaque-identity -1) :end 5))
 929    (assert-error (write-line string *standard-output*
 930                              :start 4 :end 2))
 931    (assert-error (write-line string *standard-output*
 932                              :start 6 :end 9))))
 933
 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)))
 940   (assert-error
 941    (with-input-from-string (s string :start 0 :end 6)
 942      (read-char s)))
 943   (assert-error
 944    (with-input-from-string (s string :start (opaque-identity -1) :end 5)
 945      (read-char s)))
 946   (assert-error
 947    (with-input-from-string (s string :start 4 :end 2)
 948      (read-char s)))
 949   (assert-error
 950    (with-input-from-string (s string :start 6 :end 9)
 951      (read-char s)))))
 952 \f
 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)))
 958                            (ash 1 (1- bitsize))
 959                            (1- (ash 1 bitsize)))))
 960
 961 (defun fill-with-known-value (value size &rest vectors)
 962   (dolist (vec vectors)
 963     (dotimes (i size)
 964       (setf (aref vec i) value))))
 965
 966 (defun collect-fill-amounts (n-power)
 967   (remove-duplicates
 968    (loop for i from 0 upto n-power
 969          collect (1- (expt 2 i))
 970          collect (expt 2 i)
 971          collect (1+ (expt 2 i)))))
 972
 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
 984                                      standard bashed)
 985               ;; fill vectors
 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)
 992                                  sum (ash c i))))
 993                 (funcall bash-function value bashed offset n))
 994               ;; check for errors
 995               (when (mismatch standard bashed)
 996                 (format t "Test with offset ~A, fill ~A and length ~A failed.~%"
 997                         offset c n)
 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))))
1003
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))
1014          ;; success!
1015          t)
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
1025            ;; a) the slow way
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)
1032            ;; check for errors
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~%"
1037                      standard-dst
1038                      bashed-dst)
1039              (return-from test-copy-bashing nil))))))))
1040
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
1050         ;; quickly.)
1051         (assert (test-fill-bashing i 13 8))
1052         (assert (test-copy-bashing i 13 8))
1053         until (= i sb-vm:n-word-bits)))
1054
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
1058   ;; transform.
1059   (let ((lambda-form
1060          `(lambda ()
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))
1068               (do ((i 0 (1+ i))
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
1077                   ;;
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)
1089                   ;; check for errors
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))
1095                                       bashed-dst))
1096                     (format t "Test with target-offset ~A, source-offset ~A, fill ~A, and length ~A failed.~%"
1097                             0 0 c offset)
1098                     (format t "Mismatch:~% correct ~A~% actual  ~A~%"
1099                             standard-dst
1100                             bashed-dst)
1101                     (return-from nil nil))))))))
1102     (funcall (checked-compile lambda-form))))
1103
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)))
1109 \f
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)))))
1115
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))))
1131
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)
1137                                   :test test
1138                                   :test-not test-not))
1139                        :allow-warnings t)
1140     (declare (ignore failure-p))
1141     (assert (= 1 (length warnings)))
1142     (assert-error (funcall fun 1 #'eql (complement #'eql)))))
1143 \f
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))
1149
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))
1155                                   'char<)))
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))))
1165
1166 (defun test-bit-position (size set start end from-end res)
1167   (let ((v (make-array size :element-type 'bit :initial-element 0)))
1168     (dolist (i set)
1169       (setf (bit v i) 1))
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)))
1173                      (checked-compile
1174                       `(lambda (b v s e fe)
1175                          (assert (eql b 1))
1176                          (position 1 (the bit-vector v) :start s :end e :from-end fe)))
1177                      (checked-compile
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"
1183                   res got
1184                   size set from-end)))))
1185   (let ((v (make-array size :element-type 'bit :initial-element 1)))
1186     (dolist (i set)
1187       (setf (bit v i) 0))
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)))
1191                      (checked-compile
1192                       `(lambda (b v s e fe)
1193                          (assert (eql b 0))
1194                          (position 0 (the bit-vector v) :start s :end e :from-end fe)))
1195                      (checked-compile
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"
1201                   res got
1202                   size set from-end))))))
1203
1204 (defun random-test-bit-position (n)
1205   (loop repeat 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))
1213              (loop repeat 10
1214                    do (setf (bit vector (random (length vector))) 1))
1215              (flet ((test (orig)
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)
1221                             (if (> p1 p0)
1222                                 (values p0 p1)
1223                                 (values p1 p0))
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)))))))
1228                (test vector)
1229                (test disp)))))
1230
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))
1252
1253 (with-test (:name (:bit-position :random-test))
1254   (random-test-bit-position 10000))
1255
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))
1260   #2a((x y) (1 2)))
1261 (with-test (:name :generic-sequence-reverse)
1262   (assert-error (reverse (make-instance 'bogus-reversal-seq))))
1263
1264 (with-test (:name :abstract-base-sequence-satisfies-sequencep)
1265   (assert (typep (sb-pcl::class-prototype (find-class 'sequence)) 'sequence)))
1266
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)))
1276
1277 ;;; success