0.8.1.34:

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

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index d0a2938..e0b7317 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -182,20 +182,7 @@
        (return (values nil t))))))
 
 (!define-type-method (values :simple-=) (type1 type2)
-  (let ((rest1 (args-type-rest type1))
-       (rest2 (args-type-rest type2)))
-    (cond ((and rest1 rest2 (type/= rest1 rest2))
-          (type= rest1 rest2))
-         ((or rest1 rest2)
-          (values nil t))
-         (t
-          (multiple-value-bind (req-val req-win)
-              (type=-list (values-type-required type1)
-                          (values-type-required type2))
-            (multiple-value-bind (opt-val opt-win)
-                (type=-list (values-type-optional type1)
-                            (values-type-optional type2))
-              (values (and req-val opt-val) (and req-win opt-win))))))))
+  (type=-args type1 type2))
 
 (!define-type-class function)
 
@@ -327,32 +314,7 @@
                      (values nil t))
                     ((eq (fun-type-wild-args type1) t)
                      (values t t))
-                    (t (and/type
-                        (cond ((null (fun-type-rest type1))
-                               (values (null (fun-type-rest type2)) t))
-                              ((null (fun-type-rest type2))
-                               (values nil t))
-                              (t
-                               (compare type= rest)))
-                        (labels ((type-list-= (l1 l2)
-                                   (cond ((null l1)
-                                          (values (null l2) t))
-                                         ((null l2)
-                                          (values nil t))
-                                         (t (multiple-value-bind (res winp)
-                                                (type= (first l1) (first l2))
-                                              (cond ((not winp)
-                                                     (values nil nil))
-                                                    ((not res)
-                                                     (values nil t))
-                                                    (t
-                                                     (type-list-= (rest l1)
-                                                                  (rest l2)))))))))
-                          (and/type (and/type (compare type-list-= required)
-                                              (compare type-list-= optional))
-                              (if (or (fun-type-keyp type1) (fun-type-keyp type2))
-                                  (values nil nil)
-                                  (values t t))))))))))
+                    (t (type=-args type1 type2))))))
 
 (!define-type-class constant :inherits values)
 
@@ -627,6 +589,23 @@
                               :rest rest)
             exactp)))
 
+(defun type=-args (type1 type2)
+  (macrolet ((compare (comparator field)
+               (let ((reader (symbolicate '#:args-type- field)))
+                 `(,comparator (,reader type1) (,reader type2)))))
+    (and/type
+     (cond ((null (args-type-rest type1))
+            (values (null (args-type-rest type2)) t))
+           ((null (args-type-rest type2))
+            (values nil t))
+           (t
+            (compare type= rest)))
+     (and/type (and/type (compare type=-list required)
+                         (compare type=-list optional))
+               (if (or (args-type-keyp type1) (args-type-keyp type2))
+                   (values nil nil)
+                   (values t t))))))
+
 ;;; Do a union or intersection operation on types that might be values
 ;;; types. The result is optimized for utility rather than exactness,
 ;;; but it is guaranteed that it will be no smaller (more restrictive)
@@ -1204,7 +1183,12 @@
   (values nil nil))
 
 (!define-type-method (hairy :complex-=) (type1 type2)
-  (if (unknown-type-p type2)
+  (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)
@@ -2223,25 +2207,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
@@ -2289,8 +2269,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)
@@ -2644,6 +2625,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