0.7.4.29:

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

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index b287723..63cc7c6 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -68,7 +68,7 @@
 (defun !has-superclasses-complex-subtypep-arg1 (type1 type2 info)
   ;; If TYPE2 might be concealing something related to our class
   ;; hierarchy
-  (if (type-might-contain-other-types? type2)
+  (if (type-might-contain-other-types-p type2)
       ;; too confusing, gotta punt 
       (values nil nil)
       ;; ordinary case expected by old CMU CL code, where the taxonomy
@@ -756,7 +756,17 @@
     (let ((res (specifier-type spec)))
       (unless (unknown-type-p res)
        (setf (info :type :builtin spec) res)
-       (setf (info :type :kind spec) :primitive))))
+       ;; KLUDGE: the three copies of this idiom in this file (and
+       ;; the one in class.lisp as at sbcl-0.7.4.1x) should be
+       ;; coalesced, or perhaps the error-detecting code that
+       ;; disallows redefinition of :PRIMITIVE types should be
+       ;; rewritten to use *TYPE-SYSTEM-FINALIZED* (rather than
+       ;; *TYPE-SYSTEM-INITIALIZED*). The effect of this is not to
+       ;; cause redefinition errors when precompute-types is called
+       ;; for a second time while building the target compiler using
+       ;; the cross-compiler. -- CSR, trying to explain why this
+       ;; isn't completely wrong, 2002-06-07
+       (setf (info :type :kind spec) #+sb-xc-host :defined #-sb-xc-host :primitive))))
   (values))
 \f
 ;;;; general TYPE-UNION and TYPE-INTERSECTION operations
@@ -849,6 +859,16 @@
                #+sb-xc-host (coerce types 'list)
                #-sb-xc-host (coerce-to-list types)))))
 
+(defun maybe-distribute-one-union (union-type types)
+  (let* ((intersection (apply #'type-intersection types))
+        (union (mapcar (lambda (x) (type-intersection x intersection))
+                       (union-type-types union-type))))
+    (if (notany (lambda (x) (or (hairy-type-p x)
+                               (intersection-type-p x)))
+               union)
+       union
+       nil)))
+
 (defun type-intersection (&rest input-types)
   (let ((simplified-types (simplified-compound-types input-types
                                                     #'intersection-type-p
@@ -860,11 +880,17 @@
     ;; always achieve that by the distributive rule. But we don't want
     ;; to just apply the distributive rule, since it would be too easy
     ;; to end up with unreasonably huge type expressions. So instead
-    ;; we punt to HAIRY-TYPE when this comes up.
+    ;; 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))
-       (make-hairy-type
-        :specifier `(and ,@(map 'list #'type-specifier simplified-types)))
+       (let* ((first-union (find-if #'union-type-p simplified-types))
+              (other-types (coerce (remove first-union simplified-types) 'list))
+              (distributed (maybe-distribute-one-union first-union other-types)))
+         (if distributed
+             (apply #'type-union distributed)
+             (make-hairy-type
+              :specifier `(and ,@(map 'list #'type-specifier simplified-types)))))
        (make-compound-type-or-something #'%make-intersection-type
                                         simplified-types
                                         (some #'type-enumerable
@@ -892,7 +918,7 @@
  (macrolet ((frob (name var)
              `(progn
                 (setq ,var (make-named-type :name ',name))
-                (setf (info :type :kind ',name) :primitive)
+                (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
@@ -929,7 +955,7 @@
   (cond ((eq type1 *empty-type*)
         t)
        (;; When TYPE2 might be the universal type in disguise
-        (type-might-contain-other-types? type2)
+        (type-might-contain-other-types-p type2)
         ;; Now that the UNION and HAIRY COMPLEX-SUBTYPEP-ARG2 methods
         ;; can delegate to us (more or less as CALL-NEXT-METHOD) when
         ;; they're uncertain, we can't just barf on COMPOUND-TYPE and
@@ -1054,8 +1080,8 @@
                ;; changes in internal representation in the type
                ;; system could make it start confidently returning
                ;; incorrect results.) -- WHN 2002-03-08
-               (unless (or (type-might-contain-other-types? complement-type1)
-                           (type-might-contain-other-types? type2))
+               (unless (or (type-might-contain-other-types-p complement-type1)
+                           (type-might-contain-other-types-p type2))
                  ;; Because of the way our types which don't contain
                  ;; other types are disjoint subsets of the space of
                  ;; possible values, (SUBTYPEP '(NOT AA) 'B)=NIL when
@@ -1396,7 +1422,7 @@
                                       >= > t)))))))
 
 (!cold-init-forms
-  (setf (info :type :kind 'number) :primitive)
+  (setf (info :type :kind 'number) #+sb-xc-host :defined #-sb-xc-host :primitive)
   (setf (info :type :builtin 'number)
        (make-numeric-type :complexp nil)))
 
@@ -2150,6 +2176,7 @@
              (values nil certain?))))))
 
 (!define-type-method (union :complex-=) (type1 type2)
+  (declare (ignore type1))
   (if (some #'hairy-type-p (union-type-types type2))
       (values nil nil)
       (values nil t)))