X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=3f0a53d0151329ba2a004accab2aac98527dbde0;hb=e8f173ff44bc069db48585c8844f2d1097bb47d2;hp=4b9296549cc513e7f878453e6e7267289ce0e27f;hpb=722703e7cbd3a4b279a4c1baab5d95df2c23cce9;p=sbcl.git

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 4b92965..3f0a53d 100644
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -849,6 +849,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 +870,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
@@ -2150,6 +2166,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)))