+;;;; 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 and, for entirely
+;;;; parallel reasons, (SUBTYPEP 'RATIO 'NUMBER)=>NIL,NIL. That's
+;;;; not so good..)
+;;;;
+;;;; We still follow the example of CMU CL to some extent, by punting
+;;;; (to the opaque HAIRY-TYPE) on sufficiently complicated types
+;;;; involving AND.
+
+;;; In general, make an INTERSECTION-TYPE object from the specifier
+;;; types. But in various special cases, dodge instead, representing
+;;; the intersection type in some other way.
+(defun make-intersection-type-or-something (types)
+ (declare (list types))
+ (/show0 "entering MAKE-INTERSECTION-TYPE-OR-SOMETHING")
+ (cond ((null types)
+ *universal-type*)
+ ((null (cdr types))
+ (first types))
+ (;; if potentially too hairy
+ (some (lambda (type)
+ (or (union-type-p type)
+ (hairy-type-p type)))
+ types)
+ ;; (CMU CL punted to HAIRY-TYPE like this for all AND-based
+ ;; types. We don't want to do that for simple intersection
+ ;; types like the definition of KEYWORD, hence the guard
+ ;; clause above. But we do want to punt for any really
+ ;; unreasonable cases which might have motivated them to punt
+ ;; in all cases, hence the punt-to-HAIRY-TYPE code below.)
+ (make-hairy-type :specifier `(and ,@(mapcar #'type-specifier types))))
+ (t
+ (%make-intersection-type (some #'type-enumerable types) types))))
+
+(!define-type-class intersection)
+
+;;; A few intersection types have special names. The others just get
+;;; mechanically unparsed.
+(!define-type-method (intersection :unparse) (type)
+ (declare (type ctype type))
+ (/show0 "entering INTERSECTION :UNPARSE")
+ (or (find type '(ratio bignum keyword) :key #'specifier-type :test #'type=)
+ `(and ,@(mapcar #'type-specifier (intersection-type-types type)))))
+
+;;; shared machinery for type equality: true if every type in the set
+;;; TYPES1 matches a type in the set TYPES2 and vice versa
+(defun type=-set (types1 types2)
+ (/show0 "entering TYPE=-SET")
+ (flet (;; true if every type in the set X matches a type in the set Y
+ (type<=-set (x y)
+ (declare (type list x y))
+ (every (lambda (xelement)
+ (position xelement y :test #'type=))
+ x)))
+ (values (and (type<=-set types1 types2)
+ (type<=-set types2 types1))
+ t)))
+
+;;; Two intersection types are equal if their subtypes are equal sets.
+;;;
+;;; FIXME: Might it be better to use
+;;; (AND (SUBTYPEP X Y) (SUBTYPEP Y X))
+;;; instead, since SUBTYPEP is the usual relationship that we care
+;;; most about, so it would be good to leverage any ingenuity there
+;;; in this more obscure method?
+(!define-type-method (intersection :simple-=) (type1 type2)
+ (/show0 "entering INTERSECTION :SIMPLE-=")
+ (type=-set (intersection-type-types type1)
+ (intersection-type-types type2)))
+
+(!define-type-method (intersection :simple-subtypep) (type1 type2)
+ (declare (type list type1 type2))
+ (/show0 "entering INTERSECTION :SIMPLE-SUBTYPEP")
+ (let ((certain? t))
+ (dolist (t1 (intersection-type-types type1) (values nil certain?))
+ (multiple-value-bind (subtypep validp)
+ (intersection-complex-subtypep-arg2 t1 type2)
+ (cond ((not validp)
+ (setf certain? nil))
+ (subtypep
+ (return (values t t))))))))
+
+(!define-type-method (intersection :complex-subtypep-arg1) (type1 type2)
+ (/show0 "entering INTERSECTION :COMPLEX-SUBTYPEP-ARG1")
+ (any/type (swapped-args-fun #'csubtypep)
+ type2
+ (intersection-type-types type1)))
+
+(defun intersection-complex-subtypep-arg2 (type1 type2)
+ (every/type #'csubtypep type1 (intersection-type-types type2)))
+(!define-type-method (intersection :complex-subtypep-arg2) (type1 type2)
+ (/show0 "entering INTERSECTION :COMPLEX-SUBTYPEP-ARG2")
+ (intersection-complex-subtypep-arg2 type1 type2))
+
+;;; shared logic for unions and intersections: Return a new type list
+;;; where pairs of types which can be simplified by SIMPLIFY2-FUN have
+;;; been replaced by their simplified forms.
+(defun simplify-types (types simplify2-fun)
+ (declare (type function simplify2-fun))
+ (let (;; our result, accumulated as a vector
+ (a (make-array (length types) :fill-pointer 0)))
+ (dolist (%type types (coerce a 'list))
+ ;; Merge TYPE into RESULT.
+ (named-let again ((type %type))
+ (dotimes (i (length a) (vector-push-extend type a))
+ (let ((ai (aref a i)))
+ (multiple-value-bind (simplified win?)
+ (funcall simplify2-fun type ai)
+ (when win?
+ (setf (aref a i) (vector-pop a))
+ ;; Give the new SIMPLIFIED its own chance to be
+ ;; pairwise simplified w.r.t. elements of A.
+ (return (again simplified))))))))))
+
+;;; FIXME: See FIXME note for DEFUN SIMPLIFY2-UNION.
+(defun simplify2-intersection (x y)
+ (let ((intersection (type-intersection x y)))
+ (if (and (or (intersection-type-p intersection)
+ (hairy-type-p intersection))
+ (not (intersection-type-p x))
+ (not (intersection-type-p y)))
+ (values nil nil)
+ (values intersection t))))
+
+(!define-type-method (intersection :simple-intersection :complex-intersection)
+ (type1 type2)
+ (/show0 "entering INTERSECTION :SIMPLE-INTERSECTION :COMPLEX-INTERSECTION")
+ (let ((type1types (intersection-type-types type1))
+ (type2types (if (intersection-type-p type2)
+ (intersection-type-types type2)
+ (list type2))))
+ (make-intersection-type-or-something
+ (simplify-intersection-type-types
+ (append type1types type2types)))))
+
+#|
+(!def-type-translator and (&rest type-specifiers)
+ ;; Note: Between the behavior of SIMPLIFY-INTERSECTION-TYPE (which
+ ;; will reduce to a 1-element list any list of types which CMU CL
+ ;; could've represented) and MAKE-INTERSECTION-TYPE-OR-SOMETHING
+ ;; (which knows to treat a 1-element intersection as the element
+ ;; itself) we should recover CMU CL's behavior for anything which it
+ ;; could handle usefully (i.e. could without punting to HAIRY-TYPE).
+ (/show0 "entering type translator for AND")
+ (make-intersection-type-or-something
+ (simplify-types (mapcar #'specifier-type type-specifiers)
+ #'simplify2-intersection)))
+|#
+;;; (REMOVEME once INTERSECTION-TYPE works.)
+(!def-type-translator and (&whole spec &rest types)
+ (let ((res *wild-type*))
+ (dolist (type types res)
+ (let ((ctype (specifier-type type)))
+ (multiple-value-bind (int win) (type-intersection res ctype)
+ (unless win
+ (return (make-hairy-type :specifier spec)))
+ (setq res int))))))
+\f