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