0.8.1.9:

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

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 6f6e610..5e00418 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -97,8 +97,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 +150,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

@@ -174,10 +179,7 @@
 (!define-type-method (values :simple-=) (type1 type2)
   (let ((rest1 (args-type-rest type1))
        (rest2 (args-type-rest type2)))
 (!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))
+    (cond ((and rest1 rest2 (type/= rest1 rest2))

           (type= rest1 rest2))
          ((or rest1 rest2)
           (values nil t))
           (type= rest1 rest2))
          ((or rest1 rest2)
           (values nil t))

@@ -231,10 +233,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 +249,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)

@@ -277,10 +285,41 @@
     ((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 (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))))))))))

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

@@ -291,7 +330,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 +362,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 +373,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 +416,45 @@
 ;;; 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)))))
+
+;;; If COUNT values are supplied, which types should they have?
+(defun values-type-start (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))))

 
 ;;; 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 +475,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 +540,31 @@
 ;;; 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 (make-values-type
+                     :required required
+                     :optional opt
+                     :rest rest)
+                    (and rest-exact res-exact))))))))

 
 ;;; 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 +577,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 (args-type-op type1 type2 #'type-union #'min)))))
+

 (defun-cached (values-type-intersection :hash-function type-cache-hash
                                        :hash-bits 8
                                        :values 2
                                        :default (values nil :empty)
                                        :init-wrapper !cold-init-forms)
 (defun-cached (values-type-intersection :hash-function type-cache-hash
                                        :hash-bits 8
                                        :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 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*) (values (coerce-to-values type2) t))
+        ((or (eq type2 *wild-type*) (eq type2 *universal-type*))
+         (values type1 t))
+        ((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
+         (args-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 +617,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))
+        ((or (eq type1 *wild-type*) (eq type2 *wild-type*))
+         (values t t))
+       (t

         (multiple-value-bind (res win) (values-type-intersection type1 type2)
           (values (not (eq res *empty-type*))
         (multiple-value-bind (res win) (values-type-intersection type1 type2)
           (values (not (eq res *empty-type*))

-                  win)))
-       (t
-        (types-equal-or-intersect type1 type2))))
+                  win)))))

 
 ;;; 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 +631,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 +677,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,66 +887,40 @@
 ;;;; 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
 ;;; shared logic for unions and intersections: Return a vector of

-;;; types representing the same types as INPUT-TYPES, but with 
+;;; 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.

+(declaim (inline simplified-compound-types))

 (defun simplified-compound-types (input-types %compound-type-p simplify2)
 (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))
+  (declare (function %compound-type-p simplify2))
+  (let ((types (make-array (length input-types)
+                           :fill-pointer 0
+                           :adjustable t
+                           :element-type 'ctype)))
+    (labels ((accumulate-compound-type (type)
+               (if (funcall %compound-type-p type)
+                   (dolist (type (compound-type-types type))
+                     (accumulate1-compound-type type))
+                   (accumulate1-compound-type type)))
+             (accumulate1-compound-type (type)
+               (declare (type ctype type))
+               ;; 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)))))))
+      (dolist (input-type input-types)
+        (accumulate-compound-type input-type)))
+    types))

 
 ;;; shared logic for unions and intersections: Make a COMPOUND-TYPE
 ;;; object whose components are the types in TYPES, or skip to special
 
 ;;; shared logic for unions and intersections: Make a COMPOUND-TYPE
 ;;; object whose components are the types in TYPES, or skip to special

@@ -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)))

@@ -1153,7 +1218,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 +1387,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)

@@ -1548,17 +1615,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 +1731,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)

@@ -2203,7 +2294,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 +2559,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

@@ -2638,8 +2732,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)

@@ -2765,14 +2859,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