Fix make-array transforms.

[sbcl.git] / tests / seq.impure.lisp

diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp
index a659be1..c0ddb6f 100644 (file)
--- a/tests/seq.impure.lisp
+++ b/tests/seq.impure.lisp
@@ -13,65 +13,92 @@
 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
 
 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
 

+(load "test-util.lisp")

 (load "assertoid.lisp")
 
 (defpackage :seq-test
 (load "assertoid.lisp")
 
 (defpackage :seq-test

-  (:use :cl :assertoid))
+  (:use :cl :assertoid :test-util))

 
 (in-package :seq-test)
 
 
 (in-package :seq-test)
 

+;;; user-defined mock sequence class for testing generic versions of
+;;; sequence functions.
+(defclass list-backed-sequence (standard-object
+                                sequence)
+  ((elements :initarg :elements :type list :accessor %elements)))
+
+(defmethod sequence:make-sequence-like ((sequence list-backed-sequence) length
+                                        &rest args &key
+                                        initial-element initial-contents)
+  (declare (ignore initial-element initial-contents))
+  (make-instance 'list-backed-sequence
+                 :elements (apply #'sequence:make-sequence-like
+                                  '() length args)))
+
+(defmethod sequence:length ((sequence list-backed-sequence))
+  (length (%elements sequence)))
+
+(defmethod sequence:elt
+    ((sequence list-backed-sequence) index)
+  (nth index (%elements sequence)))
+
+(defmethod (setf sequence:elt)
+    (new-value (sequence list-backed-sequence) index)
+  (setf (nth index (%elements sequence)) new-value))
+

 ;;; helper functions for exercising SEQUENCE code on data of many
 ;;; specialized types, and in many different optimization scenarios
 (defun for-every-seq-1 (base-seq snippet)
 ;;; helper functions for exercising SEQUENCE code on data of many
 ;;; specialized types, and in many different optimization scenarios
 (defun for-every-seq-1 (base-seq snippet)

-  (dolist (seq-type '(list
-                      (simple-array t 1)
-                      (vector t)
-                      (simple-array character 1)
-                      (vector character)
-                      (simple-array (signed-byte 4) 1)
-                      (vector (signed-byte 4))))
-    (flet ((entirely (eltype)
-             (every (lambda (el) (typep el eltype)) base-seq)))
+  (labels
+      ((entirely (eltype)
+         (every (lambda (el) (typep el eltype)) base-seq))
+       (make-sequence-for-type (type)
+         (etypecase type
+           ((member list list-backed-sequence)
+            (coerce base-seq type))
+           ((cons (eql simple-array) (cons * (cons (eql 1) null)))
+            (destructuring-bind (eltype one) (rest type)
+              (when (entirely eltype)
+                (coerce base-seq type))))
+           ((cons (eql vector))
+            (destructuring-bind (eltype) (rest type)
+              (when (entirely eltype)
+                (let ((initial-element
+                        (cond ((subtypep eltype 'character)
+                               #\!)
+                              ((subtypep eltype 'number)
+                               0)
+                                (t #'error))))
+                  (replace (make-array
+                            (+ (length base-seq)
+                               (random 3))
+                            :element-type eltype
+                            :fill-pointer
+                            (length base-seq)
+                            :initial-element
+                            initial-element)
+                           base-seq))))))))
+    (dolist (seq-type '(list
+                        (simple-array t 1)
+                        (vector t)
+                        (simple-array character 1)
+                        (vector character)
+                        (simple-array (signed-byte 4) 1)
+                        (vector (signed-byte 4))
+                        list-backed-sequence))

       (dolist (declaredness '(nil t))
         (dolist (optimization '(((speed 3) (space 0))
                                 ((speed 2) (space 2))
                                 ((speed 1) (space 2))
                                 ((speed 0) (space 1))))
       (dolist (declaredness '(nil t))
         (dolist (optimization '(((speed 3) (space 0))
                                 ((speed 2) (space 2))
                                 ((speed 1) (space 2))
                                 ((speed 0) (space 1))))

-          (let* ((seq (if (eq seq-type 'list)
-                          (coerce base-seq 'list)
-                          (destructuring-bind (type-first &rest type-rest)
-                              seq-type
-                            (ecase type-first
-                              (simple-array
-                               (destructuring-bind (eltype one) type-rest
-                                 (assert (= one 1))
-                                 (if (entirely eltype)
-                                     (coerce base-seq seq-type)
-                                     (return))))
-                              (vector
-                               (destructuring-bind (eltype) type-rest
-                                 (if (entirely eltype)
-                                     (let ((initial-element
-                                            (cond ((subtypep eltype 'character)
-                                                   #\!)
-                                                  ((subtypep eltype 'number)
-                                                   0)
-                                                  (t #'error))))
-                                       (replace (make-array
-                                                 (+ (length base-seq)
-                                                    (random 3))
-                                                 :element-type eltype
-                                                 :fill-pointer
-                                                 (length base-seq)
-                                                 :initial-element
-                                                 initial-element)
-                                                base-seq))
-                                     (return))))))))
-                 (lambda-expr `(lambda (seq)
-                                 ,@(when declaredness
-                                     `((declare (type ,seq-type seq))))
-                                 (declare (optimize ,@optimization))
-                                 ,snippet)))
+          (let ((seq (make-sequence-for-type seq-type))
+                (lambda-expr `(lambda (seq)
+                                ,@(when declaredness
+                                    `((declare (type ,seq-type seq))))
+                                (declare (optimize ,@optimization))
+                                ,snippet)))
+            (when (not seq)
+              (return))

             (format t "~&~S~%" lambda-expr)
             (multiple-value-bind (fun warnings-p failure-p)
                 (compile nil lambda-expr)
             (format t "~&~S~%" lambda-expr)
             (multiple-value-bind (fun warnings-p failure-p)
                 (compile nil lambda-expr)

@@ -108,6 +135,12 @@
 (assert (eql 4 ; modified more, avoids charset technicalities completely
              (find 5 '(6 4) :test '>)))
 
 (assert (eql 4 ; modified more, avoids charset technicalities completely
              (find 5 '(6 4) :test '>)))
 

+(with-test (:name sequence:emptyp)
+  (for-every-seq #()
+    '((eq t (sequence:emptyp seq))))
+  (for-every-seq #(1)
+    '((eq nil (sequence:emptyp seq)))))
+

 ;;; tests of FIND, POSITION, FIND-IF, and POSITION-IF (and a few for
 ;;; deprecated FIND-IF-NOT and POSITION-IF-NOT too)
 (for-every-seq #()
 ;;; tests of FIND, POSITION, FIND-IF, and POSITION-IF (and a few for
 ;;; deprecated FIND-IF-NOT and POSITION-IF-NOT too)
 (for-every-seq #()

@@ -197,27 +230,28 @@
     (null (find-if 'upper-case-p seq))))
 
 ;;; SUBSEQ
     (null (find-if 'upper-case-p seq))))
 
 ;;; SUBSEQ

-(let ((avec (make-array 10
-                        :fill-pointer 4
-                        :initial-contents '(0 1 2 3 iv v vi vii iix ix))))
-  ;; These first five always worked AFAIK.
-  (assert (equalp (subseq avec 0 3) #(0 1 2)))
-  (assert (equalp (subseq avec 3 3) #()))
-  (assert (equalp (subseq avec 1 3) #(1 2)))
-  (assert (equalp (subseq avec 1) #(1 2 3)))
-  (assert (equalp (subseq avec 1 4) #(1 2 3)))
-  ;; SBCL bug found ca. 2002-05-01 by OpenMCL's correct handling of
-  ;; SUBSEQ, CSR's driving portable cross-compilation far enough to
-  ;; reach the SUBSEQ calls in assem.lisp, and WHN's sleazy
-  ;; translation of old CMU CL new-assem.lisp into sufficiently grotty
-  ;; portable Lisp that it passed suitable illegal values to SUBSEQ to
-  ;; exercise the bug:-|
-  ;;
-  ;; SUBSEQ should check its END value against logical LENGTH, not
-  ;; physical ARRAY-DIMENSION 0.
-  ;;
-  ;; fixed in sbcl-0.7.4.22 by WHN
-  (assert (null (ignore-errors (aref (subseq avec 1 5) 0)))))
+(with-test (:name :subseq)
+  (let ((avec (make-array 10
+                          :fill-pointer 4
+                          :initial-contents '(0 1 2 3 iv v vi vii iix ix))))
+    ;; These first five always worked AFAIK.
+    (assert (equalp (subseq avec 0 3) #(0 1 2)))
+    (assert (equalp (subseq avec 3 3) #()))
+    (assert (equalp (subseq avec 1 3) #(1 2)))
+    (assert (equalp (subseq avec 1) #(1 2 3)))
+    (assert (equalp (subseq avec 1 4) #(1 2 3)))
+    ;; SBCL bug found ca. 2002-05-01 by OpenMCL's correct handling of
+    ;; SUBSEQ, CSR's driving portable cross-compilation far enough to
+    ;; reach the SUBSEQ calls in assem.lisp, and WHN's sleazy
+    ;; translation of old CMU CL new-assem.lisp into sufficiently grotty
+    ;; portable Lisp that it passed suitable illegal values to SUBSEQ to
+    ;; exercise the bug:-|
+    ;;
+    ;; SUBSEQ should check its END value against logical LENGTH, not
+    ;; physical ARRAY-DIMENSION 0.
+    ;;
+    ;; fixed in sbcl-0.7.4.22 by WHN
+    (assert (null (ignore-errors (aref (subseq avec 1 5) 0))))))

 
 ;;; FILL
 (defun test-fill-typecheck (x)
 
 ;;; FILL
 (defun test-fill-typecheck (x)

@@ -230,136 +264,156 @@
 
 ;;; MAKE-SEQUENCE, COERCE, CONCATENATE, MERGE, MAP and requested
 ;;; result type (BUGs 46a, 46b, 66)
 
 ;;; MAKE-SEQUENCE, COERCE, CONCATENATE, MERGE, MAP and requested
 ;;; result type (BUGs 46a, 46b, 66)

-(macrolet ((assert-type-error (form)
-             `(assert (typep (nth-value 1 (ignore-errors ,form))
-                             'type-error))))
-  (dolist (type-stub '((simple-vector)
-                       (vector *)
-                       (vector (signed-byte 8))
-                       (vector (unsigned-byte 16))
-                       (vector (signed-byte 32))
-                       (simple-bit-vector)))
-    (declare (optimize safety))
-    (format t "~&~S~%" type-stub)
-    ;; MAKE-SEQUENCE
-    (assert (= (length (make-sequence `(,@type-stub) 10)) 10))
-    (assert (= (length (make-sequence `(,@type-stub 10) 10)) 10))
-    (assert-type-error (make-sequence `(,@type-stub 10) 11))
-    ;; COERCE
-    (assert (= (length (coerce '(0 0 0) `(,@type-stub))) 3))
-    (assert (= (length (coerce #(0 0 0) `(,@type-stub 3))) 3))
-    (assert-type-error (coerce #*111 `(,@type-stub 4)))
-    ;; CONCATENATE
-    (assert (= (length (concatenate `(,@type-stub) #(0 0 0) #*111)) 6))
-    (assert (equalp (concatenate `(,@type-stub) #(0 0 0) #*111)
-                   (coerce #(0 0 0 1 1 1) `(,@type-stub))))
-    (assert (= (length (concatenate `(,@type-stub 6) #(0 0 0) #*111)) 6))
-    (assert (equalp (concatenate `(,@type-stub 6) #(0 0 0) #*111)
-                   (coerce #(0 0 0 1 1 1) `(,@type-stub 6))))
-    (assert-type-error (concatenate `(,@type-stub 5) #(0 0 0) #*111))
-    ;; MERGE
-    (macrolet ((test (type)
-                 `(merge ,type (copy-seq #(0 1 0)) (copy-seq #*111) #'>)))
-      (assert (= (length (test `(,@type-stub))) 6))
-      (assert (equalp (test `(,@type-stub))
-                      (coerce #(1 1 1 0 1 0) `(,@type-stub))))
-      (assert (= (length (test `(,@type-stub 6))) 6))
-      (assert (equalp (test `(,@type-stub 6))
-                      (coerce #(1 1 1 0 1 0) `(,@type-stub 6))))
-      (assert-type-error (test `(,@type-stub 4))))
-    ;; MAP
-    (assert (= (length (map `(,@type-stub) #'logxor #(0 0 1 1) '(0 1 0 1))) 4))
-    (assert (equalp (map `(,@type-stub) #'logxor #(0 0 1 1) '(0 1 0 1))
-                   (coerce #(0 1 1 0) `(,@type-stub))))
-    (assert (= (length (map `(,@type-stub 4) #'logxor #(0 0 1 1) '(0 1 0 1)))
-               4))
-    (assert (equalp (map `(,@type-stub 4) #'logxor #(0 0 1 1) '(0 1 0 1))
-                   (coerce #(0 1 1 0) `(,@type-stub 4))))
-    (assert-type-error (map `(,@type-stub 5) #'logxor #(0 0 1 1) '(0 1 0 1))))
-  ;; some more CONCATENATE tests for strings
-  (locally
+(with-test (:name :sequence-functions)
+  (macrolet ((assert-type-error (form)
+               `(assert (typep (nth-value 1 (ignore-errors ,form))
+                               'type-error))))
+    (dolist (type-stub '((simple-vector)
+                         (vector *)
+                         (vector (signed-byte 8))
+                         (vector (unsigned-byte 16))
+                         (vector (signed-byte 32))
+                         (simple-bit-vector)))

       (declare (optimize safety))
       (declare (optimize safety))

-    (assert (string= (concatenate 'string "foo" " " "bar") "foo bar"))
-    (assert (string= (concatenate '(string 7) "foo" " " "bar") "foo bar"))
-    (assert-type-error (concatenate '(string 6) "foo" " " "bar"))
-    (assert (string= (concatenate '(string 6) "foo" #(#\b #\a #\r)) "foobar"))
-    (assert-type-error (concatenate '(string 7) "foo" #(#\b #\a #\r))))
-  ;; Non-VECTOR ARRAY types aren't allowed as vector type specifiers.
-  (locally
-    (declare (optimize safety))
-    (assert-type-error (concatenate 'simple-array "foo" "bar"))
-    (assert-type-error (map 'simple-array #'identity '(1 2 3)))
-    (assert (equalp #(11 13)
-                    (map '(simple-array fixnum (*)) #'+ '(1 2 3) '(10 11))))
-    (assert-type-error (coerce '(1 2 3) 'simple-array))
-    (assert-type-error (merge 'simple-array (list 1 3) (list 2 4) '<))
-    (assert (equalp #(3 2 1) (coerce '(3 2 1) '(vector fixnum))))
-    (assert-type-error (map 'array #'identity '(1 2 3)))
-    (assert-type-error (map '(array fixnum) #'identity '(1 2 3)))
-    (assert (equalp #(1 2 3) (coerce '(1 2 3) '(vector fixnum))))
-    ;; but COERCE has an exemption clause:
-    (assert (string= "foo" (coerce "foo" 'simple-array)))
-    ;; ... though not in all cases.
-    (assert-type-error (coerce '(#\f #\o #\o) 'simple-array))))
+      (format t "~&~S~%" type-stub)
+      ;; MAKE-SEQUENCE
+      (assert (= (length (make-sequence `(,@type-stub) 10)) 10))
+      (assert (= (length (make-sequence `(,@type-stub 10) 10)) 10))
+      (assert-type-error (make-sequence `(,@type-stub 10) 11))
+      ;; COERCE
+      (assert (= (length (coerce '(0 0 0) `(,@type-stub))) 3))
+      (assert (= (length (coerce #(0 0 0) `(,@type-stub 3))) 3))
+      (assert-type-error (coerce #*111 `(,@type-stub 4)))
+      ;; CONCATENATE
+      (assert (= (length (concatenate `(,@type-stub) #(0 0 0) #*111)) 6))
+      (assert (equalp (concatenate `(,@type-stub) #(0 0 0) #*111)
+                      (coerce #(0 0 0 1 1 1) `(,@type-stub))))
+      (assert (= (length (concatenate `(,@type-stub 6) #(0 0 0) #*111)) 6))
+      (assert (equalp (concatenate `(,@type-stub 6) #(0 0 0) #*111)
+                      (coerce #(0 0 0 1 1 1) `(,@type-stub 6))))
+      (assert-type-error (concatenate `(,@type-stub 5) #(0 0 0) #*111))
+      ;; MERGE
+      (macrolet ((test (type)
+                   `(merge ,type (copy-seq #(0 1 0)) (copy-seq #*111) #'>)))
+        (assert (= (length (test `(,@type-stub))) 6))
+        (assert (equalp (test `(,@type-stub))
+                        (coerce #(1 1 1 0 1 0) `(,@type-stub))))
+        (assert (= (length (test `(,@type-stub 6))) 6))
+        (assert (equalp (test `(,@type-stub 6))
+                        (coerce #(1 1 1 0 1 0) `(,@type-stub 6))))
+        (assert-type-error (test `(,@type-stub 4))))
+      ;; MAP
+      (assert (= (length (map `(,@type-stub) #'logxor #(0 0 1 1) '(0 1 0 1))) 4))
+      (assert (equalp (map `(,@type-stub) #'logxor #(0 0 1 1) '(0 1 0 1))
+                      (coerce #(0 1 1 0) `(,@type-stub))))
+      (assert (= (length (map `(,@type-stub 4) #'logxor #(0 0 1 1) '(0 1 0 1)))
+                 4))
+      (assert (equalp (map `(,@type-stub 4) #'logxor #(0 0 1 1) '(0 1 0 1))
+                      (coerce #(0 1 1 0) `(,@type-stub 4))))
+      (assert-type-error (map `(,@type-stub 5) #'logxor #(0 0 1 1) '(0 1 0 1))))
+    ;; some more CONCATENATE tests for strings
+    (locally
+        (declare (optimize safety))
+      (assert (string= (concatenate 'string "foo" " " "bar") "foo bar"))
+      (assert (string= (concatenate '(string 7) "foo" " " "bar") "foo bar"))
+      (assert-type-error (concatenate '(string 6) "foo" " " "bar"))
+      (assert (string= (concatenate '(string 6) "foo" #(#\b #\a #\r)) "foobar"))
+      (assert (string= (concatenate '(string 6) #(#\b #\a #\r) "foo") "barfoo"))
+      (assert-type-error (concatenate '(string 7) "foo" #(#\b #\a #\r))))
+    ;; Non-VECTOR ARRAY types aren't allowed as vector type specifiers.
+    (locally
+        (declare (optimize safety))
+      (assert-type-error (concatenate 'simple-array "foo" "bar"))
+      (assert-type-error (map 'simple-array #'identity '(1 2 3)))
+      (assert (equalp #(11 13)
+                      (map '(simple-array fixnum (*)) #'+ '(1 2 3) '(10 11))))
+      (assert-type-error (coerce '(1 2 3) 'simple-array))
+      (assert-type-error (merge 'simple-array (list 1 3) (list 2 4) '<))
+      (assert (equalp #(3 2 1) (coerce '(3 2 1) '(vector fixnum))))
+      (assert-type-error (map 'array #'identity '(1 2 3)))
+      (assert-type-error (map '(array fixnum) #'identity '(1 2 3)))
+      (assert (equalp #(1 2 3) (coerce '(1 2 3) '(vector fixnum))))
+      ;; but COERCE has an exemption clause:
+      (assert (string= "foo" (coerce "foo" 'simple-array)))
+      ;; ... though not in all cases.
+      (assert-type-error (coerce '(#\f #\o #\o) 'simple-array)))))
+
+;; CONCATENATE used to fail for generic sequences for result-type NULL.
+(with-test (:name (concatenate :result-type-null :bug-1162301))
+  (assert (sequence:emptyp (concatenate 'null)))
+
+  (for-every-seq #()
+    '((sequence:emptyp (concatenate 'null seq))
+      (sequence:emptyp (concatenate 'null seq seq))
+      (sequence:emptyp (concatenate 'null seq #()))
+      (sequence:emptyp (concatenate 'null seq ""))))
+
+  (for-every-seq #(1)
+    (mapcar (lambda (form)
+              `(typep (nth-value 1 (ignore-errors ,form)) 'type-error))
+            '((concatenate 'null seq)
+              (concatenate 'null seq seq)
+              (concatenate 'null seq #())
+              (concatenate 'null seq "2")))))

 
 ;;; As pointed out by Raymond Toy on #lisp IRC, MERGE had some issues
 ;;; with user-defined types until sbcl-0.7.8.11
 
 ;;; As pointed out by Raymond Toy on #lisp IRC, MERGE had some issues
 ;;; with user-defined types until sbcl-0.7.8.11

-(deftype list-typeoid () 'list)
-(assert (equal '(1 2 3 4) (merge 'list-typeoid (list 1 3) (list 2 4) '<)))
+(with-test (:name :merge-user-types)
+ (deftype list-typeoid () 'list)
+ (assert (equal '(1 2 3 4) (merge 'list-typeoid (list 1 3) (list 2 4) '<)))

 ;;; and also with types that weren't precicely LIST
 ;;; and also with types that weren't precicely LIST

-(assert (equal '(1 2 3 4) (merge 'cons (list 1 3) (list 2 4) '<)))
+ (assert (equal '(1 2 3 4) (merge 'cons (list 1 3) (list 2 4) '<))))

 
 ;;; but wait, there's more! The NULL and CONS types also have implicit
 ;;; length requirements:
 
 ;;; but wait, there's more! The NULL and CONS types also have implicit
 ;;; length requirements:

-(macrolet ((assert-type-error (form)
-             `(assert (typep (nth-value 1 (ignore-errors ,form))
-                             'type-error))))
-  (locally
-      (declare (optimize safety))
-    ;; MAKE-SEQUENCE
-    (assert-type-error (make-sequence 'cons 0))
-    (assert-type-error (make-sequence 'null 1))
-    (assert-type-error (make-sequence '(cons t null) 0))
-    (assert-type-error (make-sequence '(cons t null) 2))
-    ;; KLUDGE: I'm not certain that this test actually tests for what
-    ;; it should test, in that the type deriver and optimizers might
-    ;; be too smart for the good of an exhaustive test system.
-    ;; However, it makes me feel good.  -- CSR, 2002-10-18
-    (assert (null (make-sequence 'null 0)))
-    (assert (= (length (make-sequence 'cons 3)) 3))
-    (assert (= (length (make-sequence '(cons t null) 1)) 1))
-    ;; and NIL is not a valid type for MAKE-SEQUENCE
-    (assert-type-error (make-sequence 'nil 0))
-    ;; COERCE
-    (assert-type-error (coerce #(1) 'null))
-    (assert-type-error (coerce #() 'cons))
-    (assert-type-error (coerce #() '(cons t null)))
-    (assert-type-error (coerce #(1 2) '(cons t null)))
-    (assert (null (coerce #() 'null)))
-    (assert (= (length (coerce #(1) 'cons)) 1))
-    (assert (= (length (coerce #(1) '(cons t null))) 1))
-    (assert-type-error (coerce #() 'nil))
-    ;; MERGE
-    (assert-type-error (merge 'null (list 1 3) (list 2 4) '<))
-    (assert-type-error (merge 'cons () () '<))
-    (assert (null (merge 'null () () '<)))
-    (assert (= (length (merge 'cons (list 1 3) (list 2 4) '<)) 4))
-    (assert (= (length (merge '(cons t (cons t (cons t (cons t null))))
-                              (list 1 3) (list 2 4)
-                              '<))
-               4))
-    (assert-type-error (merge 'nil () () '<))
-    ;; CONCATENATE
-    (assert-type-error (concatenate 'null '(1) "2"))
-    (assert-type-error (concatenate 'cons #() ()))
-    (assert-type-error (concatenate '(cons t null) #(1 2 3) #(4 5 6)))
-    (assert (null (concatenate 'null () #())))
-    (assert (= (length (concatenate 'cons #() '(1) "2 3")) 4))
-    (assert (= (length (concatenate '(cons t cons) '(1) "34")) 3))
-    (assert-type-error (concatenate 'nil '(3)))
-    ;; FIXME: tests for MAP to come when some brave soul implements
-    ;; the analogous type checking for MAP/%MAP.
-    ))
+(with-test (:name :sequence-functions-list-types)
+  (macrolet ((assert-type-error (form)
+               `(assert (typep (nth-value 1 (ignore-errors ,form))
+                               'type-error))))
+    (locally
+        (declare (optimize safety))
+      ;; MAKE-SEQUENCE
+      (assert-type-error (make-sequence 'cons 0))
+      (assert-type-error (make-sequence 'null 1))
+      (assert-type-error (make-sequence '(cons t null) 0))
+      (assert-type-error (make-sequence '(cons t null) 2))
+      ;; KLUDGE: I'm not certain that this test actually tests for what
+      ;; it should test, in that the type deriver and optimizers might
+      ;; be too smart for the good of an exhaustive test system.
+      ;; However, it makes me feel good.  -- CSR, 2002-10-18
+      (assert (null (make-sequence 'null 0)))
+      (assert (= (length (make-sequence 'cons 3)) 3))
+      (assert (= (length (make-sequence '(cons t null) 1)) 1))
+      ;; and NIL is not a valid type for MAKE-SEQUENCE
+      (assert-type-error (make-sequence 'nil 0))
+      ;; COERCE
+      (assert-type-error (coerce #(1) 'null))
+      (assert-type-error (coerce #() 'cons))
+      (assert-type-error (coerce #() '(cons t null)))
+      (assert-type-error (coerce #(1 2) '(cons t null)))
+      (assert (null (coerce #() 'null)))
+      (assert (= (length (coerce #(1) 'cons)) 1))
+      (assert (= (length (coerce #(1) '(cons t null))) 1))
+      (assert-type-error (coerce #() 'nil))
+      ;; MERGE
+      (assert-type-error (merge 'null (list 1 3) (list 2 4) '<))
+      (assert-type-error (merge 'cons () () '<))
+      (assert (null (merge 'null () () '<)))
+      (assert (= (length (merge 'cons (list 1 3) (list 2 4) '<)) 4))
+      (assert (= (length (merge '(cons t (cons t (cons t (cons t null))))
+                                (list 1 3) (list 2 4)
+                                '<))
+                 4))
+      (assert-type-error (merge 'nil () () '<))
+      ;; CONCATENATE
+      (assert-type-error (concatenate 'cons #() ()))
+      (assert-type-error (concatenate '(cons t null) #(1 2 3) #(4 5 6)))
+      (assert (= (length (concatenate 'cons #() '(1) "2 3")) 4))
+      (assert (= (length (concatenate '(cons t cons) '(1) "34")) 3))
+      (assert-type-error (concatenate 'nil '(3)))
+      ;; FIXME: tests for MAP to come when some brave soul implements
+      ;; the analogous type checking for MAP/%MAP.
+      )))

 \f
 ;;; ELT should signal an error of type TYPE-ERROR if its index
 ;;; argument isn't a valid sequence index for sequence:
 \f
 ;;; ELT should signal an error of type TYPE-ERROR if its index
 ;;; argument isn't a valid sequence index for sequence:

@@ -957,7 +1011,8 @@
                                      standard bashed)
               ;; fill vectors
               ;; a) the standard slow way
                                      standard bashed)
               ;; fill vectors
               ;; a) the standard slow way

-              (fill standard c :start offset :end (+ offset n))
+              (locally (declare (notinline fill))
+                (fill standard c :start offset :end (+ offset n)))

               ;; b) the blazingly fast way
               (let ((value (loop for i from 0 by bitsize
                                  until (= i sb-vm:n-word-bits)
               ;; b) the blazingly fast way
               (let ((value (loop for i from 0 by bitsize
                                  until (= i sb-vm:n-word-bits)

@@ -1083,5 +1138,147 @@
 
 (delete-duplicates (vector #\a #\b #\c #\a)
                    :test-not (lambda (a b) (not (char-equal a b))))
 
 (delete-duplicates (vector #\a #\b #\c #\a)
                    :test-not (lambda (a b) (not (char-equal a b))))

+
+;;; FILL on lists
+(let ((l (list 1 2 3)))
+  (assert (eq l (fill l 0 :start 1 :end 2)))
+  (assert (equal l '(1 0 3)))
+  (assert (eq l (fill l 'x :start 2 :end 3)))
+  (assert (equal l '(1 0 x)))
+  (assert (eq l (fill l 'y :start 1)))
+  (assert (equal l '(1 y y)))
+  (assert (eq l (fill l 'z :end 2)))
+  (assert (equal l '(z z y)))
+  (assert (eq l (fill l 1)))
+  (assert (equal l '(1 1 1)))
+  (assert (raises-error? (fill l 0 :start 4)))
+  (assert (raises-error? (fill l 0 :end 4)))
+  (assert (raises-error? (fill l 0 :start 2 :end 1))))
+
+;;; Both :TEST and :TEST-NOT provided
+(with-test (:name :test-and-test-not-to-adjoin)
+  (let* ((wc 0)
+         (fun
+          (handler-bind (((and warning (not style-warning))
+                          (lambda (w) (incf wc))))
+            (compile nil `(lambda (item test test-not) (adjoin item '(1 2 3 :foo)
+                                                               :test test
+                                                               :test-not test-not))))))
+    (assert (= 1 wc))
+    (assert (eq :error
+                (handler-case
+                    (funcall fun 1 #'eql (complement #'eql))
+                  (error ()
+                    :error))))))

 \f
 \f

+;;; tests of deftype types equivalent to STRING or SIMPLE-STRING
+(deftype %string () 'string)
+(deftype %simple-string () 'simple-string)
+(deftype string-3 () '(string 3))
+(deftype simple-string-3 () '(simple-string 3))
+
+(with-test (:name :user-defined-string-types-map-etc)
+  (dolist (type '(%string %simple-string string-3 simple-string-3))
+    (assert (string= "foo" (coerce '(#\f #\o #\o) type)))
+    (assert (string= "foo" (map type 'identity #(#\f #\o #\o))))
+    (assert (string= "foo" (merge type '(#\o) '(#\f #\o) 'char<)))
+    (assert (string= "foo" (concatenate type '(#\f) "oo")))
+    (assert (string= "ooo" (make-sequence type 3 :initial-element #\o)))))
+(with-test (:name :user-defined-string-types-map-etc-error)
+  (dolist (type '(string-3 simple-string-3))
+    (assert (raises-error? (coerce '(#\q #\u #\u #\x) type)))
+    (assert (raises-error? (map type 'identity #(#\q #\u #\u #\x))))
+    (assert (raises-error? (merge type '(#\q #\x) "uu" 'char<)))
+    (assert (raises-error? (concatenate type "qu" '(#\u #\x))))
+    (assert (raises-error? (make-sequence type 4 :initial-element #\u)))))
+
+(defun test-bit-position (size set start end from-end res)
+  (let ((v (make-array size :element-type 'bit :initial-element 0)))
+    (dolist (i set)
+      (setf (bit v i) 1))
+    (dolist (f (list (compile nil
+                              `(lambda (b v s e fe)
+                                 (position b (the bit-vector v) :start s :end e :from-end fe)))
+                     (compile nil
+                              `(lambda (b v s e fe)
+                                 (assert (eql b 1))
+                                 (position 1 (the bit-vector v) :start s :end e :from-end fe)))
+                     (compile nil
+                              `(lambda (b v s e fe)
+                                 (position b (the vector v) :start s :end e :from-end fe)))))
+      (let ((got (funcall f 1 v start end from-end)))
+        (unless (eql res got)
+          (cerror "Continue" "POSITION 1, Wanted ~S, got ~S.~%  size = ~S, set = ~S, from-end = ~S"
+                  res got
+                  size set from-end)))))
+  (let ((v (make-array size :element-type 'bit :initial-element 1)))
+    (dolist (i set)
+      (setf (bit v i) 0))
+    (dolist (f (list (compile nil
+                              `(lambda (b v s e fe)
+                                 (position b (the bit-vector v) :start s :end e :from-end fe)))
+                     (compile nil
+                              `(lambda (b v s e fe)
+                                 (assert (eql b 0))
+                                 (position 0 (the bit-vector v) :start s :end e :from-end fe)))
+                     (compile nil
+                              `(lambda (b v s e fe)
+                                 (position b (the vector v) :start s :end e :from-end fe)))))
+      (let ((got (funcall f 0 v start end from-end)))
+        (unless (eql res got)
+          (cerror "Continue" "POSITION 0, Wanted ~S, got ~S.~%  size = ~S, set = ~S, from-end = ~S"
+                  res got
+                  size set from-end))))))
+
+(defun random-test-bit-position (n)
+  (loop repeat n
+        do (let* ((vector (make-array (+ 2 (random 5000)) :element-type 'bit))
+                  (offset (random (1- (length vector))))
+                  (size (1+ (random (- (length vector) offset))))
+                  (disp (make-array size :element-type 'bit :displaced-to vector
+                                         :displaced-index-offset offset)))
+             (assert (plusp size))
+             (loop repeat 10
+                   do (setf (bit vector (random (length vector))) 1))
+             (flet ((test (orig)
+                      (declare (bit-vector orig))
+                      (let ((copy (coerce orig 'simple-vector))
+                            (p0 (random (length orig)))
+                            (p1 (1+ (random (length orig)))))
+                        (multiple-value-bind (s e)
+                            (if (> p1 p0)
+                                (values p0 p1)
+                                (values p1 p0))
+                          (assert (eql (position 1 copy :start s :end e)
+                                       (position 1 orig :start s :end e)))
+                          (assert (eql (position 1 copy :start s :end e :from-end t)
+                                       (position 1 orig :start s :end e :from-end t)))))))
+               (test vector)
+               (test disp)))))
+
+(with-test (:name :bit-position)
+  (test-bit-position 0 (list) 0 0 nil nil)
+  (test-bit-position 0 (list) 0 0 t nil)
+  (test-bit-position 1 (list 0) 0 0 nil nil)
+  (test-bit-position 1 (list 0) 0 0 t nil)
+  (test-bit-position 1 (list 0) 0 1 nil 0)
+  (test-bit-position 1 (list 0) 0 1 t 0)
+  (test-bit-position 10 (list 0 1) 0 1 nil 0)
+  (test-bit-position 10 (list 0 1) 1 1 nil nil)
+  (test-bit-position 10 (list 0 1) 0 1 t 0)
+  (test-bit-position 10 (list 0 1) 1 1 t nil)
+  (test-bit-position 10 (list 0 3) 1 4 nil 3)
+  (test-bit-position 10 (list 0 3) 1 4 t 3)
+  (test-bit-position 10 (list 0 3 6) 1 10 nil 3)
+  (test-bit-position 10 (list 0 3 6) 1 10 t 6)
+  (test-bit-position 1000 (list 128 700) 20 500 nil 128)
+  (test-bit-position 1000 (list 128 700) 20 500 t 128)
+  (test-bit-position 1000 (list 423 762) 200 800 nil 423)
+  (test-bit-position 1000 (list 423 762) 200 800 t 762)
+  (test-bit-position 1000 (list 298 299) 100 400 nil 298)
+  (test-bit-position 1000 (list 298 299) 100 400 t 299))
+
+(with-test (:name (:bit-position :random-test))
+  (random-test-bit-position 10000))
+

 ;;; success
 ;;; success