0.8.1.34:
authorChristophe Rhodes <csr21@cam.ac.uk>
Wed, 16 Jul 2003 08:25:59 +0000 (08:25 +0000)
committerChristophe Rhodes <csr21@cam.ac.uk>
Wed, 16 Jul 2003 08:25:59 +0000 (08:25 +0000)
Merge vector_nil_string_branch
... many other incremental fixes, including
* decrease of number of places array properties need to be
  specified;
* rework of build order so that unknown types are never
  specialized;
* primitive types need to know the specifier, not the ctype, so
  make it so;
* fixes to the kernel classoid hierarchy, so more likely to be
  consistent internally.

The good news is that, should it prove necessary, reverting this patch
so that (vector nil) isn't a string is probably not very much work; all
that needs to be changed are the kernel classoid supertypes and the
STRING and SIMPLE-STRING definitions (and unparses).  On the other hand,
I'd be interested in trying to fix any performance problem "the right
way" before reverting this behaviour.

15 files changed:
1  2 
build-order.lisp-expr
package-data-list.lisp-expr
src/code/array.lisp
src/code/deftypes-for-target.lisp
src/code/early-extensions.lisp
src/code/late-type.lisp
src/code/seq.lisp
src/code/stream.lisp
src/code/string.lisp
src/compiler/array-tran.lisp
src/compiler/fndb.lisp
src/compiler/generic/vm-tran.lisp
src/compiler/generic/vm-type.lisp
src/compiler/knownfun.lisp
version.lisp-expr

diff --combined build-order.lisp-expr
@@@ -73,7 -73,6 +73,7 @@@
   ;;; supplied by basic machinery
  
   ("src/code/cross-misc"  :not-target)
 + ("src/code/cross-char"  :not-target)
   ("src/code/cross-byte"  :not-target)
   ("src/code/cross-float" :not-target)
   ("src/code/cross-io"    :not-target)
   ;; in class.lisp.
   ("src/code/condition" :not-host)
  
+  ("src/compiler/generic/vm-array")
   ("src/compiler/generic/primtype")
  
   ;; the implementation of the compiler-affecting part of forms like
   ("src/code/cross-type" :not-target)
   ("src/compiler/generic/vm-type")
   ("src/compiler/proclaim")
+  ("src/code/class-init")
   ("src/code/typecheckfuns")
  
   ;; The DEFSTRUCT machinery needs SB!XC:SUBTYPEP, defined in 
   ("src/compiler/compiler-error")
  
   ("src/code/type-init")
+  ;; Now that the type system is initialized, fix up UNKNOWN types that
+  ;; have crept in.
+  ("src/compiler/fixup-type")
  
   ;; These define target types needed by fndb.lisp.
   ("src/code/package")
@@@ -884,7 -884,6 +884,7 @@@ retained, possibly temporariliy, becaus
               "EVAL-IN-LEXENV"
             "DEBUG-NAMIFY"
               "FORCE" "DELAY" "PROMISE-READY-P"
 +           "FIND-RESTART-OR-CONTROL-ERROR"
  
               ;; These could be moved back into SB!EXT if someone has
               ;; compelling reasons, but hopefully we can get by
@@@ -1027,7 -1026,7 +1027,7 @@@ is a good idea, but see SB-SYS re. blur
               "ARRAY-TYPE-DIMENSIONS" "ARRAY-TYPE-ELEMENT-TYPE"
               "ARRAY-TYPE-P"
               "ARRAY-TYPE-SPECIALIZED-ELEMENT-TYPE" "ASH-INDEX"
-              "ASSERT-ERROR" "BASE-CHAR-P"
+              "ASSERT-ERROR" "BASE-CHAR-P" "BASE-STRING-P"
               "BINDING-STACK-POINTER-SAP" "BIT-BASH-COPY"
               "BIT-INDEX" "BOGUS-ARG-TO-VALUES-LIST-ERROR"
               "BOOLE-CODE"
               "FIND-AND-INIT-OR-CHECK-LAYOUT"
               "FLOAT-EXPONENT" "FLOAT-FORMAT-DIGITS" "FLOAT-FORMAT-NAME"
               "FLOAT-FORMAT-MAX" "FLOATING-POINT-EXCEPTION"
 -             "FORM" "*FREE-INTERRUPT-CONTEXT-INDEX*" "FUNCALLABLE-INSTANCE-P"
 +             "FORM"
 +             "FORMAT-CONTROL"
 +             "*FREE-INTERRUPT-CONTEXT-INDEX*" "FUNCALLABLE-INSTANCE-P"
               "FUN-CODE-HEADER"
               "FUN-TYPE" "FUN-TYPE-ALLOWP"
               "FUN-TYPE-KEYP" "FUN-TYPE-KEYWORDS"
               "GENERALIZED-BOOLEAN"
               "GET-CLOSURE-LENGTH"
               "GET-HEADER-DATA"
 -             "GET-LISP-OBJ-ADDRESS" "LOWTAG-OF"
 -             "WIDETAG-OF"
 +             "GET-LISP-OBJ-ADDRESS" "LOWTAG-OF" "WIDETAG-OF"
 +           "GET-MACHINE-VERSION"
               "HAIRY-DATA-VECTOR-REF" "HAIRY-DATA-VECTOR-SET" "HAIRY-TYPE"
               "HAIRY-TYPE-CHECK-TEMPLATE-NAME" "HAIRY-TYPE-SPECIFIER"
               "HANDLE-CIRCULARITY" "HOST" "IGNORE-IT"
               "NUMERIC-TYPE-FORMAT"
               "NUMERIC-TYPE-HIGH" "NUMERIC-TYPE-LOW" "NUMERIC-TYPE-P"
               "OBJECT-NOT-ARRAY-ERROR" "OBJECT-NOT-BASE-CHAR-ERROR"
+            "OBJECT-NOT-BASE-STRING-ERROR"
               "OBJECT-NOT-BIGNUM-ERROR" "OBJECT-NOT-BIT-VECTOR-ERROR"
               "OBJECT-NOT-COMPLEX-ERROR"
               "OBJECT-NOT-COMPLEX-FLOAT-ERROR"
               "OBJECT-NOT-SIMPLE-ARRAY-SIGNED-BYTE-32-ERROR"
               "OBJECT-NOT-SIMPLE-ARRAY-SIGNED-BYTE-8-ERROR"
               "OBJECT-NOT-SIMPLE-BIT-VECTOR-ERROR"
+            "OBJECT-NOT-SIMPLE-BASE-STRING-ERROR"
               "OBJECT-NOT-SIMPLE-STRING-ERROR"
               "OBJECT-NOT-SIMPLE-VECTOR-ERROR"
               "OBJECT-NOT-SINGLE-FLOAT-ERROR" "OBJECT-NOT-STRING-ERROR"
               #!+x86 "*PSEUDO-ATOMIC-INTERRUPTED*"
               "PUNT-PRINT-IF-TOO-LONG"
               "READER-IMPOSSIBLE-NUMBER-ERROR" "READER-PACKAGE-ERROR"
 +             "RESTART-DESIGNATOR"
               "SCALE-DOUBLE-FLOAT"
             #!+long-float "SCALE-LONG-FLOAT"
               "SCALE-SINGLE-FLOAT"
               "SIMPLE-ARRAY-SIGNED-BYTE-30-P"
               "SIMPLE-ARRAY-SIGNED-BYTE-32-P"
               "SIMPLE-ARRAY-SIGNED-BYTE-8-P"
+            "SIMPLE-BASE-STRING-P"
               "SIMPLE-PACKAGE-ERROR"
               "SIMPLE-UNBOXED-ARRAY"
               "SINGLE-FLOAT-BITS" "SINGLE-FLOAT-EXPONENT"
               "VALUES-SPECIFIER-TYPE-CACHE-CLEAR" "VALUES-SUBTYPEP"
               "VALUES-TYPE"
               "VALUES-TYPE-ERROR"
 +             "VALUES-TYPE-IN"
               "VALUES-TYPE-INTERSECTION"
               "VALUES-TYPE-OPTIONAL"
 +             "VALUES-TYPE-OUT"
               "VALUES-TYPE-P" "VALUES-TYPE-REQUIRED"
               "VALUES-TYPE-REST" "VALUES-TYPE-UNION"
               "VALUES-TYPE-TYPES" "VALUES-TYPES"
 -             "VALUES-TYPE-START"
               "VALUES-TYPES-EQUAL-OR-INTERSECT" "VECTOR-T-P"
+            "VECTOR-NIL-P"
               "VECTOR-TO-VECTOR*"
               "VECTOR-OF-CHECKED-LENGTH-GIVEN-LENGTH"
               "WITH-ARRAY-DATA"
               "!TYPE-CLASS-COLD-INIT" "!TYPEDEFS-COLD-INIT"
               "!ALIEN-TYPE-COLD-INIT" "!CLASSES-COLD-INIT"
               "!EARLY-TYPE-COLD-INIT" "!LATE-TYPE-COLD-INIT"
+            "!FIXUP-TYPE-COLD-INIT"
               "!TARGET-TYPE-COLD-INIT" "!RANDOM-COLD-INIT"
               "!READER-COLD-INIT" "!TYPECHECKFUNS-COLD-INIT"
               "STREAM-COLD-INIT-OR-RESET" "!LOADER-COLD-INIT"
@@@ -1918,7 -1918,8 +1923,8 @@@ structure representations
               "COMPLEX-SINGLE-FLOAT-IMAG-SLOT" "COMPLEX-SINGLE-FLOAT-REAL-SLOT"
               "COMPLEX-SINGLE-FLOAT-SIZE" "COMPLEX-SINGLE-FLOAT-WIDETAG"
               "COMPLEX-SINGLE-REG-SC-NUMBER" "COMPLEX-SINGLE-STACK-SC-NUMBER"
-              "COMPLEX-SIZE" "COMPLEX-STRING-WIDETAG" "COMPLEX-WIDETAG"
+              "COMPLEX-SIZE" "COMPLEX-BASE-STRING-WIDETAG" "COMPLEX-WIDETAG"
+            "COMPLEX-VECTOR-NIL-WIDETAG"
               "COMPLEX-VECTOR-WIDETAG" "CONS-CAR-SLOT" "CONS-CDR-SLOT"
               "CONS-SIZE" "CONSTANT-SC-NUMBER"
               "CONTEXT-FLOATING-POINT-MODES" "CONTEXT-FLOAT-REGISTER"
               "*READ-ONLY-SPACE-FREE-POINTER*"
               "REGISTER-SAVE-PENALTY" "RETURN-PC-HEADER-WIDETAG"
               "RETURN-PC-RETURN-POINT-OFFSET" "RETURN-PC-SAVE-OFFSET"
+            "SAETP-CTYPE" "SAETP-INITIAL-ELEMENT-DEFAULT"
+            "SAETP-N-BITS" "SAETP-TYPECODE" "SAETP-PRIMITIVE-TYPE-NAME"
+            "SAETP-N-PAD-ELEMENTS" "SAETP-SPECIFIER"
+            "SAETP-COMPLEX-TYPECODE" "SAETP-IMPORTANCE"
+            "*SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*"
             "SANCTIFY-FOR-EXECUTION"
               "SAP-POINTER-SLOT" "SAP-REG-SC-NUMBER" "SAP-SIZE"
               "SAP-STACK-SC-NUMBER" "SAP-WIDETAG"
               "SIMPLE-ARRAY-SIGNED-BYTE-32-WIDETAG"
               "SIMPLE-ARRAY-SIGNED-BYTE-8-WIDETAG"
               "SIMPLE-BIT-VECTOR-WIDETAG"
