0.8.3.8:

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

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 296d88c..da4f37f 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -627,28 +627,28 @@
 
 (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)
     ((type1 eq) (type2 eq))
   (declare (type ctype type1 type2))
-  (cond ((eq type1 *wild-type*) (values (coerce-to-values type2) t))
+  (cond ((eq type1 *wild-type*)
+         (coerce-to-values type2))
         ((or (eq type2 *wild-type*) (eq type2 *universal-type*))
-         (values type1 t))
+         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))))
+           (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-type-op type1 (coerce-to-values type2)
-                         #'type-intersection
-                         #'max))))
+         (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
@@ -660,9 +660,9 @@
         ((or (eq type1 *wild-type*) (eq type2 *wild-type*))
          (values t t))
        (t
-        (multiple-value-bind (res win) (values-type-intersection type1 type2)
+        (let ((res (values-type-intersection type1 type2)))
           (values (not (eq res *empty-type*))
-                  win)))))
+                  t)))))
 
 ;;; a SUBTYPEP-like operation that can be used on any types, including
 ;;; VALUES types
@@ -1503,11 +1503,15 @@
 
 (!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
-   (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))
@@ -2207,25 +2211,21 @@
                   (case eltype
                     (bit 'bit-vector)
                     (base-char 'base-string)
-                    (character 'string)
                     (* 'vector)
                     (t `(vector ,eltype)))
                   (case eltype
                     (bit `(bit-vector ,(car dims)))
                     (base-char `(base-string ,(car dims)))
-                    (character `(string ,(car dims)))
                     (t `(vector ,eltype ,(car dims)))))
               (if (eq (car dims) '*)
                   (case eltype
                     (bit 'simple-bit-vector)
                     (base-char 'simple-base-string)
-                    (character 'simple-string)
                     ((t) 'simple-vector)
                     (t `(simple-array ,eltype (*))))
                   (case eltype
                     (bit `(simple-bit-vector ,(car dims)))
                     (base-char `(simple-base-string ,(car dims)))
-                    (character `(simple-string ,(car dims)))
                     ((t) `(simple-vector ,(car dims)))
                     (t `(simple-array ,eltype ,dims))))))
          (t
@@ -2273,8 +2273,9 @@
                          (specialized-element-type-maybe type2))
                   t)))))
 
+;;; FIXME: is this dead?
 (!define-superclasses array
-  ((string string)
+  ((base-string base-string)
    (vector vector)
    (array))
   !cold-init-forms)
@@ -2628,6 +2629,8 @@
     ((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