X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=e9c4a67a205a4ca24f3c6eb8ad23b92f10662871;hb=6044a3ac0bcca2f650f76f665a0cf30b8d8e3beb;hp=576c7712e46fa7a098b84459e40b68c1dd3be1e9;hpb=c9e11f1e55e5e19f35c931af8180a2cd075ab5f5;p=sbcl.git

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 576c771..e9c4a67 100644
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -1503,7 +1503,7 @@
 	  t))
 
 (!define-type-method (member :complex-subtypep-arg1) (type1 type2)
-  (block PUNT
+  (block punt-type-method
     (values (every-type-op ctypep type2 (member-type-members type1)
 			   :list-first t)
 	    t)))
@@ -1530,13 +1530,13 @@
 	    t)))
 
 (!define-type-method (member :complex-intersection) (type1 type2)
-  (block PUNT
+  (block punt-type-method
     (collect ((members))
       (let ((mem2 (member-type-members type2)))
 	(dolist (member mem2)
 	  (multiple-value-bind (val win) (ctypep member type1)
 	    (unless win
-	      (return-from PUNT (values type2 nil)))
+	      (return-from punt-type-method (values type2 nil)))
 	    (when val (members member))))
 
 	(values (cond ((subsetp mem2 (members)) type2)
@@ -1575,6 +1575,42 @@
     (make-member-type :members (remove-duplicates members))
     *empty-type*))
 
+;;;; intersection types
+;;;;
+;;;; Until version 0.6.10.6, SBCL followed the original CMU CL approach
+;;;; of punting on all AND types, not just the unreasonably complicated
+;;;; ones. The change was motivated by trying to get the KEYWORD type
+;;;; to behave sensibly:
+;;;;    ;; reasonable definition
+;;;;    (DEFTYPE KEYWORD () '(AND SYMBOL (SATISFIES KEYWORDP)))
+;;;;    ;; reasonable behavior
+;;;;    (ASSERT (SUBTYPEP 'KEYWORD 'SYMBOL))
+;;;; Without understanding a little about the semantics of AND, we'd
+;;;; get (SUBTYPEP 'KEYWORD 'SYMBOL)=>NIL,NIL, which is unreasonable.)
+;;;;
+;;;; We still follow the example of CMU CL to some extent, by punting
+;;;; (to the opaque HAIRY-TYPE) on sufficiently complicated types
+;;;; involving AND.
+
+;;; Make a union type from the specifier types; or punt (to opaque
+;;; HAIRY-TYPE) if the class looks as though it might get too hairy. 
+(defun make-intersection-type (types)
+  (declare (list types))
+  ;; "If potentially too hairy.."
+  ;;
+  ;; (CMU CL punted for all AND-based types, and we'd like to avoid
+  ;; any really unreasonable cases which might have motivated them to
+  ;; do this, while still being reasonably effective on simple
+  ;; intersection types like KEYWORD.)
+  (if (any (lambda (type)
+	     (or (union-type-p type)
+		 (hairy-type-p type)))
+	   types)
+      (make-hairy-type :specifier (mapcar #'type-specifier types))
+      (%make-intersection-type (some #'type-enumerable types) types)))
+
+(!define-type-class intersection)
+
 ;;;; union types
 
 ;;; Make a union type from the specifier types, setting ENUMERABLE in
@@ -1595,7 +1631,7 @@
 ;;; Two union types are equal if every type in one is equal to some
 ;;; type in the other.
 (!define-type-method (union :simple-=) (type1 type2)
-  (block PUNT
+  (block punt-type-method
     (let ((types1 (union-type-types type1))
 	  (types2 (union-type-types type2)))
       (values (and (dolist (type1 types1 t)
@@ -1609,7 +1645,7 @@
 ;;; Similarly, a union type is a subtype of another if every element
 ;;; of TYPE1 is a subtype of some element of TYPE2.
 (!define-type-method (union :simple-subtypep) (type1 type2)
-  (block PUNT
+  (block punt-type-method
     (let ((types2 (union-type-types type2)))
       (values (dolist (type1 (union-type-types type1) t)
 		(unless (any-type-op csubtypep type1 types2)
@@ -1617,13 +1653,13 @@
 	      t))))
 
 (!define-type-method (union :complex-subtypep-arg1) (type1 type2)
-  (block PUNT
+  (block punt-type-method
     (values (every-type-op csubtypep type2 (union-type-types type1)
 			   :list-first t)
 	    t)))
 
 (!define-type-method (union :complex-subtypep-arg2) (type1 type2)
-  (block PUNT
+  (block punt-type-method
     (values (any-type-op csubtypep type1 (union-type-types type2)) t)))
 
 (!define-type-method (union :complex-union) (type1 type2)