-              "SIMPLE-STRING-WIDETAG"
+              "SIMPLE-BASE-STRING-WIDETAG"
             "SIMPLE-VECTOR-WIDETAG" "SINGLE-FLOAT-BIAS"
               "SINGLE-FLOAT-DIGITS" "SINGLE-FLOAT-EXPONENT-BYTE"
               "SINGLE-FLOAT-HIDDEN-BIT" "SINGLE-FLOAT-NORMAL-EXPONENT-MAX"
diff --combined src/code/array.lisp
    (bug "called FAILED-%WITH-ARRAY-DATA with valid array parameters?"))
  \f
  ;;;; MAKE-ARRAY
 -(defun upgraded-array-element-type (spec &optional environment)
 -  #!+sb-doc
 -  "Return the element type that will actually be used to implement an array
 -   with the specifier :ELEMENT-TYPE Spec."
 -  (declare (ignore environment))
 -  (if (unknown-type-p (specifier-type spec))
 -      (error "undefined type: ~S" spec)
 -      (type-specifier (array-type-specialized-element-type
 -                     (specifier-type `(array ,spec))))))
  (eval-when (:compile-toplevel :execute)
    (sb!xc:defmacro pick-vector-type (type &rest specs)
      `(cond ,@(mapcar (lambda (spec)
      ;; and for all in any reasonable user programs.)
      ((t)
       (values #.sb!vm:simple-vector-widetag #.sb!vm:n-word-bits))
-     ((character base-char standard-char)
-      (values #.sb!vm:simple-string-widetag #.sb!vm:n-byte-bits))
+     ((base-char standard-char)
+      (values #.sb!vm:simple-base-string-widetag #.sb!vm:n-byte-bits))
      ((bit)
       (values #.sb!vm:simple-bit-vector-widetag 1))
      ;; OK, we have to wade into SUBTYPEPing after all.
      (t
-      ;; FIXME: The data here are redundant with
-      ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*.
-      (pick-vector-type type
-        (nil (values #.sb!vm:simple-array-nil-widetag 0))
-        (base-char (values #.sb!vm:simple-string-widetag #.sb!vm:n-byte-bits))
-        (bit (values #.sb!vm:simple-bit-vector-widetag 1))
-        ((unsigned-byte 2)
-       (values #.sb!vm:simple-array-unsigned-byte-2-widetag 2))
-        ((unsigned-byte 4)
-       (values #.sb!vm:simple-array-unsigned-byte-4-widetag 4))
-        ((unsigned-byte 8)
-       (values #.sb!vm:simple-array-unsigned-byte-8-widetag 8))
-        ((unsigned-byte 16)
-       (values #.sb!vm:simple-array-unsigned-byte-16-widetag 16))
-        ((unsigned-byte 32)
-       (values #.sb!vm:simple-array-unsigned-byte-32-widetag 32))
-        ((signed-byte 8)
-       (values #.sb!vm:simple-array-signed-byte-8-widetag 8))
-        ((signed-byte 16)
-       (values #.sb!vm:simple-array-signed-byte-16-widetag 16))
-        ((signed-byte 30)
-       (values #.sb!vm:simple-array-signed-byte-30-widetag 32))
-        ((signed-byte 32)
-       (values #.sb!vm:simple-array-signed-byte-32-widetag 32))
-        (single-float (values #.sb!vm:simple-array-single-float-widetag 32))
-        (double-float (values #.sb!vm:simple-array-double-float-widetag 64))
-        #!+long-float
-        (long-float
-       (values #.sb!vm:simple-array-long-float-widetag
-               #!+x86 96 #!+sparc 128))
-        ((complex single-float)
-       (values #.sb!vm:simple-array-complex-single-float-widetag 64))
-        ((complex double-float)
-       (values #.sb!vm:simple-array-complex-double-float-widetag 128))
-        #!+long-float
-        ((complex long-float)
-       (values #.sb!vm:simple-array-complex-long-float-widetag
-               #!+x86 192
-               #!+sparc 256))
-        (t (values #.sb!vm:simple-vector-widetag #.sb!vm:n-word-bits))))))
+      #.`(pick-vector-type type
+        ,@(map 'list
+               (lambda (saetp)
+                 `(,(sb!vm:saetp-specifier saetp)
+                   (values ,(sb!vm:saetp-typecode saetp)
+                           ,(sb!vm:saetp-n-bits saetp))))
+               sb!vm:*specialized-array-element-type-properties*)))))
  (defun %complex-vector-widetag (type)
    (case type
      ;; Pick off some easy common cases.
      ((t)
       #.sb!vm:complex-vector-widetag)
-     ((character base-char)
-      #.sb!vm:complex-string-widetag) 
+     ((base-char)
+      #.sb!vm:complex-base-string-widetag)
+     ((nil)
+      #.sb!vm:complex-vector-nil-widetag)
      ((bit)
       #.sb!vm:complex-bit-vector-widetag)
      ;; OK, we have to wade into SUBTYPEPing after all.
      (t
       (pick-vector-type type
-        (base-char #.sb!vm:complex-string-widetag)
+        (nil #.sb!vm:complex-vector-nil-widetag)
+        (base-char #.sb!vm:complex-base-string-widetag)
         (bit #.sb!vm:complex-bit-vector-widetag)
         (t #.sb!vm:complex-vector-widetag)))))
  
                 (array (allocate-vector
                         type
                         length
-                        (ceiling (* (if (= type sb!vm:simple-string-widetag)
+                        (ceiling (* (if (= type sb!vm:simple-base-string-widetag)
                                         (1+ length)
                                         length)
                                     n-bits)
    (coerce (the list objects) 'simple-vector))
  \f
  ;;;; accessor/setter functions
- (eval-when (:compile-toplevel :execute)
-   (defparameter *specialized-array-element-types*
-     '(t
-       character
-       bit
-       (unsigned-byte 2)
-       (unsigned-byte 4)
-       (unsigned-byte 8)
-       (unsigned-byte 16)
-       (unsigned-byte 32)
-       (signed-byte 8)
-       (signed-byte 16)
-       (signed-byte 30)
-       (signed-byte 32)
-       single-float
-       double-float
-       #!+long-float long-float
-       (complex single-float)
-       (complex double-float)
-       #!+long-float (complex long-float)
-       nil)))
-     
  (defun hairy-data-vector-ref (array index)
    (with-array-data ((vector array) (index index) (end))
      (declare (ignore end))
      (etypecase vector .
-              #.(mapcar (lambda (type)
-                          (let ((atype `(simple-array ,type (*))))
-                            `(,atype
-                              (data-vector-ref (the ,atype vector)
-                                               index))))
-                        *specialized-array-element-types*))))
+              #.(map 'list
+                     (lambda (saetp)
+                       (let* ((type (sb!vm:saetp-specifier saetp))
+                              (atype `(simple-array ,type (*))))
+                         `(,atype
+                           (data-vector-ref (the ,atype vector) index))))
+                     (sort
+                      (copy-seq
+                       sb!vm:*specialized-array-element-type-properties*)
+                      #'> :key #'sb!vm:saetp-importance)))))
  
  ;;; (Ordinary DATA-VECTOR-REF usage compiles into a vop, but
  ;;; DATA-VECTOR-REF is also FOLDABLE, and this ordinary function
    (with-array-data ((vector array) (index index) (end))
      (declare (ignore end))
      (etypecase vector .
-              #.(mapcar (lambda (type)
-                          (let ((atype `(simple-array ,type (*))))
-                            `(,atype
-                              (data-vector-set (the ,atype vector)
-                                               index
-                                               (the ,type
-                                                 new-value))
-                              ;; For specialized arrays, the return
-                              ;; from data-vector-set would have to
-                              ;; be reboxed to be a (Lisp) return
-                              ;; value; instead, we use the
-                              ;; already-boxed value as the return.
-                              new-value)))
-                        *specialized-array-element-types*))))
+              #.(map 'list
+                     (lambda (saetp)
+                       (let* ((type (sb!vm:saetp-specifier saetp))
+                              (atype `(simple-array ,type (*))))
+                         `(,atype
+                           (data-vector-set (the ,atype vector) index
+                                            (the ,type new-value))
+                           ;; For specialized arrays, the return from
+                           ;; data-vector-set would have to be
+                           ;; reboxed to be a (Lisp) return value;
+                           ;; instead, we use the already-boxed value
+                           ;; as the return.
+                           new-value)))
+                     (sort
+                      (copy-seq
+                       sb!vm:*specialized-array-element-type-properties*)
+                      #'> :key #'sb!vm:saetp-importance)))))
  
  (defun %array-row-major-index (array subscripts
                                     &optional (invalid-index-error-p t))
          (let ((index (car subs))
                (dim (%array-dimension array axis)))
            (declare (fixnum dim))
 -          (unless (< -1 index dim)
 +          (unless (and (fixnump index) (< -1 index dim))
              (if invalid-index-error-p
                  (error 'simple-type-error
                         :format-control "invalid index ~W~[~;~:; on axis ~:*~W~] in ~S"
            (setf chunk-size (* chunk-size dim))))
        (let ((index (first subscripts))
              (length (length (the (simple-array * (*)) array))))
 -        (unless (< -1 index length)
 +        (unless (and (fixnump index) (< -1 index length))
            (if invalid-index-error-p
                ;; FIXME: perhaps this should share a format-string
                ;; with INVALID-ARRAY-INDEX-ERROR or
  
  (defun array-in-bounds-p (array &rest subscripts)
    #!+sb-doc
 -  "Return T if the Subscipts are in bounds for the Array, Nil otherwise."
 +  "Return T if the SUBSCIPTS are in bounds for the ARRAY, NIL otherwise."
    (if (%array-row-major-index array subscripts nil)
        t))
  
  
  (defun aref (array &rest subscripts)
    #!+sb-doc
 -  "Return the element of the Array specified by the Subscripts."
 +  "Return the element of the ARRAY specified by the SUBSCRIPTS."
    (row-major-aref array (%array-row-major-index array subscripts)))
  
  (defun %aset (array &rest stuff)
                                              `(= widetag ,item))))
                                     (cdr stuff)))
                                  stuff))))
-       ;; FIXME: The data here are redundant with
-       ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*.
-       (pick-element-type
-        (sb!vm:simple-array-nil-widetag nil)
-        ((sb!vm:simple-string-widetag sb!vm:complex-string-widetag) 'base-char)
-        ((sb!vm:simple-bit-vector-widetag
-        sb!vm:complex-bit-vector-widetag) 'bit)
-        (sb!vm:simple-vector-widetag t)
-        (sb!vm:simple-array-unsigned-byte-2-widetag '(unsigned-byte 2))
-        (sb!vm:simple-array-unsigned-byte-4-widetag '(unsigned-byte 4))
-        (sb!vm:simple-array-unsigned-byte-8-widetag '(unsigned-byte 8))
-        (sb!vm:simple-array-unsigned-byte-16-widetag '(unsigned-byte 16))
-        (sb!vm:simple-array-unsigned-byte-32-widetag '(unsigned-byte 32))
-        (sb!vm:simple-array-signed-byte-8-widetag '(signed-byte 8))
-        (sb!vm:simple-array-signed-byte-16-widetag '(signed-byte 16))
-        (sb!vm:simple-array-signed-byte-30-widetag '(signed-byte 30))
-        (sb!vm:simple-array-signed-byte-32-widetag '(signed-byte 32))
-        (sb!vm:simple-array-single-float-widetag 'single-float)
-        (sb!vm:simple-array-double-float-widetag 'double-float)
-        #!+long-float
-        (sb!vm:simple-array-long-float-widetag 'long-float)
-        (sb!vm:simple-array-complex-single-float-widetag
-       '(complex single-float))
-        (sb!vm:simple-array-complex-double-float-widetag
-       '(complex double-float))
-        #!+long-float
-        (sb!vm:simple-array-complex-long-float-widetag '(complex long-float))
-        ((sb!vm:simple-array-widetag
-        sb!vm:complex-vector-widetag
-        sb!vm:complex-array-widetag)
-       (with-array-data ((array array) (start) (end))
-         (declare (ignore start end))
-         (array-element-type array)))
-        (t
-       (error 'type-error :datum array :expected-type 'array))))))
+       #.`(pick-element-type
+         ,@(map 'list
+                (lambda (saetp)
+                  `(,(if (sb!vm:saetp-complex-typecode saetp)
+                         (list (sb!vm:saetp-typecode saetp)
+                               (sb!vm:saetp-complex-typecode saetp))
+                         (sb!vm:saetp-typecode saetp))
+                    ',(sb!vm:saetp-specifier saetp)))
+                sb!vm:*specialized-array-element-type-properties*)
+         ((sb!vm:simple-array-widetag
+           sb!vm:complex-vector-widetag
+           sb!vm:complex-array-widetag)
+          (with-array-data ((array array) (start) (end))
+            (declare (ignore start end))
+            (array-element-type array)))
+         (t
+          (error 'type-error :datum array :expected-type 'array))))))
  
  (defun array-rank (array)
    #!+sb-doc
    (unless (array-header-p vector)
      (macrolet ((frob (name &rest things)
                 `(etypecase ,name
-                   ((simple-array nil (*)) (error 'cell-error
-                                            :name 'nil-array-element))
+                   ((simple-array nil (*)) (error 'nil-array-accessed-error))
                    ,@(mapcar (lambda (thing)
                                (destructuring-bind (type-spec fill-value)
                                    thing
                                          ,fill-value
                                          :start new-length))))
                              things))))
-       ;; FIXME: The associations between vector types and initial
-       ;; values here are redundant with
-       ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*.
-       (frob vector
-       (simple-vector 0)
-       (simple-base-string #.*default-init-char-form*)
-       (simple-bit-vector 0)
-       ((simple-array (unsigned-byte 2) (*)) 0)
-       ((simple-array (unsigned-byte 4) (*)) 0)
-       ((simple-array (unsigned-byte 8) (*)) 0)
-       ((simple-array (unsigned-byte 16) (*)) 0)
-       ((simple-array (unsigned-byte 32) (*)) 0)
-       ((simple-array (signed-byte 8) (*)) 0)
-       ((simple-array (signed-byte 16) (*)) 0)
-       ((simple-array (signed-byte 30) (*)) 0)
-       ((simple-array (signed-byte 32) (*)) 0)
-       ((simple-array single-float (*)) (coerce 0 'single-float))
-       ((simple-array double-float (*)) (coerce 0 'double-float))
-       #!+long-float
-       ((simple-array long-float (*)) (coerce 0 'long-float))
-       ((simple-array (complex single-float) (*))
-        (coerce 0 '(complex single-float)))
-       ((simple-array (complex double-float) (*))
-        (coerce 0 '(complex double-float)))
-       #!+long-float
-       ((simple-array (complex long-float) (*))
-        (coerce 0 '(complex long-float))))))
+       #.`(frob vector
+         ,@(map 'list
+                (lambda (saetp)
+                  `((simple-array ,(sb!vm:saetp-specifier saetp) (*))
+                    ,(if (eq (sb!vm:saetp-specifier saetp) 'base-char)
+                         *default-init-char-form*
+                         (sb!vm:saetp-initial-element-default saetp))))
+                (remove-if-not
+                 #'sb!vm:saetp-specifier
+                 sb!vm:*specialized-array-element-type-properties*)))))
    ;; Only arrays have fill-pointers, but vectors have their length
    ;; parameter in the same place.
    (setf (%array-fill-pointer vector) new-length)
@@@ -54,7 -54,7 +54,7 @@@
  
  (sb!xc:deftype extended-char ()
    #!+sb-doc
-   "Type of characters that aren't base-char's. None in CMU CL."
+   "Type of CHARACTERs that aren't BASE-CHARs."
    '(and character (not base-char)))
  
  (sb!xc:deftype standard-char ()
    `(simple-array base-char (,size)))
  (sb!xc:deftype string (&optional size)
    `(or (array character (,size))
-           (base-string ,size)))
+        (array nil (,size))
+        (base-string ,size)))
  (sb!xc:deftype simple-string (&optional size)
    `(or (simple-array character (,size))
-           (simple-base-string ,size)))
+        (simple-array nil (,size))
+        (simple-base-string ,size)))
  
  (sb!xc:deftype bit-vector (&optional size)
    `(array bit (,size)))
  ;;; semistandard types
  (sb!xc:deftype generalized-boolean () t)
  
 +(sb!xc:deftype format-control ()
 +  '(or string function))
 +
 +(sb!xc:deftype restart-designator ()
 +  '(or (and symbol (not null)) restart))
 +
- ;;; a type specifier
- ;;;
- ;;; FIXME: The SB!KERNEL:INSTANCE here really means CL:CLASS.
- ;;; However, the CL:CLASS type is only defined once PCL is loaded,
- ;;; which is before this is evaluated.  Once PCL is moved into cold
- ;;; init, this might be fixable.
- (sb!xc:deftype type-specifier () '(or list symbol sb!kernel:instance))
  ;;; array rank, total size...
  (sb!xc:deftype array-rank () `(integer 0 (,sb!xc:array-rank-limit)))
  (sb!xc:deftype array-total-size ()
                        (t `(values ,@(cdr result) &optional)))))
      `(function ,args ,result)))
  
+ ;;; a type specifier
+ ;;;
+ ;;; FIXME: The SB!KERNEL:INSTANCE here really means CL:CLASS.
+ ;;; However, the CL:CLASS type is only defined once PCL is loaded,
+ ;;; which is before this is evaluated.  Once PCL is moved into cold
+ ;;; init, this might be fixable.
+ (def!type type-specifier () '(or list symbol sb!kernel:instance))
  ;;; the default value used for initializing character data. The ANSI
  ;;; spec says this is arbitrary, so we use the value that falls
  ;;; through when we just let the low-level consing code initialize
@@@ -816,7 -824,7 +824,7 @@@ which can be found at <http://sbcl.sour
    (error 'simple-type-error ; maybe should be TYPE-BUG, subclass of BUG?
         :value value
         :expected-type type
 -       :format-string "~@<~S ~_is not a ~_~S~:>"
 +       :format-control "~@<~S ~_is not a ~_~S~:>"
         :format-arguments (list value type)))
  \f
  ;;; Return a function like FUN, but expecting its (two) arguments in
diff --combined src/code/late-type.lisp
  ;;; There are all sorts of nasty problems with open bounds on FLOAT
  ;;; types (and probably FLOAT types in general.)
  
 +;;; This condition is signalled whenever we make a UNKNOWN-TYPE so that
 +;;; compiler warnings can be emitted as appropriate.
 +(define-condition parse-unknown-type (condition)
 +  ((specifier :reader parse-unknown-type-specifier :initarg :specifier)))
 +
  ;;; FIXME: This really should go away. Alas, it doesn't seem to be so
  ;;; simple to make it go away.. (See bug 123 in BUGS file.)
  (defvar *use-implementation-types* t ; actually initialized in cold init
        (return (values nil t))))))
  
  (!define-type-method (values :simple-=) (type1 type2)
 -  (let ((rest1 (args-type-rest type1))
 -      (rest2 (args-type-rest type2)))
 -    (cond ((and rest1 rest2 (type/= rest1 rest2))
 -         (type= rest1 rest2))
 -        ((or rest1 rest2)
 -         (values nil t))
 -        (t
 -         (multiple-value-bind (req-val req-win)
 -             (type=-list (values-type-required type1)
 -                         (values-type-required type2))
 -           (multiple-value-bind (opt-val opt-win)
 -               (type=-list (values-type-optional type1)
 -                           (values-type-optional type2))
 -             (values (and req-val opt-val) (and req-win opt-win))))))))
 +  (type=-args type1 type2))
  
  (!define-type-class function)
  
                     ((fun-type-wild-args type1)
                      (cond ((fun-type-keyp type2) (values nil nil))
                            ((not (fun-type-rest type2)) (values nil t))
 -                          ((not (null (fun-type-required type2))) (values nil t))
 -                          (t (and/type (type= *universal-type* (fun-type-rest type2))
 -                                       (every/type #'type= *universal-type*
 -                                                   (fun-type-optional type2))))))
 +                          ((not (null (fun-type-required type2)))
 +                         (values nil t))
 +                          (t (and/type (type= *universal-type*
 +                                            (fun-type-rest type2))
 +                                       (every/type #'type=
 +                                                 *universal-type*
 +                                                   (fun-type-optional
 +                                                  type2))))))
                     ((not (and (fun-type-simple-p type1)
                                (fun-type-simple-p type2)))
                      (values nil nil))
                            (cond ((or (> max1 max2) (< min1 min2))
                                   (values nil t))
                                  ((and (= min1 min2) (= max1 max2))
 -                                 (and/type (every-csubtypep (fun-type-required type1)
 -                                                            (fun-type-required type2))
 -                                           (every-csubtypep (fun-type-optional type1)
 -                                                            (fun-type-optional type2))))
 +                                 (and/type (every-csubtypep
 +                                          (fun-type-required type1)
 +                                          (fun-type-required type2))
 +                                           (every-csubtypep
 +                                          (fun-type-optional type1)
 +                                          (fun-type-optional type2))))
                                  (t (every-csubtypep
                                      (concatenate 'list
                                                   (fun-type-required type1)
    (declare (ignore type1 type2))
    (specifier-type 'function))
  (!define-type-method (function :simple-intersection2) (type1 type2)
 -  (declare (ignore type1 type2))
 -  (specifier-type 'function))
 +  (let ((ftype (specifier-type 'function)))
 +    (cond ((eq type1 ftype) type2)
 +          ((eq type2 ftype) type1)
 +          (t (let ((rtype (values-type-intersection (fun-type-returns type1)
 +                                                    (fun-type-returns type2))))
 +               (flet ((change-returns (ftype rtype)
 +                        (declare (type fun-type ftype) (type ctype rtype))
 +                        (make-fun-type :required (fun-type-required ftype)
 +                                       :optional (fun-type-optional ftype)
 +                                       :keyp (fun-type-keyp ftype)
 +                                       :keywords (fun-type-keywords ftype)
 +                                       :allowp (fun-type-allowp ftype)
 +                                       :returns rtype)))
 +               (cond
 +                 ((fun-type-wild-args type1)
 +                  (if (fun-type-wild-args type2)
 +                      (make-fun-type :wild-args t
 +                                     :returns rtype)
 +                      (change-returns type2 rtype)))
 +                 ((fun-type-wild-args type2)
 +                  (change-returns type1 rtype))
 +                 (t (multiple-value-bind (req opt rest)
 +                        (args-type-op type1 type2 #'type-intersection #'max)
 +                      (make-fun-type :required req
 +                                     :optional opt
 +                                     :rest rest
 +                                     ;; FIXME: :keys
 +                                     :allowp (and (fun-type-allowp type1)
 +                                                  (fun-type-allowp type2))
 +                                     :returns rtype))))))))))
  
  ;;; The union or intersection of a subclass of FUNCTION with a
  ;;; FUNCTION type is somewhat complicated.
                       (values nil t))
                      ((eq (fun-type-wild-args type1) t)
                       (values t t))
 -                    (t (and/type
 -                        (cond ((null (fun-type-rest type1))
 -                               (values (null (fun-type-rest type2)) t))
 -                              ((null (fun-type-rest type2))
 -                               (values nil t))
 -                              (t
 -                               (compare type= rest)))
 -                        (labels ((type-list-= (l1 l2)
 -                                   (cond ((null l1)
 -                                          (values (null l2) t))
 -                                         ((null l2)
 -                                          (values nil t))
 -                                         (t (multiple-value-bind (res winp)
 -                                                (type= (first l1) (first l2))
 -                                              (cond ((not winp)
 -                                                     (values nil nil))
 -                                                    ((not res)
 -                                                     (values nil t))
 -                                                    (t
 -                                                     (type-list-= (rest l1)
 -                                                                  (rest l2)))))))))
 -                          (and/type (and/type (compare type-list-= required)
 -                                              (compare type-list-= optional))
 -                              (if (or (fun-type-keyp type1) (fun-type-keyp type2))
 -                                  (values nil nil)
 -                                  (values t t))))))))))
 +                    (t (type=-args type1 type2))))))
  
  (!define-type-class constant :inherits values)
  
                (cond ((args-type-rest type))
                      (t default-type)))))
  
 -;;; If COUNT values are supplied, which types should they have?
 -(defun values-type-start (type count)
 +;;; types of values in (the <type> (values o_1 ... o_n))
 +(defun values-type-out (type count)
    (declare (type ctype type) (type unsigned-byte count))
    (if (eq type *wild-type*)
        (make-list count :initial-element *universal-type*)
                    do (res rest))))
          (res))))
  
 +;;; types of variable in (m-v-bind (v_1 ... v_n) (the <type> ...
 +(defun values-type-in (type count)
 +  (declare (type ctype type) (type unsigned-byte count))
 +  (if (eq type *wild-type*)
 +      (make-list count :initial-element *universal-type*)
 +      (collect ((res))
 +        (let ((null-type (specifier-type 'null)))
 +          (loop for type in (values-type-required type)
 +             while (plusp count)
 +             do (decf count)
 +             do (res type))
 +          (loop for type in (values-type-optional type)
 +             while (plusp count)
 +             do (decf count)
 +             do (res (type-union type null-type)))
 +          (when (plusp count)
 +            (loop with rest = (acond ((values-type-rest type)
 +                                      (type-union it null-type))
 +                                     (t null-type))
 +               repeat count
 +               do (res rest))))
 +        (res))))
 +
  ;;; Return a list of OPERATION applied to the types in TYPES1 and
  ;;; TYPES2, padding with REST2 as needed. TYPES1 must not be shorter
  ;;; than TYPES2. The second value is T if OPERATION always returned a
                                 (length (args-type-required type2))))
                   (required (subseq res 0 req))
                   (opt (subseq res req)))
 -            (values (make-values-type
 -                     :required required
 -                     :optional opt
 -                     :rest rest)
 +            (values required opt rest
                      (and rest-exact res-exact))))))))
  
 +(defun values-type-op (type1 type2 operation nreq)
 +  (multiple-value-bind (required optional rest exactp)
 +      (args-type-op type1 type2 operation nreq)
 +    (values (make-values-type :required required
 +                              :optional optional
 +                              :rest rest)
 +            exactp)))
 +
 +(defun type=-args (type1 type2)
 +  (macrolet ((compare (comparator field)
 +               (let ((reader (symbolicate '#:args-type- field)))
 +                 `(,comparator (,reader type1) (,reader type2)))))
 +    (and/type
 +     (cond ((null (args-type-rest type1))
 +            (values (null (args-type-rest type2)) t))
 +           ((null (args-type-rest type2))
 +            (values nil t))
 +           (t
 +            (compare type= rest)))
 +     (and/type (and/type (compare type=-list required)
 +                         (compare type=-list optional))
 +               (if (or (args-type-keyp type1) (args-type-keyp type2))
 +                   (values nil nil)
 +                   (values t t))))))
 +
  ;;; Do a union or intersection operation on types that might be values
  ;;; types. The result is optimized for utility rather than exactness,
  ;;; but it is guaranteed that it will be no smaller (more restrictive)
          ((eq type1 *empty-type*) type2)
          ((eq type2 *empty-type*) type1)
          (t
 -         (values (args-type-op type1 type2 #'type-union #'min)))))
 +         (values (values-type-op type1 type2 #'type-union #'min)))))
  
  (defun-cached (values-type-intersection :hash-function type-cache-hash
                                        :hash-bits 8
                             :rest (values-type-rest type1)
                             :allowp (values-type-allowp type1))))
          (t
 -         (args-type-op type1 (coerce-to-values type2)
 -                       #'type-intersection
 -                       #'max))))
 +         (values-type-op type1 (coerce-to-values type2)
 +                         #'type-intersection
 +                         #'max))))
  
  ;;; This is like TYPES-EQUAL-OR-INTERSECT, except that it sort of
  ;;; works on VALUES types. Note that due to the semantics of
    (values nil nil))
  
  (!define-type-method (hairy :complex-=) (type1 type2)
 -  (declare (ignore type1 type2))
 -  (values nil nil))
 +  (if (and (unknown-type-p type2)
 +           (let* ((specifier2 (unknown-type-specifier type2))
 +                  (name2 (if (consp specifier2)
 +                             (car specifier2)
 +                             specifier2)))
 +             (info :type :kind name2)))
 +      (let ((type2 (specifier-type (unknown-type-specifier type2))))
 +        (if (unknown-type-p type2)
 +            (values nil nil)
 +            (type= type1 type2)))
 +  (values nil nil)))
  
  (!define-type-method (hairy :simple-intersection2 :complex-intersection2) 
                     (type1 type2)
          ((consp low-bound)
           (let ((low-value (car low-bound)))
             (or (eql low-value high-bound)
 -               (and (eql low-value (load-time-value (make-unportable-float :single-float-negative-zero))) (eql high-bound 0f0))
 -               (and (eql low-value 0f0) (eql high-bound (load-time-value (make-unportable-float :single-float-negative-zero))))
 -               (and (eql low-value (load-time-value (make-unportable-float :double-float-negative-zero))) (eql high-bound 0d0))
 -               (and (eql low-value 0d0) (eql high-bound (load-time-value (make-unportable-float :double-float-negative-zero)))))))
 +               (and (eql low-value
 +                         (load-time-value (make-unportable-float
 +                                           :single-float-negative-zero)))
 +                    (eql high-bound 0f0))
 +               (and (eql low-value 0f0)
 +                    (eql high-bound
 +                         (load-time-value (make-unportable-float
 +                                           :single-float-negative-zero))))
 +               (and (eql low-value
 +                         (load-time-value (make-unportable-float
 +                                           :double-float-negative-zero)))
 +                    (eql high-bound 0d0))
 +               (and (eql low-value 0d0)
 +                    (eql high-bound
 +                         (load-time-value (make-unportable-float
 +                                           :double-float-negative-zero)))))))
          ((consp high-bound)
           (let ((high-value (car high-bound)))
             (or (eql high-value low-bound)
 -               (and (eql high-value (load-time-value (make-unportable-float :single-float-negative-zero))) (eql low-bound 0f0))
 -               (and (eql high-value 0f0) (eql low-bound (load-time-value (make-unportable-float :single-float-negative-zero))))
 -               (and (eql high-value (load-time-value (make-unportable-float :double-float-negative-zero))) (eql low-bound 0d0))
 -               (and (eql high-value 0d0) (eql low-bound (load-time-value (make-unportable-float :double-float-negative-zero)))))))
 +               (and (eql high-value
 +                         (load-time-value (make-unportable-float
 +                                           :single-float-negative-zero)))
 +                    (eql low-bound 0f0))
 +               (and (eql high-value 0f0)
 +                    (eql low-bound
 +                         (load-time-value (make-unportable-float
 +                                           :single-float-negative-zero))))
 +               (and (eql high-value
 +                         (load-time-value (make-unportable-float
 +                                           :double-float-negative-zero)))
 +                    (eql low-bound 0d0))
 +               (and (eql high-value 0d0)
 +                    (eql low-bound
 +                         (load-time-value (make-unportable-float
 +                                           :double-float-negative-zero)))))))
          ((and (eq (numeric-type-class low) 'integer)
                (eq (numeric-type-class high) 'integer))
           (eql (1+ low-bound) high-bound))
                   (case eltype
                     (bit 'bit-vector)
                     (base-char 'base-string)
-                    (character 'string)
                     (* 'vector)
                     (t `(vector ,eltype)))
                   (case eltype
                     (bit `(bit-vector ,(car dims)))
                     (base-char `(base-string ,(car dims)))
-                    (character `(string ,(car dims)))
                     (t `(vector ,eltype ,(car dims)))))
               (if (eq (car dims) '*)
                   (case eltype
                     (bit 'simple-bit-vector)
                     (base-char 'simple-base-string)
-                    (character 'simple-string)
                     ((t) 'simple-vector)
                     (t `(simple-array ,eltype (*))))
                   (case eltype
                     (bit `(simple-bit-vector ,(car dims)))
                     (base-char `(simple-base-string ,(car dims)))
-                    (character `(simple-string ,(car dims)))
                     ((t) `(simple-vector ,(car dims)))
                     (t `(simple-array ,eltype ,dims))))))
          (t
                          (specialized-element-type-maybe type2))
                   t)))))
  
+ ;;; FIXME: is this dead?
  (!define-superclasses array
-   ((string string)
+   ((base-string base-string)
     (vector vector)
     (array))
    !cold-init-forms)
                             (mapcar (lambda (x y) (if (eq x '*) y x))
                                     dims1 dims2)))
          :complexp (if (eq complexp1 :maybe) complexp2 complexp1)
 -        :element-type (if (eq eltype1 *wild-type*) eltype2 eltype1))))
 +        :element-type (cond
 +                        ((eq eltype1 *wild-type*) eltype2)
 +                        ((eq eltype2 *wild-type*) eltype1)
 +                        (t (type-intersection eltype1 eltype2))))))
        *empty-type*))
  
  ;;; Check a supplied dimension list to determine whether it is legal,
      ((type= type (specifier-type 'real)) 'real)
      ((type= type (specifier-type 'sequence)) 'sequence)
      ((type= type (specifier-type 'bignum)) 'bignum)
+     ((type= type (specifier-type 'simple-string)) 'simple-string)
+     ((type= type (specifier-type 'string)) 'string)
      (t `(or ,@(mapcar #'type-specifier (union-type-types type))))))
  
  ;;; Two union types are equal if they are each subtypes of each
diff --combined src/code/seq.lisp
              '((start end length sequence)
                (start1 end1 length1 sequence1)
                (start2 end2 length2 sequence2)))
 +    (key nil
 +         nil
 +         (and key (%coerce-callable-to-fun key))
 +         (or null function))
 +    (test #'eql
 +          nil
 +          (%coerce-callable-to-fun test)
 +          function)
 +    (test-not nil
 +              nil
 +              (and test-not (%coerce-callable-to-fun test-not))
 +              (or null function))
      ))
  
  (sb!xc:defmacro define-sequence-traverser (name args &body body)
    "Return a sequence of the given TYPE and LENGTH, with elements initialized
    to :INITIAL-ELEMENT."
    (declare (fixnum length))
-   (let ((type (specifier-type type)))
+   (let* ((adjusted-type
+         (typecase type
+           (atom (cond
+                   ((eq type 'string) '(vector character))
+                   ((eq type 'simple-string) '(simple-array character (*)))
+                   (t type)))
+           (cons (cond
+                   ((eq (car type) 'string) `(vector character ,@(cdr type)))
+                   ((eq (car type) 'simple-string)
+                    `(simple-array character ,@(when (cdr type)
+                                                     (list (cdr type)))))
+                   (t type)))
+           (t type)))
+        (type (specifier-type adjusted-type)))
      (cond ((csubtypep type (specifier-type 'list))
           (cond
             ((type= type (specifier-type 'list))
             ;; it was stranger to feed that type in to MAKE-SEQUENCE.
             (t (sequence-type-too-hairy (type-specifier type)))))
          ((csubtypep type (specifier-type 'vector))
-          (if (typep type 'array-type)
-              ;; KLUDGE: the above test essentially asks "Do we know
-              ;; what the upgraded-array-element-type is?" [consider
-              ;; (OR STRING BIT-VECTOR)]
-              (progn
-                (aver (= (length (array-type-dimensions type)) 1))
-                (let* ((etype (type-specifier
-                                 (array-type-specialized-element-type type)))
-                         (etype (if (eq etype '*) t etype))
+          (cond
+            (;; is it immediately obvious what the result type is?
+             (typep type 'array-type)
+             (progn
+               (aver (= (length (array-type-dimensions type)) 1))
+               (let* ((etype (type-specifier
+                              (array-type-specialized-element-type type)))
+                      (etype (if (eq etype '*) t etype))
                       (type-length (car (array-type-dimensions type))))
-                  (unless (or (eq type-length '*)
-                              (= type-length length))
-                    (sequence-type-length-mismatch-error type length))
-                  ;; FIXME: These calls to MAKE-ARRAY can't be
-                  ;; open-coded, as the :ELEMENT-TYPE argument isn't
-                  ;; constant.  Probably we ought to write a
-                  ;; DEFTRANSFORM for MAKE-SEQUENCE.  -- CSR,
-                  ;; 2002-07-22
-                  (if iep
-                      (make-array length :element-type etype
-                                  :initial-element initial-element)
-                      (make-array length :element-type etype))))
-              (sequence-type-too-hairy (type-specifier type))))
+                 (unless (or (eq type-length '*)
+                             (= type-length length))
+                   (sequence-type-length-mismatch-error type length))
+                 ;; FIXME: These calls to MAKE-ARRAY can't be
+                 ;; open-coded, as the :ELEMENT-TYPE argument isn't
+                 ;; constant.  Probably we ought to write a
+                 ;; DEFTRANSFORM for MAKE-SEQUENCE.  -- CSR,
+                 ;; 2002-07-22
+                 (if iep
+                     (make-array length :element-type etype
+                                 :initial-element initial-element)
+                     (make-array length :element-type etype)))))
+            (t (sequence-type-too-hairy (type-specifier type)))))
          (t (bad-sequence-type-error (type-specifier type))))))
  \f
  ;;;; SUBSEQ
  
  (sb!xc:defmacro vector-nreverse (sequence)
    `(let ((length (length (the vector ,sequence))))
 -     (declare (fixnum length))
 -     (do ((left-index 0 (1+ left-index))
 -        (right-index (1- length) (1- right-index))
 -        (half-length (truncate length 2)))
 -       ((= left-index half-length) ,sequence)
 -       (declare (fixnum left-index right-index half-length))
 -       (rotatef (aref ,sequence left-index)
 -              (aref ,sequence right-index)))))
 +     (when (>= length 2)
 +       (do ((left-index 0 (1+ left-index))
 +            (right-index (1- length) (1- right-index)))
 +           ((<= right-index left-index))
 +         (declare (type index left-index right-index))
 +         (rotatef (aref ,sequence left-index)
 +                  (aref ,sequence right-index))))
 +     ,sequence))
  
  (sb!xc:defmacro list-nreverse-macro (list)
    `(do ((1st (cdr ,list) (if (endp 1st) 1st (cdr 1st)))
  ) ; EVAL-WHEN
  
  (define-sequence-traverser delete
 -    (item sequence &key from-end (test #'eql) test-not start
 +    (item sequence &key from-end test test-not start
            end count key)
    #!+sb-doc
    "Return a sequence formed by destructively removing the specified ITEM from
  ) ; EVAL-WHEN
  
  (define-sequence-traverser remove
 -    (item sequence &key from-end (test #'eql) test-not start
 +    (item sequence &key from-end test test-not start
            end count key)
    #!+sb-doc
    "Return a copy of SEQUENCE with elements satisfying the test (default is
      (shrink-vector result jndex)))
  
  (define-sequence-traverser remove-duplicates
 -    (sequence &key (test #'eql) test-not (start 0) end from-end key)
 +    (sequence &key test test-not start end from-end key)
    #!+sb-doc
    "The elements of SEQUENCE are compared pairwise, and if any two match,
     the one occurring earlier is discarded, unless FROM-END is true, in
        (setq jndex (1+ jndex)))))
  
  (define-sequence-traverser delete-duplicates
 -    (sequence &key (test #'eql) test-not (start 0) end from-end key)
 +    (sequence &key test test-not start end from-end key)
    #!+sb-doc
    "The elements of SEQUENCE are examined, and if any two match, one is
     discarded. The resulting sequence, which may be formed by destroying the
  ) ; EVAL-WHEN
  
  (define-sequence-traverser substitute
 -    (new old sequence &key from-end (test #'eql) test-not
 +    (new old sequence &key from-end test test-not
           start count end key)
    #!+sb-doc
    "Return a sequence of the same kind as SEQUENCE with the same elements,
  ;;;; SUBSTITUTE-IF, SUBSTITUTE-IF-NOT
  
  (define-sequence-traverser substitute-if
 -    (new test sequence &key from-end start end count key)
 +    (new pred sequence &key from-end start end count key)
    #!+sb-doc
    "Return a sequence of the same kind as SEQUENCE with the same elements
 -  except that all elements satisfying the TEST are replaced with NEW. See
 +  except that all elements satisfying the PRED are replaced with NEW. See
    manual for details."
    (declare (fixnum start))
    (let ((end (or end length))
 +        (test pred)
        test-not
        old)
      (declare (type index length end))
      (subst-dispatch 'if)))
  
  (define-sequence-traverser substitute-if-not
 -    (new test sequence &key from-end start end count key)
 +    (new pred sequence &key from-end start end count key)
    #!+sb-doc
    "Return a sequence of the same kind as SEQUENCE with the same elements
 -  except that all elements not satisfying the TEST are replaced with NEW.
 +  except that all elements not satisfying the PRED are replaced with NEW.
    See manual for details."
    (declare (fixnum start))
    (let ((end (or end length))
 +        (test pred)
        test-not
        old)
      (declare (type index length end))
  ;;;; NSUBSTITUTE
  
  (define-sequence-traverser nsubstitute
 -    (new old sequence &key from-end (test #'eql) test-not
 +    (new old sequence &key from-end test test-not
           end count key start)
    #!+sb-doc
    "Return a sequence of the same kind as SEQUENCE with the same elements
  ;;;; NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT
  
  (define-sequence-traverser nsubstitute-if
 -    (new test sequence &key from-end start end count key)
 +    (new pred sequence &key from-end start end count key)
    #!+sb-doc
    "Return a sequence of the same kind as SEQUENCE with the same elements
 -   except that all elements satisfying the TEST are replaced with NEW. 
 +   except that all elements satisfying the PRED are replaced with NEW. 
     SEQUENCE may be destructively modified. See manual for details."
    (declare (fixnum start))
    (let ((end (or end length)))
        (if from-end
            (let ((length (length sequence)))
              (nreverse (nlist-substitute-if*
 -                       new test (nreverse (the list sequence))
 +                       new pred (nreverse (the list sequence))
                         (- length end) (- length start) count key)))
 -          (nlist-substitute-if* new test sequence
 +          (nlist-substitute-if* new pred sequence
                                  start end count key))
        (if from-end
 -          (nvector-substitute-if* new test sequence -1
 +          (nvector-substitute-if* new pred sequence -1
                                    (1- end) (1- start) count key)
 -          (nvector-substitute-if* new test sequence 1
 +          (nvector-substitute-if* new pred sequence 1
                                    start end count key)))))
  
  (defun nlist-substitute-if* (new test sequence start end count key)
        (setq count (1- count)))))
  
  (define-sequence-traverser nsubstitute-if-not
 -    (new test sequence &key from-end start end count key)
 +    (new pred sequence &key from-end start end count key)
    #!+sb-doc
    "Return a sequence of the same kind as SEQUENCE with the same elements
     except that all elements not satisfying the TEST are replaced with NEW.
        (if from-end
            (let ((length (length sequence)))
              (nreverse (nlist-substitute-if-not*
 -                       new test (nreverse (the list sequence))
 +                       new pred (nreverse (the list sequence))
                         (- length end) (- length start) count key)))
 -          (nlist-substitute-if-not* new test sequence
 +          (nlist-substitute-if-not* new pred sequence
                                      start end count key))
        (if from-end
 -          (nvector-substitute-if-not* new test sequence -1
 +          (nvector-substitute-if-not* new pred sequence -1
                                        (1- end) (1- start) count key)
 -          (nvector-substitute-if-not* new test sequence 1
 +          (nvector-substitute-if-not* new pred sequence 1
                                        start end count key)))))
  
  (defun nlist-substitute-if-not* (new test sequence start end count key)
                                                 (frob sequence nil))))
                         (typecase sequence
                           (simple-vector (frob2))
-                          (simple-string (frob2))
+                          (simple-base-string (frob2))
                           (t (vector*-frob sequence))))
                     (declare (type (or index null) p))
                     (values f (and p (the index (+ p offset))))))))))
  
  ) ; EVAL-WHEN
  
 -(define-sequence-traverser count-if (test sequence &key from-end start end key)
 +(define-sequence-traverser count-if (pred sequence &key from-end start end key)
    #!+sb-doc
 -  "Return the number of elements in SEQUENCE satisfying TEST(el)."
 +  "Return the number of elements in SEQUENCE satisfying PRED(el)."
    (declare (fixnum start))
    (let ((end (or end length)))
      (declare (type index end))
      (seq-dispatch sequence
                  (if from-end
 -                    (list-count-if nil t test sequence)
 -                    (list-count-if nil nil test sequence))
 +                    (list-count-if nil t pred sequence)
 +                    (list-count-if nil nil pred sequence))
                  (if from-end
 -                    (vector-count-if nil t test sequence)
 -                    (vector-count-if nil nil test sequence)))))
 +                    (vector-count-if nil t pred sequence)
 +                    (vector-count-if nil nil pred sequence)))))
  
  (define-sequence-traverser count-if-not
 -    (test sequence &key from-end start end key)
 +    (pred sequence &key from-end start end key)
    #!+sb-doc
    "Return the number of elements in SEQUENCE not satisfying TEST(el)."
    (declare (fixnum start))
      (declare (type index end))
      (seq-dispatch sequence
                  (if from-end
 -                    (list-count-if t t test sequence)
 -                    (list-count-if t nil test sequence))
 +                    (list-count-if t t pred sequence)
 +                    (list-count-if t nil pred sequence))
                  (if from-end
 -                    (vector-count-if t t test sequence)
 -                    (vector-count-if t nil test sequence)))))
 +                    (vector-count-if t t pred sequence)
 +                    (vector-count-if t nil pred sequence)))))
  
  (define-sequence-traverser count
      (item sequence &key from-end start end
  
  (define-sequence-traverser mismatch
      (sequence1 sequence2
 -             &key from-end (test #'eql) test-not
 +             &key from-end test test-not
               start1 end1 start2 end2 key)
    #!+sb-doc
    "The specified subsequences of SEQUENCE1 and SEQUENCE2 are compared
    `(do ((main ,main (cdr main))
        (jndex start1 (1+ jndex))
        (sub (nthcdr start1 ,sub) (cdr sub)))
 -       ((or (null main) (null sub) (= (the fixnum end1) jndex))
 +       ((or (endp main) (endp sub) (<= end1 jndex))
        t)
 -     (declare (fixnum jndex))
 +     (declare (type (integer 0) jndex))
       (compare-elements (car sub) (car main))))
  
  (sb!xc:defmacro search-compare-list-vector (main sub)
    `(do ((main ,main (cdr main))
        (index start1 (1+ index)))
 -       ((or (null main) (= index (the fixnum end1))) t)
 -     (declare (fixnum index))
 +       ((or (endp main) (= index end1)) t)
       (compare-elements (aref ,sub index) (car main))))
  
  (sb!xc:defmacro search-compare-vector-list (main sub index)
    `(do ((sub (nthcdr start1 ,sub) (cdr sub))
        (jndex start1 (1+ jndex))
        (index ,index (1+ index)))
 -       ((or (= (the fixnum end1) jndex) (null sub)) t)
 -     (declare (fixnum jndex index))
 +       ((or (<= end1 jndex) (endp sub)) t)
 +     (declare (type (integer 0) jndex))
       (compare-elements (car sub) (aref ,main index))))
  
  (sb!xc:defmacro search-compare-vector-vector (main sub index)
    `(do ((index ,index (1+ index))
        (sub-index start1 (1+ sub-index)))
 -       ((= sub-index (the fixnum end1)) t)
 -     (declare (fixnum sub-index index))
 +       ((= sub-index end1) t)
       (compare-elements (aref ,sub sub-index) (aref ,main index))))
  
  (sb!xc:defmacro search-compare (main-type main sub index)
  (sb!xc:defmacro list-search (main sub)
    `(do ((main (nthcdr start2 ,main) (cdr main))
        (index2 start2 (1+ index2))
 -      (terminus (- (the fixnum end2)
 -                   (the fixnum (- (the fixnum end1)
 -                                  (the fixnum start1)))))
 +      (terminus (- end2 (the (integer 0) (- end1 start1))))
        (last-match ()))
         ((> index2 terminus) last-match)
 -     (declare (fixnum index2 terminus))
 +     (declare (type (integer 0) index2))
       (if (search-compare list main ,sub index2)
         (if from-end
             (setq last-match index2)
  
  (sb!xc:defmacro vector-search (main sub)
    `(do ((index2 start2 (1+ index2))
 -      (terminus (- (the fixnum end2)
 -                   (the fixnum (- (the fixnum end1)
 -                                  (the fixnum start1)))))
 +      (terminus (- end2 (the (integer 0) (- end1 start1))))
        (last-match ()))
         ((> index2 terminus) last-match)
 -     (declare (fixnum index2 terminus))
 +     (declare (type (integer 0) index2))
       (if (search-compare vector ,main ,sub index2)
         (if from-end
             (setq last-match index2)
  
  (define-sequence-traverser search
      (sequence1 sequence2
 -             &key from-end (test #'eql) test-not
 +             &key from-end test test-not
               start1 end1 start2 end2 key)
    (declare (fixnum start1 start2))
    (let ((end1 (or end1 length1))
diff --combined src/code/stream.lisp
           ;; private predicate function..) is ugly and confusing, but
           ;; I can't see any other way. -- WHN 2001-04-14
           :expected-type '(satisfies stream-associated-with-file-p)
 -         :format-string
 +         :format-control
           "~@<The stream ~2I~_~S ~I~_isn't associated with a file.~:>"
           :format-arguments (list stream))))
  
               (:include ansi-stream)
               (:constructor nil)
               (:copier nil))
-   (string nil :type string))
+   ;; FIXME: This type declaration is true, and will probably continue
+   ;; to be true.  However, note well the comments in DEFTRANSFORM
+   ;; REPLACE, implying that performance of REPLACE is somewhat
+   ;; critical to performance of string streams.  If (VECTOR CHARACTER)
+   ;; ever becomes different from (VECTOR BASE-CHAR), the transform
+   ;; probably needs to be extended.
+   (string (missing-arg) :type (vector character)))
  \f
  ;;;; STRING-INPUT-STREAM stuff
  
                       (bin #'string-binch)
                       (n-bin #'string-stream-read-n-bytes)
                       (misc #'string-in-misc)
-                        (string nil :type simple-string))
+                        (string (missing-arg)
+                              :type (simple-array character (*))))
             (:constructor internal-make-string-input-stream
                           (string current end))
             (:copier nil))
  (defun string-inch (stream eof-error-p eof-value)
    (let ((string (string-input-stream-string stream))
        (index (string-input-stream-current stream)))
-     (declare (simple-string string) (fixnum index))
+     (declare (type (simple-array character (*)) string)
+            (type fixnum index))
      (cond ((= index (the index (string-input-stream-end stream)))
           (eof-or-lose stream eof-error-p eof-value))
          (t
  (defun string-binch (stream eof-error-p eof-value)
    (let ((string (string-input-stream-string stream))
        (index (string-input-stream-current stream)))
-     (declare (simple-string string)
+     (declare (type (simple-array character (*)) string)
             (type index index))
      (cond ((= index (the index (string-input-stream-end stream)))
           (eof-or-lose stream eof-error-p eof-value))
         (index (string-input-stream-current stream))
         (available (- (string-input-stream-end stream) index))
         (copy (min available requested)))
-     (declare (simple-string string)
+     (declare (type (simple-array character (*)) string)
             (type index index available copy))
      (when (plusp copy)
        (setf (string-input-stream-current stream)
                      (sout #'string-sout)
                      (misc #'string-out-misc)
                        ;; The string we throw stuff in.
-                       (string (make-string 40) :type simple-string))
+                       (string (make-string 40)
+                             :type (simple-array character (*))))
            (:constructor make-string-output-stream ())
            (:copier nil))
    ;; Index of the next location to use.
  (defun string-ouch (stream character)
    (let ((current (string-output-stream-index stream))
        (workspace (string-output-stream-string stream)))
-     (declare (simple-string workspace) (fixnum current))
+     (declare (type (simple-array character (*)) workspace)
+            (type fixnum current))
      (if (= current (the fixnum (length workspace)))
        (let ((new-workspace (make-string (* current 2))))
          (replace new-workspace workspace)
      (setf (string-output-stream-index stream) (1+ current))))
  
  (defun string-sout (stream string start end)
-   (declare (simple-string string) (fixnum start end))
-   (let* ((current (string-output-stream-index stream))
+   (declare (type simple-string string)
+          (type fixnum start end))
+   (let* ((string (if (typep string '(simple-array character (*)))
+                    string
+                    (coerce string '(simple-array character (*)))))
+        (current (string-output-stream-index stream))
         (length (- end start))
         (dst-end (+ length current))
         (workspace (string-output-stream-string stream)))
-     (declare (simple-string workspace)
-            (fixnum current length dst-end))
+     (declare (type (simple-array character (*)) workspace string)
+            (type fixnum current length dst-end))
      (if (> dst-end (the fixnum (length workspace)))
        (let ((new-workspace (make-string (+ (* current 2) length))))
          (replace new-workspace workspace :end2 current)
          (count 0 (1+ count))
          (string (string-output-stream-string stream)))
         ((< index 0) count)
-        (declare (simple-string string)
-               (fixnum index count))
+        (declare (type (simple-array character (*)) string)
+               (type fixnum index count))
         (if (char= (schar string index) #\newline)
           (return count))))
      (:element-type 'base-char)))
  ;;; WITH-OUTPUT-TO-STRING.
  
  (deftype string-with-fill-pointer ()
-   '(and string
+   '(and (vector character)
        (satisfies array-has-fill-pointer-p)))
  
  (defstruct (fill-pointer-output-stream
         (current+1 (1+ current)))
      (declare (fixnum current))
      (with-array-data ((workspace buffer) (start) (end))
-       (declare (simple-string workspace))
+       (declare (type (simple-array character (*)) workspace))
        (let ((offset-current (+ start current)))
        (declare (fixnum offset-current))
        (if (= offset-current end)
  
  (defun fill-pointer-sout (stream string start end)
    (declare (simple-string string) (fixnum start end))
-   (let* ((buffer (fill-pointer-output-stream-string stream))
+   (let* ((string (if (typep string '(simple-array character (*)))
+                    string
+                    (coerce string '(simple-array character (*)))))
+        (buffer (fill-pointer-output-stream-string stream))
         (current (fill-pointer buffer))
         (string-len (- end start))
         (dst-end (+ string-len current)))
      (declare (fixnum current dst-end string-len))
      (with-array-data ((workspace buffer) (dst-start) (dst-length))
-       (declare (simple-string workspace))
+       (declare (type (simple-array character (*)) workspace))
        (let ((offset-dst-end (+ dst-start dst-end))
            (offset-current (+ dst-start current)))
        (declare (fixnum offset-dst-end offset-current))
        (if (> offset-dst-end dst-length)
            (let* ((new-length (+ (the fixnum (* current 2)) string-len))
                   (new-workspace (make-string new-length)))
-             (declare (simple-string new-workspace))
+             (declare (type (simple-array character (*)) new-workspace))
              (%byte-blt workspace dst-start
                         new-workspace 0 current)
              (setf workspace new-workspace)
diff --combined src/code/string.lisp
  ;;; strings in the unasterisked versions and using this in the
  ;;; transforms conditional on SAFETY>SPEED,SPACE).
  (defun %check-vector-sequence-bounds (vector start end)
 -  (declare (type vector vector)
 -         (type index start)
 -         (type (or index null) end))
 -  (let ((length (length vector)))
 -    (if (<= 0 start (or end length) length)
 -      (or end length)
 -      (signal-bounding-indices-bad-error string start end))))
 +  (%check-vector-sequence-bounds vector start end))
  
  (eval-when (:compile-toplevel)
  ;;; WITH-ONE-STRING is used to set up some string hacking things. The
    (using char-equal) of the two strings. Otherwise, returns ()."
    (string-not-greaterp* string1 string2 start1 end1 start2 end2))
  
- (defun make-string (count &key element-type ((:initial-element fill-char)))
+ (defun make-string (count &key
+                   (element-type 'character)
+                   ((:initial-element fill-char)))
    #!+sb-doc
    "Given a character count and an optional fill character, makes and returns
-    a new string Count long filled with the fill character."
-   (declare (fixnum count)
-          (ignore element-type))
+    a new string COUNT long filled with the fill character."
+   (declare (fixnum count))
    (if fill-char
-       (do ((i 0 (1+ i))
-          (string (make-string count)))
-         ((= i count) string)
-       (declare (fixnum i))
-       (setf (schar string i) fill-char))
-       (make-string count)))
+       (make-string count :element-type element-type :initial-element fill-char)
+       (make-string count :element-type element-type)))
  
  (flet ((%upcase (string start end)
         (declare (string string) (index start) (type sequence-end end))
        ;; 2002-08-21
        *wild-type*)))
  
 +(defun extract-declared-element-type (array)
 +  (let ((type (continuation-type array)))
 +    (if (array-type-p type)
 +      (array-type-element-type type)
 +      *wild-type*)))
 +
  ;;; The ``new-value'' for array setters must fit in the array, and the
  ;;; return type is going to be the same as the new-value for SETF
  ;;; functions.
           `(,(if simple 'simple-array 'array)
              ,(cond ((not element-type) t)
                     ((constant-continuation-p element-type)
 -                    (continuation-value element-type))
 +                  (let ((ctype (careful-specifier-type
 +                                (continuation-value element-type))))
 +                    (cond
 +                      ((or (null ctype) (unknown-type-p ctype)) '*)
 +                      (t (sb!xc:upgraded-array-element-type
 +                          (continuation-value element-type))))))
                     (t
                      '*))
              ,(cond ((constant-continuation-p dims)
  
  ;;; Just convert it into a MAKE-ARRAY.
  (deftransform make-string ((length &key
-                                  (element-type 'base-char)
+                                  (element-type 'character)
                                   (initial-element
                                    #.*default-init-char-form*)))
-   '(make-array (the index length)
-                :element-type element-type
-                :initial-element initial-element))
- (defstruct (specialized-array-element-type-properties
-           (:conc-name saetp-)
-           (:constructor !make-saetp (ctype
-                                      initial-element-default
-                                      n-bits
-                                      typecode
-                                      &key
-                                      (n-pad-elements 0)))
-           (:copier nil))
-   ;; the element type, e.g. #<BUILT-IN-CLASS BASE-CHAR (sealed)> or
-   ;; #<SB-KERNEL:NUMERIC-TYPE (UNSIGNED-BYTE 4)>
-   (ctype (missing-arg) :type ctype :read-only t)
-   ;; what we get when the low-level vector-creation logic zeroes all
-   ;; the bits (which also serves as the default value of MAKE-ARRAY's
-   ;; :INITIAL-ELEMENT keyword)
-   (initial-element-default (missing-arg) :read-only t)
-   ;; how many bits per element
-   (n-bits (missing-arg) :type index :read-only t)
-   ;; the low-level type code
-   (typecode (missing-arg) :type index :read-only t)
-   ;; the number of extra elements we use at the end of the array for
-   ;; low level hackery (e.g., one element for arrays of BASE-CHAR,
-   ;; which is used for a fixed #\NULL so that when we call out to C
-   ;; we don't need to cons a new copy)
-   (n-pad-elements (missing-arg) :type index :read-only t))
- (defparameter *specialized-array-element-type-properties*
-   (map 'simple-vector
-        (lambda (args)
-        (destructuring-bind (type-spec &rest rest) args
-          (let ((ctype (specifier-type type-spec)))
-            (apply #'!make-saetp ctype rest))))
-        `(;; Erm.  Yeah.  There aren't a lot of things that make sense
-        ;; for an initial element for (ARRAY NIL). -- CSR, 2002-03-07
-        (nil '#:mu 0 ,sb!vm:simple-array-nil-widetag)
-        (base-char ,(code-char 0) 8 ,sb!vm:simple-string-widetag
-                   ;; (SIMPLE-STRINGs are stored with an extra trailing
-                   ;; #\NULL for convenience in calling out to C.)
-                   :n-pad-elements 1)
-        (single-float 0.0f0 32 ,sb!vm:simple-array-single-float-widetag)
-        (double-float 0.0d0 64 ,sb!vm:simple-array-double-float-widetag)
-        #!+long-float (long-float 0.0L0 #!+x86 96 #!+sparc 128
-                                  ,sb!vm:simple-array-long-float-widetag)
-        (bit 0 1 ,sb!vm:simple-bit-vector-widetag)
-        ;; KLUDGE: The fact that these UNSIGNED-BYTE entries come
-        ;; before their SIGNED-BYTE partners is significant in the
-        ;; implementation of the compiler; some of the cross-compiler
-        ;; code (see e.g. COERCE-TO-SMALLEST-ELTYPE in
-        ;; src/compiler/debug-dump.lisp) attempts to create an array
-        ;; specialized on (UNSIGNED-BYTE FOO), where FOO could be 7;
-        ;; (UNSIGNED-BYTE 7) is SUBTYPEP (SIGNED-BYTE 8), so if we're
-        ;; not careful we could get the wrong specialized array when
-        ;; we try to FIND-IF, below. -- CSR, 2002-07-08
-        ((unsigned-byte 2) 0 2 ,sb!vm:simple-array-unsigned-byte-2-widetag)
-        ((unsigned-byte 4) 0 4 ,sb!vm:simple-array-unsigned-byte-4-widetag)
-        ((unsigned-byte 8) 0 8 ,sb!vm:simple-array-unsigned-byte-8-widetag)
-        ((unsigned-byte 16) 0 16 ,sb!vm:simple-array-unsigned-byte-16-widetag)
-        ((unsigned-byte 32) 0 32 ,sb!vm:simple-array-unsigned-byte-32-widetag)
-        ((signed-byte 8) 0 8 ,sb!vm:simple-array-signed-byte-8-widetag)
-        ((signed-byte 16) 0 16 ,sb!vm:simple-array-signed-byte-16-widetag)
-        ((signed-byte 30) 0 32 ,sb!vm:simple-array-signed-byte-30-widetag)
-        ((signed-byte 32) 0 32 ,sb!vm:simple-array-signed-byte-32-widetag)
-        ((complex single-float) #C(0.0f0 0.0f0) 64
-         ,sb!vm:simple-array-complex-single-float-widetag)
-        ((complex double-float) #C(0.0d0 0.0d0) 128
-         ,sb!vm:simple-array-complex-double-float-widetag)
-        #!+long-float ((complex long-float) #C(0.0L0 0.0L0)
-                       #!+x86 192 #!+sparc 256
-                       ,sb!vm:simple-array-complex-long-float-widetag)
-        (t 0 32 ,sb!vm:simple-vector-widetag))))
+   `(the simple-string (make-array (the index length)
+                      :element-type element-type
+                      ,@(when initial-element
+                          '(:initial-element initial-element)))))
  
  (deftransform make-array ((dims &key initial-element element-type
                                     adjustable fill-pointer)
                        (continuation-value element-type))))
         (eltype-type (ir1-transform-specifier-type eltype))
         (saetp (find-if (lambda (saetp)
-                          (csubtypep eltype-type (saetp-ctype saetp)))
-                        *specialized-array-element-type-properties*))
+                          (csubtypep eltype-type (sb!vm:saetp-ctype saetp)))
+                        sb!vm:*specialized-array-element-type-properties*))
         (creation-form `(make-array dims
-                         :element-type ',(type-specifier (saetp-ctype saetp))
+                         :element-type ',(type-specifier (sb!vm:saetp-ctype saetp))
                          ,@(when fill-pointer
                                  '(:fill-pointer fill-pointer))
                          ,@(when adjustable
  
      (cond ((and (constant-continuation-p initial-element)
                (eql (continuation-value initial-element)
-                    (saetp-initial-element-default saetp)))
+                    (sb!vm:saetp-initial-element-default saetp)))
           creation-form)
          (t
           ;; error checking for target, disabled on the host because
           (when (constant-continuation-p initial-element)
             (let ((value (continuation-value initial-element)))
               (cond
-                ((not (ctypep value (saetp-ctype saetp)))
+                ((not (ctypep value (sb!vm:saetp-ctype saetp)))
                  ;; this case will cause an error at runtime, so we'd
                  ;; better WARN about it now.
                  (compiler-warn "~@<~S is not a ~S (which is the ~
                                   UPGRADED-ARRAY-ELEMENT-TYPE of ~S).~@:>"
                                 value
-                                (type-specifier (saetp-ctype saetp))
+                                (type-specifier (sb!vm:saetp-ctype saetp))
                                 eltype))
                 ((not (ctypep value eltype-type))
                  ;; this case will not cause an error at runtime, but
         (len (if (constant-continuation-p length)
                  (continuation-value length)
                  '*))
 -       (result-type-spec `(simple-array ,eltype (,len)))
         (eltype-type (ir1-transform-specifier-type eltype))
 +       (result-type-spec
 +        `(simple-array
 +          ,(if (unknown-type-p eltype-type)
 +               (give-up-ir1-transform
 +                "ELEMENT-TYPE is an unknown type: ~S" eltype)
 +               (sb!xc:upgraded-array-element-type eltype))
 +          (,len)))
         (saetp (find-if (lambda (saetp)
-                          (csubtypep eltype-type (saetp-ctype saetp)))
-                        *specialized-array-element-type-properties*)))
+                          (csubtypep eltype-type (sb!vm:saetp-ctype saetp)))
+                        sb!vm:*specialized-array-element-type-properties*)))
      (unless saetp
        (give-up-ir1-transform
         "cannot open-code creation of ~S" result-type-spec))
      #-sb-xc-host
-     (unless (csubtypep (ctype-of (saetp-initial-element-default saetp))
+     (unless (csubtypep (ctype-of (sb!vm:saetp-initial-element-default saetp))
                       eltype-type)
        ;; This situation arises e.g. in (MAKE-ARRAY 4 :ELEMENT-TYPE
        ;; '(INTEGER 1 5)) ANSI's definition of MAKE-ARRAY says "If
        ;; he writes code:-), we'll signal a STYLE-WARNING in case he
        ;; didn't realize this.
        (compiler-style-warn "The default initial element ~S is not a ~S."
-                          (saetp-initial-element-default saetp)
+                          (sb!vm:saetp-initial-element-default saetp)
                           eltype))
-     (let* ((n-bits-per-element (saetp-n-bits saetp))
-          (typecode (saetp-typecode saetp))
-          (n-pad-elements (saetp-n-pad-elements saetp))
+     (let* ((n-bits-per-element (sb!vm:saetp-n-bits saetp))
+          (typecode (sb!vm:saetp-typecode saetp))
+          (n-pad-elements (sb!vm:saetp-n-pad-elements saetp))
           (padded-length-form (if (zerop n-pad-elements)
                                   'length
                                   `(+ length ,n-pad-elements)))
               (rank (length dims))
               (spec `(simple-array
                       ,(cond ((null element-type) t)
 -                            ((constant-continuation-p element-type)
 -                             (continuation-value element-type))
 +                            ((and (constant-continuation-p element-type)
 +                                  (ir1-transform-specifier-type
 +                                   (continuation-value element-type)))
 +                             (sb!xc:upgraded-array-element-type
 +                              (continuation-value element-type)))
                              (t '*))
                           ,(make-list rank :initial-element '*))))
          `(let ((header (make-array-header sb!vm:simple-array-widetag ,rank)))
           (give-up-ir1-transform))
          (t
           (let ((dim (continuation-value dimension)))
 -           `(the (integer 0 ,dim) index)))))
 +           `(the (integer 0 (,dim)) index)))))
  \f
  ;;;; WITH-ARRAY-DATA
  
  ;;; value?
  \f
  ;;; Pick off some constant cases.
 -(deftransform array-header-p ((array) (array))
 +(defoptimizer (array-header-p derive-type) ((array))
    (let ((type (continuation-type array)))
 -    (unless (array-type-p type)
 -      (give-up-ir1-transform))
 -    (let ((dims (array-type-dimensions type)))
 -      (cond ((csubtypep type (specifier-type '(simple-array * (*))))
 -           ;; no array header
 -           nil)
 -          ((and (listp dims) (/= (length dims) 1))
 -           ;; multi-dimensional array, will have a header
 -           t)
 -          (t
 -           (give-up-ir1-transform))))))
 +    (cond ((not (array-type-p type))
 +           nil)
 +          (t
 +           (let ((dims (array-type-dimensions type)))
 +             (cond ((csubtypep type (specifier-type '(simple-array * (*))))
 +                    ;; no array header
 +                    (specifier-type 'null))
 +                   ((and (listp dims) (/= (length dims) 1))
 +                    ;; multi-dimensional array, will have a header
 +                    (specifier-type '(eql t)))
 +                   (t
 +                    nil)))))))
diff --combined src/compiler/fndb.lisp
@@@ -44,7 -44,7 +44,7 @@@
  (defknown type-of (t) t (foldable flushable))
  
  ;;; These can be affected by type definitions, so they're not FOLDABLE.
 -(defknown (upgraded-complex-part-type upgraded-array-element-type)
 +(defknown (upgraded-complex-part-type sb!xc:upgraded-array-element-type)
          (type-specifier &optional lexenv-designator) type-specifier
    (unsafely-flushable))
  \f
                                        (:initial-element t))
    consed-sequence
    (movable unsafe)
-   :derive-type (result-type-specifier-nth-arg 1))
+   :derive-type (creation-result-type-specifier-nth-arg 1))
  
  (defknown concatenate (type-specifier &rest sequence) consed-sequence
    ()
-   :derive-type (result-type-specifier-nth-arg 1))
+   :derive-type (creation-result-type-specifier-nth-arg 1))
  
  (defknown (map %map) (type-specifier callable sequence &rest sequence)
    consed-sequence
                                &key (:key callable))
    sequence
    (call)
-   :derive-type (result-type-specifier-nth-arg 1))
+   :derive-type (creation-result-type-specifier-nth-arg 1))
  
  ;;; not FLUSHABLE, despite what CMU CL's DEFKNOWN said..
  (defknown read-sequence (sequence stream
    (foldable flushable call))
  (defknown endp (list) boolean (foldable flushable movable))
  (defknown list-length (list) (or index null) (foldable unsafely-flushable))
 -(defknown nth (index list) t (foldable flushable))
 -(defknown nthcdr (index list) t (foldable unsafely-flushable))
 -(defknown last (list &optional index) t (foldable flushable))
 +(defknown nth (unsigned-byte list) t (foldable flushable))
 +(defknown nthcdr (unsigned-byte list) t (foldable unsafely-flushable))
 +(defknown last (list &optional unsigned-byte) t (foldable flushable))
  (defknown list (&rest t) list (movable flushable unsafe))
  (defknown list* (t &rest t) t (movable flushable unsafe))
  (defknown make-list (index &key (:initial-element t)) list
  (defknown nconc (&rest t) t ())
  
  (defknown nreconc (list t) t ())
 -(defknown butlast (list &optional index) list (flushable))
 -(defknown nbutlast (list &optional index) list ())
 +(defknown butlast (list &optional unsigned-byte) list (flushable))
 +(defknown nbutlast (list &optional unsigned-byte) list ())
  (defknown ldiff (list t) list (flushable))
  (defknown (rplaca rplacd) (cons t) list (unsafe))
  
  (defknown directory (pathname-designator &key)
    list ())
  \f
 -;;;; from the "Errors" chapter:
 -
 -(defknown error (t &rest t) nil) ; never returns
 -(defknown cerror (string t &rest t) null)
 +;;;; from the "Conditions" chapter:
 +
 +(defknown cell-error-name (cell-error) t)
 +(defknown error (t &rest t) nil)
 +(defknown cerror (format-control t &rest t) null)
 +(defknown invalid-method-error (t format-control &rest t) *) ; FIXME: first arg is METHOD
 +(defknown method-combination-error (format-control &rest t) *)
 +(defknown signal (t &rest t) null)
 +(defknown simple-condition-format-control (condition)
 +  format-control)
 +(defknown simple-condition-format-arguments (condition)
 +  list)
  (defknown warn (t &rest t) null)
 -(defknown break (&optional t &rest t) null)
 +(defknown invoke-debugger (condition) nil)
 +(defknown break (&optional format-control &rest t) null)
 +(defknown make-condition (type-specifier &rest t) condition)
 +(defknown compute-restarts (&optional (or condition null)) list)
 +(defknown find-restart (restart-designator &optional (or condition null))
 +  (or restart null))
 +(defknown invoke-restart (restart-designator &rest t) *)
 +(defknown invoke-restart-interactively (restart-designator) *)
 +(defknown restart-name (restart) symbol)
 +(defknown (abort muffle-warning) (&optional (or condition null)) nil)
 +(defknown continue (&optional (or condition null)) null)
 +(defknown (store-value use-value) (t &optional (or condition null))
 +  null)
  
  ;;; and analogous SBCL extension:
  (defknown bug (t &rest t) nil) ; never returns
  (defknown (setf fdocumentation) ((or string null) t symbol)
    (or string null)
    ())
 -(defknown %setnth (index list t) t (unsafe))
 +(defknown %setnth (unsigned-byte list t) t (unsafe))
  (defknown %set-fill-pointer (vector index) index (unsafe))
  \f
  ;;;; miscellaneous internal utilities
  \f
  ;;;; simplifying HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET
  
+ (deftransform hairy-data-vector-ref ((string index) (simple-string t))
+   (let ((ctype (continuation-type string)))
+     (if (array-type-p ctype)
+       ;; the other transform will kick in, so that's OK
+       (give-up-ir1-transform)
+       `(typecase string
+         ((simple-array character (*)) (data-vector-ref string index))
+         ((simple-array nil (*)) (data-vector-ref string index))))))
  (deftransform hairy-data-vector-ref ((array index) (array t) * :important t)
    "avoid runtime dispatch on array element type"
 -  (let ((element-ctype (extract-upgraded-element-type array)))
 +  (let ((element-ctype (extract-upgraded-element-type array))
 +      (declared-element-ctype (extract-declared-element-type array)))
      (declare (type ctype element-ctype))
      (when (eq *wild-type* element-ctype)
        (give-up-ir1-transform
        `(multiple-value-bind (array index)
           (%data-vector-and-index array index)
         (declare (type (simple-array ,element-type-specifier 1) array))
 -       (data-vector-ref array index)))))
 +       ,(let ((bare-form '(data-vector-ref array index)))
 +          (if (type= element-ctype declared-element-ctype)
 +              bare-form
 +              `(the ,(type-specifier declared-element-ctype)
 +                    ,bare-form)))))))
  
  (deftransform data-vector-ref ((array index)
                                 (simple-array t))
                                       (%array-data-vector array))
                            index)))))
  
++(deftransform hairy-data-vector-set ((string index new-value)
++                                   (simple-string t t))
++  (let ((ctype (continuation-type string)))
++    (if (array-type-p ctype)
++      ;; the other transform will kick in, so that's OK
++      (give-up-ir1-transform)
++      `(typecase string
++        ((simple-array character (*))
++         (data-vector-set string index new-value))
++        ((simple-array nil (*))
++         (data-vector-set string index new-value))))))
++
  (deftransform hairy-data-vector-set ((array index new-value)
                                     (array t t)
                                     *
                                     :important t)
    "avoid runtime dispatch on array element type"
 -  (let ((element-ctype (extract-upgraded-element-type array)))
 +  (let ((element-ctype (extract-upgraded-element-type array))
 +      (declared-element-ctype (extract-declared-element-type array)))
      (declare (type ctype element-ctype))
      (when (eq *wild-type* element-ctype)
        (give-up-ir1-transform
           (%data-vector-and-index array index)
         (declare (type (simple-array ,element-type-specifier 1) array)
                  (type ,element-type-specifier new-value))
 -       (data-vector-set array
 -                        index
 -                        new-value)))))
 -
 -(deftransform hairy-data-vector-set ((string index new-value)
 -                                   (simple-string t t))
 -  (let ((ctype (continuation-type string)))
 -    (if (array-type-p ctype)
 -      ;; the other transform will kick in, so that's OK
 -      (give-up-ir1-transform)
 -      `(typecase string
 -        ((simple-array character (*))
 -         (data-vector-set string index new-value))
 -        ((simple-array nil (*))
 -         (data-vector-set string index new-value))))))
 +       ,(if (type= element-ctype declared-element-ctype)
 +            '(data-vector-set array index new-value)
 +            `(truly-the ,(type-specifier declared-element-ctype)
 +               (data-vector-set array index
 +                (the ,(type-specifier declared-element-ctype)
 +                     new-value))))))))
  
  (deftransform data-vector-set ((array index new-value)
                                 (simple-array t t))
  
  (in-package "SB!KERNEL")
  
- (/show0 "vm-type.lisp 17")
- (!begin-collecting-cold-init-forms)
\f
  ;;;; FIXME: I'm not sure where to put this. -- WHN 19990817
  
  (deftype sb!vm:word () `(unsigned-byte ,sb!vm:n-word-bits))
  \f
  ;;;; hooks into the type system
  
- ;;; the kinds of specialized array that actually exist in this implementation
- (defvar *specialized-array-element-types*)
- (!cold-init-forms
-   (setf *specialized-array-element-types*
-       '(nil
-         bit
-         (unsigned-byte 2)
-         (unsigned-byte 4)
-         (unsigned-byte 8)
-         (unsigned-byte 16)
-         (unsigned-byte 32)
-         (signed-byte 8)
-         (signed-byte 16)
-         (signed-byte 30)
-         (signed-byte 32)
-         (complex single-float)
-         (complex double-float)
-         #!+long-float (complex long-float)
-         base-char
-         single-float
-         double-float
-         #!+long-float long-float)))
  (sb!xc:deftype unboxed-array (&optional dims)
    (collect ((types (list 'or)))
      (dolist (type *specialized-array-element-types*)
                ;; them on the fly this way? (Call the new array
                ;; *SPECIALIZED-ARRAY-ELEMENT-SPECIFIER-TYPES* or something..)
                (let ((stype (specifier-type stype-name)))
+                 (aver (not (unknown-type-p stype)))
                  (when (csubtypep eltype stype)
                    (return stype))))))
      type))
  
 +(defun sb!xc:upgraded-array-element-type (spec &optional environment)
 +  #!+sb-doc
 +  "Return the element type that will actually be used to implement an array
 +   with the specifier :ELEMENT-TYPE Spec."
 +  (declare (ignore environment))
 +  (if (unknown-type-p (specifier-type spec))
 +      (error "undefined type: ~S" spec)
 +      (type-specifier (array-type-specialized-element-type
 +                     (specifier-type `(array ,spec))))))
 +
  ;;; Return the most specific integer type that can be quickly checked that
  ;;; includes the given type.
  (defun containing-integer-type (subtype)
       'sb!c:check-fun)
      (t
       nil)))
\f
- (!defun-from-collected-cold-init-forms !vm-type-cold-init)
- (/show0 "vm-type.lisp end of file")
    (predicate-type nil :type (or ctype null)))
  
  (defprinter (fun-info)
 +  (attributes :test (not (zerop attributes))
 +              :prin1 (decode-ir1-attributes attributes))
    (transforms :test transforms)
    (derive-type :test derive-type)
    (optimizer :test optimizer)
                (when (csubtypep type ltype)
                  ltype))))))))
  
- ;;; Derive the type to be the type specifier which is the N'th arg.
+ ;;; Derive the type to be the type specifier which is the Nth arg.
  (defun result-type-specifier-nth-arg (n)
    (lambda (call)
      (declare (type combination call))
        (when (and cont (constant-continuation-p cont))
        (careful-specifier-type (continuation-value cont))))))
  
+ ;;; Derive the type to be the type specifier which is the Nth arg,
+ ;;; with the additional restriptions noted in the CLHS for STRING and
+ ;;; SIMPLE-STRING.
+ (defun creation-result-type-specifier-nth-arg (n)
+   (lambda (call)
+     (declare (type combination call))
+     (let ((cont (nth (1- n) (combination-args call))))
+       (when (and cont (constant-continuation-p cont))
+       (let* ((specifier (continuation-value cont))
+              (lspecifier (if (atom specifier) (list specifier) specifier)))
+         (cond
+           ((eq (car lspecifier) 'string)
+            (destructuring-bind (string &rest size)
+                lspecifier
+              (declare (ignore string))
+              (careful-specifier-type
+               `(vector character ,@(when size size)))))
+           ((eq (car lspecifier) 'simple-string)
+            (destructuring-bind (simple-string &rest size)
+                lspecifier
+              (declare (ignore simple-string))
+              (careful-specifier-type
+               `(simple-array character ,@(if size (list size) '((*)))))))
+           (t (careful-specifier-type specifier))))))))
  (/show0 "knownfun.lisp end of file")
diff --combined version.lisp-expr
@@@ -17,4 -17,4 +17,4 @@@
  ;;; checkins which aren't released. (And occasionally for internal
  ;;; versions, especially for internal versions off the main CVS
  ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
- "0.8.1.33"
 -"0.8.0.78.vector-nil-string.15"
++"0.8.1.34"