0.8.6.28:

[sbcl.git] / src / code / late-type.lisp

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 6f6e610..c1a29d9 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -25,6 +25,11 @@
 ;;; There are all sorts of nasty problems with open bounds on FLOAT
 ;;; types (and probably FLOAT types in general.)
 
 ;;; 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
 ;;; 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

@@ -97,8 +102,7 @@
 ;;;
 ;;; WHEN controls when the forms are executed.
 (defmacro !define-superclasses (type-class-name specs when)
 ;;;
 ;;; WHEN controls when the forms are executed.
 (defmacro !define-superclasses (type-class-name specs when)

-  (let ((type-class (gensym "TYPE-CLASS-"))
-       (info (gensym "INFO")))
+  (with-unique-names (type-class info)

     `(,when
        (let ((,type-class (type-class-or-lose ',type-class-name))
             (,info (mapcar (lambda (spec)
     `(,when
        (let ((,type-class (type-class-or-lose ',type-class-name))
             (,info (mapcar (lambda (spec)

@@ -151,7 +155,13 @@
   (error "SUBTYPEP is illegal on this type:~%  ~S" (type-specifier type2)))
 
 (!define-type-method (values :unparse) (type)
   (error "SUBTYPEP is illegal on this type:~%  ~S" (type-specifier type2)))
 
 (!define-type-method (values :unparse) (type)

-  (cons 'values (unparse-args-types type)))
+  (cons 'values
+        (let ((unparsed (unparse-args-types type)))
+          (if (or (values-type-optional type)
+                  (values-type-rest type)
+                  (values-type-allowp type))
+              unparsed
+              (nconc unparsed '(&optional))))))

 
 ;;; Return true if LIST1 and LIST2 have the same elements in the same
 ;;; positions according to TYPE=. We return NIL, NIL if there is an
 
 ;;; Return true if LIST1 and LIST2 have the same elements in the same
 ;;; positions according to TYPE=. We return NIL, NIL if there is an

@@ -172,23 +182,7 @@
        (return (values nil t))))))
 
 (!define-type-method (values :simple-=) (type1 type2)
        (return (values nil t))))))
 
 (!define-type-method (values :simple-=) (type1 type2)

-  (let ((rest1 (args-type-rest type1))
-       (rest2 (args-type-rest type2)))
-    (cond ((or (args-type-keyp type1) (args-type-keyp type2)
-              (args-type-allowp type1) (args-type-allowp type2))
-          (values nil nil))
-         ((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)
 
 
 (!define-type-class function)
 

@@ -231,10 +225,14 @@
                    ((fun-type-wild-args type1)
                     (cond ((fun-type-keyp type2) (values nil nil))
                           ((not (fun-type-rest type2)) (values nil t))
                    ((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))
                    ((not (and (fun-type-simple-p type1)
                               (fun-type-simple-p type2)))
                     (values nil nil))

@@ -243,10 +241,12 @@
                           (cond ((or (> max1 max2) (< min1 min2))
                                  (values nil t))
                                 ((and (= min1 min2) (= max1 max2))
                           (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)
                                 (t (every-csubtypep
                                     (concatenate 'list
                                                  (fun-type-required type1)

@@ -262,8 +262,36 @@
   (declare (ignore type1 type2))
   (specifier-type 'function))
 (!define-type-method (function :simple-intersection2) (type1 type2)
   (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.
 
 ;;; The union or intersection of a subclass of FUNCTION with a
 ;;; FUNCTION type is somewhat complicated.

@@ -277,10 +305,16 @@
     ((type= type1 (specifier-type 'function)) type1)
     (t nil)))
 
     ((type= type1 (specifier-type 'function)) type1)
     (t nil)))
 

-;;; ### Not very real, but good enough for redefining transforms
-;;; according to type:

 (!define-type-method (function :simple-=) (type1 type2)
 (!define-type-method (function :simple-=) (type1 type2)

-  (values (equalp type1 type2) t))
+  (macrolet ((compare (comparator field)
+               (let ((reader (symbolicate '#:fun-type- field)))
+                 `(,comparator (,reader type1) (,reader type2)))))
+    (and/type (compare type= returns)
+              (cond ((neq (fun-type-wild-args type1) (fun-type-wild-args type2))
+                     (values nil t))
+                    ((eq (fun-type-wild-args type1) t)
+                     (values t t))
+                    (t (type=-args type1 type2))))))

 
 (!define-type-class constant :inherits values)
 
 
 (!define-type-class constant :inherits values)
 

@@ -291,7 +325,7 @@
   (type= (constant-type-type type1) (constant-type-type type2)))
 
 (!def-type-translator constant-arg (type)
   (type= (constant-type-type type1) (constant-type-type type2)))
 
 (!def-type-translator constant-arg (type)

-  (make-constant-type :type (specifier-type type)))
+  (make-constant-type :type (single-value-specifier-type type)))

 
 ;;; Return the lambda-list-like type specification corresponding
 ;;; to an ARGS-TYPE.
 
 ;;; Return the lambda-list-like type specification corresponding
 ;;; to an ARGS-TYPE.

@@ -323,7 +357,8 @@
     (result)))
 
 (!def-type-translator function (&optional (args '*) (result '*))
     (result)))
 
 (!def-type-translator function (&optional (args '*) (result '*))

-  (make-fun-type :args args :returns (values-specifier-type result)))
+  (make-fun-type :args args
+                 :returns (coerce-to-values (values-specifier-type result))))

 
 (!def-type-translator values (&rest values)
   (make-values-type :args values))
 
 (!def-type-translator values (&rest values)
   (make-values-type :args values))

@@ -333,23 +368,28 @@
 ;;;; We provide a few special operations that can be meaningfully used
 ;;;; on VALUES types (as well as on any other type).
 
 ;;;; We provide a few special operations that can be meaningfully used
 ;;;; on VALUES types (as well as on any other type).
 

+(defun type-single-value-p (type)
+  (and (values-type-p type)
+       (not (values-type-rest type))
+       (null (values-type-optional type))
+       (singleton-p (values-type-required type))))
+

 ;;; Return the type of the first value indicated by TYPE. This is used
 ;;; by people who don't want to have to deal with VALUES types.
 #!-sb-fluid (declaim (freeze-type values-type))
 ; (inline single-value-type))
 (defun single-value-type (type)
   (declare (type ctype type))
 ;;; Return the type of the first value indicated by TYPE. This is used
 ;;; by people who don't want to have to deal with VALUES types.
 #!-sb-fluid (declaim (freeze-type values-type))
 ; (inline single-value-type))
 (defun single-value-type (type)
   (declare (type ctype type))

-  (cond ((values-type-p type)
-        (or (car (args-type-required type))
-             (if (args-type-optional type)
-                 (type-union (car (args-type-optional type))
-                            (specifier-type 'null)))
-            (args-type-rest type)
-             (specifier-type 'null)))
-       ((eq type *wild-type*)
-        *universal-type*)
-       (t
-        type)))
+  (cond ((eq type *wild-type*)
+         *universal-type*)
+        ((eq type *empty-type*)
+         *empty-type*)
+        ((not (values-type-p type))
+         type)
+        (t (or (car (args-type-required type))
+               (car (args-type-optional type))
+               (args-type-rest type)
+               (specifier-type 'null)))))

 
 ;;; Return the minimum number of arguments that a function can be
 ;;; called with, and the maximum number or NIL. If not a function
 
 ;;; Return the minimum number of arguments that a function can be
 ;;; called with, and the maximum number or NIL. If not a function

@@ -371,31 +411,68 @@
 ;;; not fixed, then return NIL and :UNKNOWN.
 (defun values-types (type)
   (declare (type ctype type))
 ;;; not fixed, then return NIL and :UNKNOWN.
 (defun values-types (type)
   (declare (type ctype type))

-  (cond ((eq type *wild-type*)
+  (cond ((or (eq type *wild-type*) (eq type *empty-type*))

         (values nil :unknown))
         (values nil :unknown))

-       ((not (values-type-p type))
-        (values (list type) 1))

        ((or (args-type-optional type)
        ((or (args-type-optional type)

-            (args-type-rest type)
-            (args-type-keyp type)
-            (args-type-allowp type))
+            (args-type-rest type))

         (values nil :unknown))
        (t
         (let ((req (args-type-required type)))
         (values nil :unknown))
        (t
         (let ((req (args-type-required type)))

-          (values (mapcar #'single-value-type req) (length req))))))
+          (values req (length req))))))

 
 ;;; Return two values:
 ;;; 1. A list of all the positional (fixed and optional) types.
 
 ;;; Return two values:
 ;;; 1. A list of all the positional (fixed and optional) types.

-;;; 2. The &REST type (if any). If keywords allowed, *UNIVERSAL-TYPE*.
-;;;    If no keywords or &REST, then the DEFAULT-TYPE.
+;;; 2. The &REST type (if any). If no &REST, then the DEFAULT-TYPE.

 (defun values-type-types (type &optional (default-type *empty-type*))
 (defun values-type-types (type &optional (default-type *empty-type*))

-  (declare (type values-type type))
-  (values (append (args-type-required type)
-                 (args-type-optional type))
-         (cond ((args-type-keyp type) *universal-type*)
-               ((args-type-rest type))
-               (t
-                default-type))))
+  (declare (type ctype type))
+  (if (eq type *wild-type*)
+      (values nil *universal-type*)
+      (values (append (args-type-required type)
+                      (args-type-optional type))
+              (cond ((args-type-rest type))
+                    (t default-type)))))
+
+;;; 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*)
+      (collect ((res))
+        (flet ((process-types (types)
+                 (loop for type in types
+                       while (plusp count)
+                       do (decf count)
+                       do (res type))))
+          (process-types (values-type-required type))
+          (process-types (values-type-optional type))
+          (when (plusp count)
+            (loop with rest = (the ctype (values-type-rest type))
+                  repeat count
+                  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
 
 ;;; Return a list of OPERATION applied to the types in TYPES1 and
 ;;; TYPES2, padding with REST2 as needed. TYPES1 must not be shorter

@@ -416,13 +493,47 @@
                                       :initial-element rest2)))
            exact)))
 
                                       :initial-element rest2)))
            exact)))
 

-;;; If TYPE isn't a values type, then make it into one:
-;;;    <type>  ==>  (values type &rest t)
+;;; If TYPE isn't a values type, then make it into one.
+(defun-cached (%coerce-to-values
+               :hash-bits 8
+               :hash-function (lambda (type)
+                                (logand (type-hash-value type)
+                                        #xff)))
+    ((type eq))
+  (cond ((multiple-value-bind (res sure)
+             (csubtypep (specifier-type 'null) type)
+           (and (not res) sure))
+         ;; FIXME: What should we do with (NOT SURE)?
+         (make-values-type :required (list type) :rest *universal-type*))
+        (t
+         (make-values-type :optional (list type) :rest *universal-type*))))
+

 (defun coerce-to-values (type)
   (declare (type ctype type))
 (defun coerce-to-values (type)
   (declare (type ctype type))

-  (if (values-type-p type)
-      type
-      (make-values-type :required (list type) :rest *universal-type*)))
+  (cond ((or (eq type *universal-type*)
+             (eq type *wild-type*))
+         *wild-type*)
+        ((values-type-p type)
+         type)
+        (t (%coerce-to-values type))))
+
+;;; Return type, corresponding to ANSI short form of VALUES type
+;;; specifier.
+(defun make-short-values-type (types)
+  (declare (list types))
+  (let ((last-required (position-if
+                        (lambda (type)
+                          (not/type (csubtypep (specifier-type 'null) type)))
+                        types
+                        :from-end t)))
+    (if last-required
+        (make-values-type :required (subseq types 0 (1+ last-required))
+                          :optional (subseq types (1+ last-required))
+                          :rest *universal-type*)
+        (make-values-type :optional types :rest *universal-type*))))
+
+(defun make-single-value-type (type)
+  (make-values-type :required (list type)))

 
 ;;; Do the specified OPERATION on TYPE1 and TYPE2, which may be any
 ;;; type, including VALUES types. With VALUES types such as:
 
 ;;; Do the specified OPERATION on TYPE1 and TYPE2, which may be any
 ;;; type, including VALUES types. With VALUES types such as:

@@ -447,41 +558,53 @@
 ;;; OPERATION returned true as its second value each time we called
 ;;; it. Since we approximate the intersection of VALUES types, the
 ;;; second value being true doesn't mean the result is exact.
 ;;; OPERATION returned true as its second value each time we called
 ;;; it. Since we approximate the intersection of VALUES types, the
 ;;; second value being true doesn't mean the result is exact.

-(defun args-type-op (type1 type2 operation nreq default-type)
-  (declare (type ctype type1 type2 default-type)
+(defun args-type-op (type1 type2 operation nreq)
+  (declare (type ctype type1 type2)

           (type function operation nreq))
   (when (eq type1 type2)
     (values type1 t))
           (type function operation nreq))
   (when (eq type1 type2)
     (values type1 t))

-  (if (or (values-type-p type1) (values-type-p type2))
-      (let ((type1 (coerce-to-values type1))
-           (type2 (coerce-to-values type2)))
-       (multiple-value-bind (types1 rest1)
-            (values-type-types type1 default-type)
-         (multiple-value-bind (types2 rest2)
-              (values-type-types type2 default-type)
-           (multiple-value-bind (rest rest-exact)
-               (funcall operation rest1 rest2)
-             (multiple-value-bind (res res-exact)
-                 (if (< (length types1) (length types2))
-                     (fixed-values-op types2 types1 rest1 operation)
-                     (fixed-values-op types1 types2 rest2 operation))
-               (let* ((req (funcall nreq
-                                    (length (args-type-required type1))
-                                    (length (args-type-required type2))))
-                      (required (subseq res 0 req))
-                      (opt (subseq res req))
-                      (opt-last (position rest opt :test-not #'type=
-                                          :from-end t)))
-                 (if (find *empty-type* required :test #'type=)
-                     (values *empty-type* t)
-                     (values (make-values-type
-                              :required required
-                              :optional (if opt-last
-                                            (subseq opt 0 (1+ opt-last))
-                                            ())
-                              :rest (if (eq rest default-type) nil rest))
-                             (and rest-exact res-exact)))))))))
-      (funcall operation type1 type2)))
+  (multiple-value-bind (types1 rest1)
+      (values-type-types type1)
+    (multiple-value-bind (types2 rest2)
+        (values-type-types type2)
+      (multiple-value-bind (rest rest-exact)
+          (funcall operation rest1 rest2)
+        (multiple-value-bind (res res-exact)
+            (if (< (length types1) (length types2))
+                (fixed-values-op types2 types1 rest1 operation)
+                (fixed-values-op types1 types2 rest2 operation))
+          (let* ((req (funcall nreq
+                               (length (args-type-required type1))
+                               (length (args-type-required type2))))
+                 (required (subseq res 0 req))
+                 (opt (subseq res req)))
+            (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,
 
 ;;; Do a union or intersection operation on types that might be values
 ;;; types. The result is optimized for utility rather than exactness,

@@ -494,27 +617,38 @@
                                 :hash-bits 8
                                 :default nil
                                 :init-wrapper !cold-init-forms)
                                 :hash-bits 8
                                 :default nil
                                 :init-wrapper !cold-init-forms)

-             ((type1 eq) (type2 eq))
+    ((type1 eq) (type2 eq))

   (declare (type ctype type1 type2))
   (cond ((or (eq type1 *wild-type*) (eq type2 *wild-type*)) *wild-type*)
   (declare (type ctype type1 type2))
   (cond ((or (eq type1 *wild-type*) (eq type2 *wild-type*)) *wild-type*)

-       ((eq type1 *empty-type*) type2)
-       ((eq type2 *empty-type*) type1)
-       (t
-        (values (args-type-op type1 type2 #'type-union #'min *empty-type*)))))
+        ((eq type1 *empty-type*) type2)
+        ((eq type2 *empty-type*) type1)
+        (t
+         (values (values-type-op type1 type2 #'type-union #'min)))))
+

 (defun-cached (values-type-intersection :hash-function type-cache-hash
                                        :hash-bits 8
 (defun-cached (values-type-intersection :hash-function type-cache-hash
                                        :hash-bits 8

-                                       :values 2
-                                       :default (values nil :empty)
+                                       :default (values nil)

                                        :init-wrapper !cold-init-forms)
                                        :init-wrapper !cold-init-forms)

-             ((type1 eq) (type2 eq))
+    ((type1 eq) (type2 eq))

   (declare (type ctype type1 type2))
   (declare (type ctype type1 type2))

-  (cond ((eq type1 *wild-type*) (values type2 t))
-       ((eq type2 *wild-type*) (values type1 t))
-       (t
-        (args-type-op type1 type2
-                      #'type-intersection
-                      #'max
-                      (specifier-type 'null)))))
+  (cond ((eq type1 *wild-type*)
+         (coerce-to-values type2))
+        ((or (eq type2 *wild-type*) (eq type2 *universal-type*))
+         type1)
+        ((or (eq type1 *empty-type*) (eq type2 *empty-type*))
+         *empty-type*)
+        ((and (not (values-type-p type2))
+              (values-type-required type1))
+         (let ((req1 (values-type-required type1)))
+           (make-values-type :required (cons (type-intersection (first req1) type2)
+                                             (rest req1))
+                             :optional (values-type-optional type1)
+                             :rest (values-type-rest type1)
+                             :allowp (values-type-allowp type1))))
+        (t
+         (values (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
 
 ;;; This is like TYPES-EQUAL-OR-INTERSECT, except that it sort of
 ;;; works on VALUES types. Note that due to the semantics of

@@ -523,12 +657,12 @@
 (defun values-types-equal-or-intersect (type1 type2)
   (cond ((or (eq type1 *empty-type*) (eq type2 *empty-type*))
         (values t t))
 (defun values-types-equal-or-intersect (type1 type2)
   (cond ((or (eq type1 *empty-type*) (eq type2 *empty-type*))
         (values t t))

-       ((or (values-type-p type1) (values-type-p type2))
-        (multiple-value-bind (res win) (values-type-intersection type1 type2)
-          (values (not (eq res *empty-type*))
-                  win)))
+        ((or (eq type1 *wild-type*) (eq type2 *wild-type*))
+         (values t t))

        (t
        (t

-        (types-equal-or-intersect type1 type2))))
+        (let ((res (values-type-intersection type1 type2)))
+          (values (not (eq res *empty-type*))
+                  t)))))

 
 ;;; a SUBTYPEP-like operation that can be used on any types, including
 ;;; VALUES types
 
 ;;; a SUBTYPEP-like operation that can be used on any types, including
 ;;; VALUES types

@@ -537,39 +671,39 @@
                               :values 2
                               :default (values nil :empty)
                               :init-wrapper !cold-init-forms)
                               :values 2
                               :default (values nil :empty)
                               :init-wrapper !cold-init-forms)

-             ((type1 eq) (type2 eq))
+    ((type1 eq) (type2 eq))

   (declare (type ctype type1 type2))
   (declare (type ctype type1 type2))

-  (cond ((eq type2 *wild-type*) (values t t))
-       ((eq type1 *wild-type*)
-        (values (eq type2 *universal-type*) t))
-       ((not (values-types-equal-or-intersect type1 type2))
-        (values nil t))
-       (t
-        (if (or (values-type-p type1) (values-type-p type2))
-            (let ((type1 (coerce-to-values type1))
-                  (type2 (coerce-to-values type2)))
-              (multiple-value-bind (types1 rest1) (values-type-types type1)
-                (multiple-value-bind (types2 rest2) (values-type-types type2)
-                  (cond ((< (length (values-type-required type1))
-                            (length (values-type-required type2)))
-                         (values nil t))
-                        ((< (length types1) (length types2))
-                         (values nil nil))
-                        ((or (values-type-keyp type1)
-                             (values-type-keyp type2))
-                         (values nil nil))
-                        (t
-                         (do ((t1 types1 (rest t1))
-                              (t2 types2 (rest t2)))
-                             ((null t2)
-                              (csubtypep rest1 rest2))
-                           (multiple-value-bind (res win-p)
-                               (csubtypep (first t1) (first t2))
-                             (unless win-p
-                               (return (values nil nil)))
-                             (unless res
-                               (return (values nil t))))))))))
-            (csubtypep type1 type2)))))
+  (cond ((or (eq type2 *wild-type*) (eq type2 *universal-type*)
+             (eq type1 *empty-type*))
+         (values t t))
+        ((eq type1 *wild-type*)
+         (values (eq type2 *wild-type*) t))
+        ((or (eq type2 *empty-type*)
+             (not (values-types-equal-or-intersect type1 type2)))
+         (values nil t))
+        ((and (not (values-type-p type2))
+              (values-type-required type1))
+         (csubtypep (first (values-type-required type1))
+                    type2))
+        (t (setq type2 (coerce-to-values type2))
+           (multiple-value-bind (types1 rest1) (values-type-types type1)
+             (multiple-value-bind (types2 rest2) (values-type-types type2)
+               (cond ((< (length (values-type-required type1))
+                         (length (values-type-required type2)))
+                      (values nil t))
+                     ((< (length types1) (length types2))
+                      (values nil nil))
+                     (t
+                      (do ((t1 types1 (rest t1))
+                           (t2 types2 (rest t2)))
+                          ((null t2)
+                           (csubtypep rest1 rest2))
+                        (multiple-value-bind (res win-p)
+                            (csubtypep (first t1) (first t2))
+                          (unless win-p
+                            (return (values nil nil)))
+                          (unless res
+                            (return (values nil t))))))))))))

 \f
 ;;;; type method interfaces
 
 \f
 ;;;; type method interfaces
 

@@ -583,9 +717,10 @@
   (declare (type ctype type1 type2))
   (cond ((or (eq type1 type2)
             (eq type1 *empty-type*)
   (declare (type ctype type1 type2))
   (cond ((or (eq type1 type2)
             (eq type1 *empty-type*)

-            (eq type2 *wild-type*))
+            (eq type2 *universal-type*))

         (values t t))
         (values t t))

-       ((eq type1 *wild-type*)
+        #+nil
+       ((eq type1 *universal-type*)

         (values nil t))
        (t
         (!invoke-type-method :simple-subtypep :complex-subtypep-arg2
         (values nil t))
        (t
         (!invoke-type-method :simple-subtypep :complex-subtypep-arg2

@@ -792,91 +927,27 @@
 ;;;; These are fully general operations on CTYPEs: they'll always
 ;;;; return a CTYPE representing the result.
 
 ;;;; These are fully general operations on CTYPEs: they'll always
 ;;;; return a CTYPE representing the result.
 

-;;; shared logic for unions and intersections: Stuff TYPE into the
-;;; vector TYPES, finding pairs of types which can be simplified by
-;;; SIMPLIFY2 (TYPE-UNION2 or TYPE-INTERSECTION2) and replacing them
-;;; by their simplified forms.
-(defun accumulate1-compound-type (type types %compound-type-p simplify2)
-  (declare (type ctype type))
-  (declare (type (vector ctype) types))
-  (declare (type function %compound-type-p simplify2))
-  ;; Any input object satisfying %COMPOUND-TYPE-P should've been
-  ;; broken into components before it reached us.
-  (aver (not (funcall %compound-type-p type)))
-  (dotimes (i (length types) (vector-push-extend type types))
-    (let ((simplified2 (funcall simplify2 type (aref types i))))
-      (when simplified2
-       ;; Discard the old (AREF TYPES I).
-       (setf (aref types i) (vector-pop types))
-       ;; Merge the new SIMPLIFIED2 into TYPES, by tail recursing.
-       ;; (Note that the tail recursion is indirect: we go through
-       ;; ACCUMULATE, not ACCUMULATE1, so that if SIMPLIFIED2 is
-       ;; handled properly if it satisfies %COMPOUND-TYPE-P.)
-       (return (accumulate-compound-type simplified2
-                                         types
-                                         %compound-type-p
-                                         simplify2)))))
-  ;; Voila.
-  (values))
-
-;;; shared logic for unions and intersections: Use
-;;; ACCUMULATE1-COMPOUND-TYPE to merge TYPE into TYPES, either
-;;; all in one step or, if %COMPOUND-TYPE-P is satisfied,
-;;; component by component.
-(defun accumulate-compound-type (type types %compound-type-p simplify2)
-  (declare (type function %compound-type-p simplify2))
-  (flet ((accumulate1 (x)
-          (accumulate1-compound-type x types %compound-type-p simplify2)))
-    (declare (inline accumulate1))
-    (if (funcall %compound-type-p type)
-       (map nil #'accumulate1 (compound-type-types type))
-       (accumulate1 type)))
-  (values))
-
-;;; shared logic for unions and intersections: Return a vector of
-;;; types representing the same types as INPUT-TYPES, but with 
+;;; shared logic for unions and intersections: Return a list of
+;;; types representing the same types as INPUT-TYPES, but with

 ;;; COMPOUND-TYPEs satisfying %COMPOUND-TYPE-P broken up into their
 ;;; component types, and with any SIMPLY2 simplifications applied.
 ;;; COMPOUND-TYPEs satisfying %COMPOUND-TYPE-P broken up into their
 ;;; component types, and with any SIMPLY2 simplifications applied.

-(defun simplified-compound-types (input-types %compound-type-p simplify2)
-  (let ((simplified-types (make-array (length input-types)
-                                     :fill-pointer 0
-                                     :adjustable t
-                                     :element-type 'ctype
-                                     ;; (This INITIAL-ELEMENT shouldn't
-                                     ;; matter, but helps avoid type
-                                     ;; warnings at compile time.)
-                                     :initial-element *empty-type*)))
-    (dolist (input-type input-types)
-      (accumulate-compound-type input-type
-                               simplified-types
-                               %compound-type-p
-                               simplify2))
-    simplified-types))
-
-;;; shared logic for unions and intersections: Make a COMPOUND-TYPE
-;;; object whose components are the types in TYPES, or skip to special
-;;; cases when TYPES is short.
-(defun make-probably-compound-type (constructor types enumerable identity)
-  (declare (type function constructor))
-  (declare (type (vector ctype) types))
-  (declare (type ctype identity))
-  (case (length types)
-    (0 identity)
-    (1 (aref types 0))
-    (t (funcall constructor
-               enumerable
-               ;; FIXME: This should be just (COERCE TYPES 'LIST), but as
-               ;; of sbcl-0.6.11.17 the COERCE optimizer is really
-               ;; brain-dead, so that would generate a full call to
-               ;; SPECIFIER-TYPE at runtime, so we get into bootstrap
-               ;; problems in cold init because 'LIST is a compound
-               ;; type, so we need to MAKE-PROBABLY-COMPOUND-TYPE
-               ;; before we know what 'LIST is. Once the COERCE
-               ;; optimizer is less brain-dead, we can make this
-               ;; (COERCE TYPES 'LIST) again.
-               #+sb-xc-host (coerce types 'list)
-               #-sb-xc-host (coerce-to-list types)))))
-
+(macrolet
+    ((def (name compound-type-p simplify2)
+        `(defun ,name (types)
+           (when types
+             (multiple-value-bind (first rest)
+                 (if (,compound-type-p (car types))
+                     (values (car (compound-type-types (car types)))
+                             (append (cdr (compound-type-types (car types)))
+                                     (cdr types)))
+                     (values (car types) (cdr types)))
+               (let ((rest (,name rest)) u)
+                 (dolist (r rest (cons first rest))
+                   (when (setq u (,simplify2 first r))
+                     (return (,name (nsubstitute u r rest)))))))))))
+  (def simplify-intersections intersection-type-p type-intersection2)
+  (def simplify-unions union-type-p type-union2))
+                

 (defun maybe-distribute-one-union (union-type types)
   (let* ((intersection (apply #'type-intersection types))
         (union (mapcar (lambda (x) (type-intersection x intersection))
 (defun maybe-distribute-one-union (union-type types)
   (let* ((intersection (apply #'type-intersection types))
         (union (mapcar (lambda (x) (type-intersection x intersection))

@@ -893,10 +964,8 @@
                                   :hash-function (lambda (x)
                                                    (logand (sxhash x) #xff)))
     ((input-types equal))
                                   :hash-function (lambda (x)
                                                    (logand (sxhash x) #xff)))
     ((input-types equal))

-  (let ((simplified-types (simplified-compound-types input-types
-                                                    #'intersection-type-p
-                                                    #'type-intersection2)))
-    (declare (type (vector ctype) simplified-types))
+  (let ((simplified-types (simplify-intersections input-types)))
+    (declare (type list simplified-types))

     ;; We want to have a canonical representation of types (or failing
     ;; that, punt to HAIRY-TYPE). Canonical representation would have
     ;; intersections inside unions but not vice versa, since you can
     ;; We want to have a canonical representation of types (or failing
     ;; that, punt to HAIRY-TYPE). Canonical representation would have
     ;; intersections inside unions but not vice versa, since you can

@@ -905,8 +974,7 @@
     ;; to end up with unreasonably huge type expressions. So instead
     ;; we try to generate a simple type by distributing the union; if
     ;; the type can't be made simple, we punt to HAIRY-TYPE.
     ;; to end up with unreasonably huge type expressions. So instead
     ;; we try to generate a simple type by distributing the union; if
     ;; the type can't be made simple, we punt to HAIRY-TYPE.

-    (if (and (> (length simplified-types) 1)
-            (some #'union-type-p simplified-types))
+    (if (and (cdr simplified-types) (some #'union-type-p simplified-types))

        (let* ((first-union (find-if #'union-type-p simplified-types))
               (other-types (coerce (remove first-union simplified-types)
                                    'list))
        (let* ((first-union (find-if #'union-type-p simplified-types))
               (other-types (coerce (remove first-union simplified-types)
                                    'list))

@@ -918,11 +986,12 @@
               :specifier `(and ,@(map 'list
                                       #'type-specifier
                                       simplified-types)))))
               :specifier `(and ,@(map 'list
                                       #'type-specifier
                                       simplified-types)))))

-       (make-probably-compound-type #'%make-intersection-type
-                                    simplified-types
-                                    (some #'type-enumerable
-                                          simplified-types)
-                                    *universal-type*))))
+       (cond
+         ((null simplified-types) *universal-type*)
+         ((null (cdr simplified-types)) (car simplified-types))
+         (t (%make-intersection-type
+             (some #'type-enumerable simplified-types)
+             simplified-types))))))

 
 (defun type-union (&rest input-types)
   (%type-union input-types))
 
 (defun type-union (&rest input-types)
   (%type-union input-types))

@@ -930,13 +999,13 @@
                            :hash-function (lambda (x)
                                             (logand (sxhash x) #xff)))
     ((input-types equal))
                            :hash-function (lambda (x)
                                             (logand (sxhash x) #xff)))
     ((input-types equal))

-  (let ((simplified-types (simplified-compound-types input-types
-                                                    #'union-type-p
-                                                    #'type-union2)))
-    (make-probably-compound-type #'make-union-type
-                                simplified-types
-                                (every #'type-enumerable simplified-types)
-                                *empty-type*)))
+  (let ((simplified-types (simplify-unions input-types)))
+    (cond
+      ((null simplified-types) *empty-type*)
+      ((null (cdr simplified-types)) (car simplified-types))
+      (t (make-union-type
+         (every #'type-enumerable simplified-types)
+         simplified-types)))))

 \f
 ;;;; built-in types
 
 \f
 ;;;; built-in types
 

@@ -946,19 +1015,18 @@
 (defvar *empty-type*)
 (defvar *universal-type*)
 (defvar *universal-fun-type*)
 (defvar *empty-type*)
 (defvar *universal-type*)
 (defvar *universal-fun-type*)

+

 (!cold-init-forms
  (macrolet ((frob (name var)
              `(progn
 (!cold-init-forms
  (macrolet ((frob (name var)
              `(progn

-                (setq ,var (make-named-type :name ',name))
+                 (setq ,var (make-named-type :name ',name))

                 (setf (info :type :kind ',name)
                       #+sb-xc-host :defined #-sb-xc-host :primitive)
                 (setf (info :type :builtin ',name) ,var))))
    ;; KLUDGE: In ANSI, * isn't really the name of a type, it's just a
    ;; special symbol which can be stuck in some places where an
    ;; ordinary type can go, e.g. (ARRAY * 1) instead of (ARRAY T 1).
                 (setf (info :type :kind ',name)
                       #+sb-xc-host :defined #-sb-xc-host :primitive)
                 (setf (info :type :builtin ',name) ,var))))
    ;; KLUDGE: In ANSI, * isn't really the name of a type, it's just a
    ;; special symbol which can be stuck in some places where an
    ;; ordinary type can go, e.g. (ARRAY * 1) instead of (ARRAY T 1).

-   ;; At some point, in order to become more standard, we should
-   ;; convert all the classic CMU CL legacy *s and *WILD-TYPE*s into
-   ;; Ts and *UNIVERSAL-TYPE*s.
+   ;; In SBCL it also used to denote universal VALUES type.

    (frob * *wild-type*)
    (frob nil *empty-type*)
    (frob t *universal-type*))
    (frob * *wild-type*)
    (frob nil *empty-type*)
    (frob t *universal-type*))

@@ -967,9 +1035,6 @@
                      :returns *wild-type*)))
 
 (!define-type-method (named :simple-=) (type1 type2)
                      :returns *wild-type*)))
 
 (!define-type-method (named :simple-=) (type1 type2)

-  ;; FIXME: BUG 85: This assertion failed when I added it in
-  ;; sbcl-0.6.11.13. It probably shouldn't fail; but for now it's
-  ;; just commented out.

   ;;(aver (not (eq type1 *wild-type*))) ; * isn't really a type.
   (values (eq type1 type2) t))
 
   ;;(aver (not (eq type1 *wild-type*))) ; * isn't really a type.
   (values (eq type1 type2) t))
 

@@ -1020,7 +1085,7 @@
         (values nil nil))
        (t
         ;; By elimination, TYPE1 is the universal type.
         (values nil nil))
        (t
         ;; By elimination, TYPE1 is the universal type.

-        (aver (or (eq type1 *wild-type*) (eq type1 *universal-type*)))
+        (aver (eq type1 *universal-type*))

         ;; This case would have been picked off by the SIMPLE-SUBTYPEP
         ;; method, and so shouldn't appear here.
         (aver (not (eq type2 *universal-type*)))
         ;; This case would have been picked off by the SIMPLE-SUBTYPEP
         ;; method, and so shouldn't appear here.
         (aver (not (eq type2 *universal-type*)))

@@ -1061,7 +1126,7 @@
 
 (!define-type-method (hairy :unparse) (x)
   (hairy-type-specifier x))
 
 (!define-type-method (hairy :unparse) (x)
   (hairy-type-specifier x))

-    
+

 (!define-type-method (hairy :simple-subtypep) (type1 type2)
   (let ((hairy-spec1 (hairy-type-specifier type1))
        (hairy-spec2 (hairy-type-specifier type2)))
 (!define-type-method (hairy :simple-subtypep) (type1 type2)
   (let ((hairy-spec1 (hairy-type-specifier type1))
        (hairy-spec2 (hairy-type-specifier type2)))

@@ -1078,8 +1143,17 @@
   (values nil nil))
 
 (!define-type-method (hairy :complex-=) (type1 type2)
   (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)
 
 (!define-type-method (hairy :simple-intersection2 :complex-intersection2) 
                     (type1 type2)

@@ -1153,7 +1227,7 @@
     (let ((complement-type1 (negation-type-type type1)))
       ;; Do the special cases first, in order to give us a chance if
       ;; subtype/supertype relationships are hairy.
     (let ((complement-type1 (negation-type-type type1)))
       ;; Do the special cases first, in order to give us a chance if
       ;; subtype/supertype relationships are hairy.

-      (multiple-value-bind (equal certain) 
+      (multiple-value-bind (equal certain)

          (type= complement-type1 type2)
        ;; If a = b, ~a is not a subtype of b (unless b=T, which was
        ;; excluded above).
          (type= complement-type1 type2)
        ;; If a = b, ~a is not a subtype of b (unless b=T, which was
        ;; excluded above).

@@ -1322,8 +1396,10 @@
        (let ((members (member-type-members not-type)))
         (if (some #'floatp members)
             (let (floats)
        (let ((members (member-type-members not-type)))
         (if (some #'floatp members)
             (let (floats)

-              (dolist (pair '((0.0f0 . -0.0f0) (0.0d0 . -0.0d0)
-                              #!+long-float (0.0l0 . -0.0l0)))
+              (dolist (pair `((0.0f0 . ,(load-time-value (make-unportable-float :single-float-negative-zero)))
+                              (0.0d0 . ,(load-time-value (make-unportable-float :double-float-negative-zero)))
+                              #!+long-float
+                              (0.0l0 . ,(load-time-value (make-unportable-float :long-float-negative-zero)))))

                 (when (member (car pair) members)
                   (aver (not (member (cdr pair) members)))
                   (push (cdr pair) floats)
                 (when (member (car pair) members)
                   (aver (not (member (cdr pair) members)))
                   (push (cdr pair) floats)

@@ -1387,11 +1463,15 @@
 
 (!define-type-class number)
 
 
 (!define-type-class number)
 

+(declaim (inline numeric-type-equal))
+(defun numeric-type-equal (type1 type2)
+  (and (eq (numeric-type-class type1) (numeric-type-class type2))
+       (eq (numeric-type-format type1) (numeric-type-format type2))
+       (eq (numeric-type-complexp type1) (numeric-type-complexp type2))))
+

 (!define-type-method (number :simple-=) (type1 type2)
   (values
 (!define-type-method (number :simple-=) (type1 type2)
   (values

-   (and (eq (numeric-type-class type1) (numeric-type-class type2))
-       (eq (numeric-type-format type1) (numeric-type-format type2))
-       (eq (numeric-type-complexp type1) (numeric-type-complexp type2))
+   (and (numeric-type-equal type1 type2)

        (equalp (numeric-type-low type1) (numeric-type-low type2))
        (equalp (numeric-type-high type1) (numeric-type-high type2)))
    t))
        (equalp (numeric-type-low type1) (numeric-type-low type2))
        (equalp (numeric-type-high type1) (numeric-type-high type2)))
    t))

@@ -1548,17 +1628,41 @@
          ((consp low-bound)
           (let ((low-value (car low-bound)))
             (or (eql low-value high-bound)
          ((consp low-bound)
           (let ((low-value (car low-bound)))
             (or (eql low-value high-bound)

-                (and (eql low-value -0f0) (eql high-bound 0f0))
-                (and (eql low-value 0f0) (eql high-bound -0f0))
-                (and (eql low-value -0d0) (eql high-bound 0d0))
-                (and (eql low-value 0d0) (eql high-bound -0d0)))))
+                (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)
          ((consp high-bound)
           (let ((high-value (car high-bound)))
             (or (eql high-value low-bound)

-                (and (eql high-value -0f0) (eql low-bound 0f0))
-                (and (eql high-value 0f0) (eql low-bound -0f0))
-                (and (eql high-value -0d0) (eql low-bound 0d0))
-                (and (eql high-value 0d0) (eql low-bound -0d0)))))
+                (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))
          ((and (eq (numeric-type-class low) 'integer)
                (eq (numeric-type-class high) 'integer))
           (eql (1+ low-bound) high-bound))

@@ -1640,7 +1744,7 @@
                                        (numeric-type-high type2)
                                        >= > t)))
             (t nil))))))
                                        (numeric-type-high type2)
                                        >= > t)))
             (t nil))))))

-             
+

 
 (!cold-init-forms
   (setf (info :type :kind 'number)
 
 (!cold-init-forms
   (setf (info :type :kind 'number)

@@ -2067,25 +2171,21 @@
                   (case eltype
                     (bit 'bit-vector)
                     (base-char 'base-string)
                   (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)))
                     (* '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)
                     (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)))
                     ((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
                     ((t) `(simple-vector ,(car dims)))
                     (t `(simple-array ,eltype ,dims))))))
          (t

@@ -2133,8 +2233,9 @@
                          (specialized-element-type-maybe type2))
                   t)))))
 
                          (specialized-element-type-maybe type2))
                   t)))))
 

+;;; FIXME: is this dead?

 (!define-superclasses array
 (!define-superclasses array

-  ((string string)
+  ((base-string base-string)

    (vector vector)
    (array))
   !cold-init-forms)
    (vector vector)
    (array))
   !cold-init-forms)

@@ -2203,7 +2304,10 @@
                             (mapcar (lambda (x y) (if (eq x '*) y x))
                                     dims1 dims2)))
          :complexp (if (eq complexp1 :maybe) complexp2 complexp1)
                             (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,
       *empty-type*))
 
 ;;; Check a supplied dimension list to determine whether it is legal,

@@ -2465,7 +2569,7 @@
                     (return nil)))
               (setf accumulator
                     (type-intersection accumulator union))))))))
                     (return nil)))
               (setf accumulator
                     (type-intersection accumulator union))))))))

-        
+

 (!def-type-translator and (&whole whole &rest type-specifiers)
   (apply #'type-intersection
         (mapcar #'specifier-type
 (!def-type-translator and (&whole whole &rest type-specifiers)
   (apply #'type-intersection
         (mapcar #'specifier-type

@@ -2485,6 +2589,8 @@
     ((type= type (specifier-type 'real)) 'real)
     ((type= type (specifier-type 'sequence)) 'sequence)
     ((type= type (specifier-type 'bignum)) 'bignum)
     ((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
     (t `(or ,@(mapcar #'type-specifier (union-type-types type))))))
 
 ;;; Two union types are equal if they are each subtypes of each

@@ -2638,8 +2744,8 @@
 (!define-type-class cons)
 
 (!def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*))
 (!define-type-class cons)
 
 (!def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*))

-  (let ((car-type (specifier-type car-type-spec))
-       (cdr-type (specifier-type cdr-type-spec)))
+  (let ((car-type (single-value-specifier-type car-type-spec))
+       (cdr-type (single-value-specifier-type cdr-type-spec)))

     (make-cons-type car-type cdr-type)))
  
 (!define-type-method (cons :unparse) (type)
     (make-cons-type car-type cdr-type)))
  
 (!define-type-method (cons :unparse) (type)

@@ -2672,15 +2778,20 @@
   (let ((car-type1 (cons-type-car-type type1))
        (car-type2 (cons-type-car-type type2))
        (cdr-type1 (cons-type-cdr-type type1))
   (let ((car-type1 (cons-type-car-type type1))
        (car-type2 (cons-type-car-type type2))
        (cdr-type1 (cons-type-cdr-type type1))

-       (cdr-type2 (cons-type-cdr-type type2)))
+       (cdr-type2 (cons-type-cdr-type type2))
+       car-not1
+       car-not2)

     ;; UGH.  -- CSR, 2003-02-24
     ;; UGH.  -- CSR, 2003-02-24

-    (macrolet ((frob-car (car1 car2 cdr1 cdr2)
+    (macrolet ((frob-car (car1 car2 cdr1 cdr2
+                         &optional (not1 nil not1p))

                 `(type-union
                   (make-cons-type ,car1 (type-union ,cdr1 ,cdr2))
                   (make-cons-type
                    (type-intersection ,car2
                 `(type-union
                   (make-cons-type ,car1 (type-union ,cdr1 ,cdr2))
                   (make-cons-type
                    (type-intersection ,car2

-                    (specifier-type
-                     `(not ,(type-specifier ,car1))))
+                    ,(if not1p
+                         not1
+                         `(specifier-type
+                           `(not ,(type-specifier ,car1)))))

                    ,cdr2))))
       (cond ((type= car-type1 car-type2)
             (make-cons-type car-type1
                    ,cdr2))))
       (cond ((type= car-type1 car-type2)
             (make-cons-type car-type1

@@ -2692,6 +2803,17 @@
             (frob-car car-type1 car-type2 cdr-type1 cdr-type2))
            ((csubtypep car-type2 car-type1)
             (frob-car car-type2 car-type1 cdr-type2 cdr-type1))
             (frob-car car-type1 car-type2 cdr-type1 cdr-type2))
            ((csubtypep car-type2 car-type1)
             (frob-car car-type2 car-type1 cdr-type2 cdr-type1))

+           ;; more general case of the above, but harder to compute
+           ((progn
+              (setf car-not1 (specifier-type
+                              `(not ,(type-specifier car-type1))))
+              (not (csubtypep car-type2 car-not1)))
+            (frob-car car-type1 car-type2 cdr-type1 cdr-type2 car-not1))
+           ((progn
+              (setf car-not2 (specifier-type
+                              `(not ,(type-specifier car-type2))))
+              (not (csubtypep car-type1 car-not2)))
+            (frob-car car-type2 car-type1 cdr-type2 cdr-type1 car-not2))

            ;; Don't put these in -- consider the effect of taking the
            ;; union of (CONS (INTEGER 0 2) (INTEGER 5 7)) and
            ;; (CONS (INTEGER 0 3) (INTEGER 5 6)).
            ;; Don't put these in -- consider the effect of taking the
            ;; union of (CONS (INTEGER 0 2) (INTEGER 5 7)) and
            ;; (CONS (INTEGER 0 3) (INTEGER 5 6)).

@@ -2704,14 +2826,21 @@
            
 (!define-type-method (cons :simple-intersection2) (type1 type2)
   (declare (type cons-type type1 type2))
            
 (!define-type-method (cons :simple-intersection2) (type1 type2)
   (declare (type cons-type type1 type2))

-  (let (car-int2
-       cdr-int2)
-    (and (setf car-int2 (type-intersection2 (cons-type-car-type type1)
-                                           (cons-type-car-type type2)))
-        (setf cdr-int2 (type-intersection2 (cons-type-cdr-type type1)
-                                           (cons-type-cdr-type type2)))
-        (make-cons-type car-int2 cdr-int2))))
-\f
+  (let ((car-int2 (type-intersection2 (cons-type-car-type type1)
+                                     (cons-type-car-type type2)))
+       (cdr-int2 (type-intersection2 (cons-type-cdr-type type1)
+                                     (cons-type-cdr-type type2))))
+    (cond
+      ((and car-int2 cdr-int2) (make-cons-type car-int2 cdr-int2))
+      (car-int2 (make-cons-type car-int2
+                               (type-intersection
+                                (cons-type-cdr-type type1)
+                                (cons-type-cdr-type type2))))
+      (cdr-int2 (make-cons-type
+                (type-intersection (cons-type-car-type type1)
+                                   (cons-type-car-type type2))
+                cdr-int2)))))
+\f                               

 ;;; Return the type that describes all objects that are in X but not
 ;;; in Y. If we can't determine this type, then return NIL.
 ;;;
 ;;; Return the type that describes all objects that are in X but not
 ;;; in Y. If we can't determine this type, then return NIL.
 ;;;

@@ -2765,14 +2894,18 @@
   (specialize-array-type
    (make-array-type :dimensions (canonical-array-dimensions dimensions)
                     :complexp :maybe
   (specialize-array-type
    (make-array-type :dimensions (canonical-array-dimensions dimensions)
                     :complexp :maybe

-                   :element-type (specifier-type element-type))))
+                   :element-type (if (eq element-type '*)
+                                      *wild-type*
+                                      (specifier-type element-type)))))

 
 (!def-type-translator simple-array (&optional (element-type '*)
                                              (dimensions '*))
   (specialize-array-type
    (make-array-type :dimensions (canonical-array-dimensions dimensions)
                     :complexp nil
 
 (!def-type-translator simple-array (&optional (element-type '*)
                                              (dimensions '*))
   (specialize-array-type
    (make-array-type :dimensions (canonical-array-dimensions dimensions)
                     :complexp nil

-                   :element-type (specifier-type element-type))))
+                   :element-type (if (eq element-type '*)
+                                      *wild-type*
+                                      (specifier-type element-type)))))

 \f
 ;;;; utilities shared between cross-compiler and target system
 
 \f
 ;;;; utilities shared between cross-compiler and target system