X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Flate-type.lisp;h=63431b9f85aad4fc6d7bda8e1eb0e0a8e1a1f8ee;hb=d720bc359f03734ccb9baf66cb45dc01d623f369;hp=34b5f0d9f435372216dc1b22ceee9369d5f2c724;hpb=dbe82b489260b2ef76e916d0aeaee8b3850f5f52;p=sbcl.git

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 34b5f0d..63431b9 100644
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -432,8 +432,9 @@
       1
       (values-type-max-value-count type)))
 
+;;; VALUES type with a single value.
 (defun type-single-value-p (type)
-  (and (values-type-p type)
+  (and (%values-type-p type)
        (not (values-type-rest type))
        (null (values-type-optional type))
        (singleton-p (values-type-required type))))
@@ -1731,7 +1732,7 @@
              (eql low high)
              (eql (numeric-type-complexp type) :real)
              (member (numeric-type-class type) '(integer rational
-                                                 #!-sb-xc-host float)))
+                                                 #-sb-xc-host float)))
         (values t (numeric-type-low type))
         (values nil nil))))
 
@@ -2403,14 +2404,8 @@ used for a COMPLEX component.~:@>"
          (values nil t))
         ((or (unknown-type-p (array-type-element-type type1))
              (unknown-type-p (array-type-element-type type2)))
-         (multiple-value-bind (equalp certainp)
-             (type= (array-type-element-type type1)
-                    (array-type-element-type type2))
-           ;; By its nature, the call to TYPE= should never return
-           ;; NIL, T, as we don't know what the UNKNOWN-TYPE will grow
-           ;; up to be.  -- CSR, 2002-08-19
-           (aver (not (and (not equalp) certainp)))
-           (values equalp certainp)))
+         (type= (array-type-element-type type1)
+                (array-type-element-type type2)))
         (t
          (values (type= (array-type-specialized-element-type type1)
                         (array-type-specialized-element-type type2))
@@ -2909,11 +2904,12 @@ used for a COMPLEX component.~:@>"
                           :high (if (null (numeric-type-high type1))
                                     nil
                                     (list (1+ (numeric-type-high type1)))))))
-         (type-union type1
-                     (apply #'type-intersection
-                            (remove (specifier-type '(not integer))
-                                    (intersection-type-types type2)
-                                    :test #'type=))))
+         (let* ((intersected (intersection-type-types type2))
+                (remaining   (remove (specifier-type '(not integer))
+                                     intersected
+                                     :test #'type=)))
+           (and (not (equal intersected remaining))
+                (type-union type1 (apply #'type-intersection remaining)))))
         (t
          (let ((accumulator *universal-type*))
            (do ((t2s (intersection-type-types type2) (cdr t2s)))
@@ -3301,10 +3297,20 @@ used for a COMPLEX component.~:@>"
     ((type= type (specifier-type 'base-char)) 'base-char)
     ((type= type (specifier-type 'extended-char)) 'extended-char)
     ((type= type (specifier-type 'standard-char)) 'standard-char)
-    (t (let ((pairs (character-set-type-pairs type)))
-        `(member ,@(loop for (low . high) in pairs
+    (t
+     ;; Unparse into either MEMBER or CHARACTER-SET. We use MEMBER if there
+     ;; are at most as many characters than there are character code ranges.
+     (let* ((pairs (character-set-type-pairs type))
+            (count (length pairs))
+            (chars (loop named outer
+                         for (low . high) in pairs
                          nconc (loop for code from low upto high
-                                     collect (sb!xc:code-char code))))))))
+                                     collect (sb!xc:code-char code)
+                                     when (minusp (decf count))
+                                     do (return-from outer t)))))
+       (if (eq chars t)
+           `(character-set ,pairs)
+           `(member ,@chars))))))
 
 (!define-type-method (character-set :singleton-p) (type)
   (let* ((pairs (character-set-type-pairs type))