+(!define-type-class union)
+
+;;; The LIST, FLOAT and REAL types have special names. Other union
+;;; types just get mechanically unparsed.
+(!define-type-method (union :unparse) (type)
+ (declare (type ctype type))
+ (cond
+ ((type= type (specifier-type 'list)) 'list)
+ ((type= type (specifier-type 'float)) 'float)
+ ((type= type (specifier-type 'real)) 'real)
+ ((type= type (specifier-type 'sequence)) 'sequence)
+ ((type= type (specifier-type 'bignum)) 'bignum)
+ (t `(or ,@(mapcar #'type-specifier (union-type-types type))))))
+
+;;; Two union types are equal if they are each subtypes of each
+;;; other. We need to be this clever because our complex subtypep
+;;; methods are now more accurate; we don't get infinite recursion
+;;; because the simple-subtypep method delegates to complex-subtypep
+;;; of the individual types of type1. - CSR, 2002-04-09
+;;;
+;;; Previous comment, now obsolete, but worth keeping around because
+;;; it is true, though too strong a condition:
+;;;
+;;; Two union types are equal if their subtypes are equal sets.
+(!define-type-method (union :simple-=) (type1 type2)
+ (multiple-value-bind (subtype certain?)
+ (csubtypep type1 type2)
+ (if subtype
+ (csubtypep type2 type1)
+ ;; we might as well become as certain as possible.
+ (if certain?
+ (values nil t)
+ (multiple-value-bind (subtype certain?)
+ (csubtypep type2 type1)
+ (declare (ignore subtype))
+ (values nil certain?))))))
+
+(!define-type-method (union :complex-=) (type1 type2)
+ (declare (ignore type1))
+ (if (some #'type-might-contain-other-types-p
+ (union-type-types type2))
+ (values nil nil)
+ (values nil t)))
+
+;;; Similarly, a union type is a subtype of another if and only if
+;;; every element of TYPE1 is a subtype of TYPE2.
+(defun union-simple-subtypep (type1 type2)
+ (every/type (swapped-args-fun #'union-complex-subtypep-arg2)
+ type2
+ (union-type-types type1)))
+
+(!define-type-method (union :simple-subtypep) (type1 type2)
+ (union-simple-subtypep type1 type2))
+
+(defun union-complex-subtypep-arg1 (type1 type2)
+ (every/type (swapped-args-fun #'csubtypep)
+ type2
+ (union-type-types type1)))
+
+(!define-type-method (union :complex-subtypep-arg1) (type1 type2)
+ (union-complex-subtypep-arg1 type1 type2))
+
+(defun union-complex-subtypep-arg2 (type1 type2)
+ (multiple-value-bind (sub-value sub-certain?)
+ ;; was: (any/type #'csubtypep type1 (union-type-types type2)),
+ ;; which turns out to be too restrictive, causing bug 91.
+ ;;
+ ;; the following reimplementation might look dodgy. It is
+ ;; dodgy. It depends on the union :complex-= method not doing
+ ;; very much work -- certainly, not using subtypep. Reasoning:
+ (progn
+ ;; At this stage, we know that type2 is a union type and type1
+ ;; isn't. We might as well check this, though:
+ (aver (union-type-p type2))
+ (aver (not (union-type-p type1)))
+ ;; A is a subset of (B1 u B2)
+ ;; <=> A n (B1 u B2) = A
+ ;; <=> (A n B1) u (A n B2) = A
+ ;;
+ ;; But, we have to be careful not to delegate this type= to
+ ;; something that could invoke subtypep, which might get us
+ ;; back here -> stack explosion. We therefore ensure that the
+ ;; second type (which is the one that's dispatched on) is
+ ;; either a union type (where we've ensured that the complex-=
+ ;; method will not call subtypep) or something with no union
+ ;; types involved, in which case we'll never come back here.
+ ;;
+ ;; If we don't do this, then e.g.
+ ;; (SUBTYPEP '(MEMBER 3) '(OR (SATISFIES FOO) (SATISFIES BAR)))
+ ;; would loop infinitely, as the member :complex-= method is
+ ;; implemented in terms of subtypep.
+ ;;
+ ;; Ouch. - CSR, 2002-04-10
+ (type= type1
+ (apply #'type-union
+ (mapcar (lambda (x) (type-intersection type1 x))
+ (union-type-types type2)))))
+ (if sub-certain?
+ (values sub-value sub-certain?)
+ ;; The ANY/TYPE expression above is a sufficient condition for
+ ;; subsetness, but not a necessary one, so we might get a more
+ ;; certain answer by this CALL-NEXT-METHOD-ish step when the
+ ;; ANY/TYPE expression is uncertain.
+ (invoke-complex-subtypep-arg1-method type1 type2))))
+
+(!define-type-method (union :complex-subtypep-arg2) (type1 type2)
+ (union-complex-subtypep-arg2 type1 type2))
+
+(!define-type-method (union :simple-intersection2 :complex-intersection2)
+ (type1 type2)
+ ;; The CSUBTYPEP clauses here let us simplify e.g.
+ ;; (TYPE-INTERSECTION2 (SPECIFIER-TYPE 'LIST)
+ ;; (SPECIFIER-TYPE '(OR LIST VECTOR)))
+ ;; (where LIST is (OR CONS NULL)).
+ ;;
+ ;; The tests are more or less (CSUBTYPEP TYPE1 TYPE2) and vice
+ ;; versa, but it's important that we pre-expand them into
+ ;; specialized operations on individual elements of
+ ;; UNION-TYPE-TYPES, instead of using the ordinary call to
+ ;; CSUBTYPEP, in order to avoid possibly invoking any methods which
+ ;; might in turn invoke (TYPE-INTERSECTION2 TYPE1 TYPE2) and thus
+ ;; cause infinite recursion.
+ ;;
+ ;; Within this method, type2 is guaranteed to be a union type:
+ (aver (union-type-p type2))
+ ;; Make sure to call only the applicable methods...
+ (cond ((and (union-type-p type1)
+ (union-simple-subtypep type1 type2)) type1)
+ ((and (union-type-p type1)
+ (union-simple-subtypep type2 type1)) type2)
+ ((and (not (union-type-p type1))
+ (union-complex-subtypep-arg2 type1 type2))
+ type1)
+ ((and (not (union-type-p type1))
+ (union-complex-subtypep-arg1 type2 type1))
+ type2)
+ (t
+ ;; KLUDGE: This code accumulates a sequence of TYPE-UNION2
+ ;; operations in a particular order, and gives up if any of
+ ;; the sub-unions turn out not to be simple. In other cases
+ ;; ca. sbcl-0.6.11.15, that approach to taking a union was a
+ ;; bad idea, since it can overlook simplifications which
+ ;; might occur if the terms were accumulated in a different
+ ;; order. It's possible that that will be a problem here too.
+ ;; However, I can't think of a good example to demonstrate
+ ;; it, and without an example to demonstrate it I can't write
+ ;; test cases, and without test cases I don't want to
+ ;; complicate the code to address what's still a hypothetical
+ ;; problem. So I punted. -- WHN 2001-03-20
+ (let ((accumulator *empty-type*))
+ (dolist (t2 (union-type-types type2) accumulator)
+ (setf accumulator
+ (type-union accumulator
+ (type-intersection type1 t2))))))))
+
+(!def-type-translator or (&rest type-specifiers)
+ (apply #'type-union
+ (mapcar #'specifier-type
+ type-specifiers)))
+\f
+;;;; CONS types
+
+(!define-type-class cons)
+
+(!def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*))
+ (let ((car-type (specifier-type car-type-spec))
+ (cdr-type (specifier-type cdr-type-spec)))
+ (make-cons-type car-type cdr-type)))
+
+(!define-type-method (cons :unparse) (type)
+ (let ((car-eltype (type-specifier (cons-type-car-type type)))
+ (cdr-eltype (type-specifier (cons-type-cdr-type type))))
+ (if (and (member car-eltype '(t *))
+ (member cdr-eltype '(t *)))
+ 'cons
+ `(cons ,car-eltype ,cdr-eltype))))
+
+(!define-type-method (cons :simple-=) (type1 type2)
+ (declare (type cons-type type1 type2))
+ (and (type= (cons-type-car-type type1) (cons-type-car-type type2))
+ (type= (cons-type-cdr-type type1) (cons-type-cdr-type type2))))
+
+(!define-type-method (cons :simple-subtypep) (type1 type2)
+ (declare (type cons-type type1 type2))
+ (multiple-value-bind (val-car win-car)
+ (csubtypep (cons-type-car-type type1) (cons-type-car-type type2))
+ (multiple-value-bind (val-cdr win-cdr)
+ (csubtypep (cons-type-cdr-type type1) (cons-type-cdr-type type2))
+ (if (and val-car val-cdr)
+ (values t (and win-car win-cdr))
+ (values nil (or win-car win-cdr))))))
+
+;;; Give up if a precise type is not possible, to avoid returning
+;;; overly general types.
+(!define-type-method (cons :simple-union2) (type1 type2)
+ (declare (type cons-type type1 type2))
+ (let ((car-type1 (cons-type-car-type type1))
+ (car-type2 (cons-type-car-type type2))
+ (cdr-type1 (cons-type-cdr-type type1))
+ (cdr-type2 (cons-type-cdr-type type2)))
+ ;; UGH. -- CSR, 2003-02-24
+ (macrolet ((frob-car (car1 car2 cdr1 cdr2)
+ `(type-union
+ (make-cons-type ,car1 (type-union ,cdr1 ,cdr2))
+ (make-cons-type
+ (type-intersection ,car2
+ (specifier-type
+ `(not ,(type-specifier ,car1))))
+ ,cdr2))))
+ (cond ((type= car-type1 car-type2)
+ (make-cons-type car-type1
+ (type-union cdr-type1 cdr-type2)))
+ ((type= cdr-type1 cdr-type2)
+ (make-cons-type (type-union car-type1 car-type2)
+ cdr-type1))
+ ((csubtypep car-type1 car-type2)
+ (frob-car car-type1 car-type2 cdr-type1 cdr-type2))
+ ((csubtypep car-type2 car-type1)
+ (frob-car car-type2 car-type1 cdr-type2 cdr-type1))
+ ;; Don't put these in -- consider the effect of taking the
+ ;; union of (CONS (INTEGER 0 2) (INTEGER 5 7)) and
+ ;; (CONS (INTEGER 0 3) (INTEGER 5 6)).
+ #+nil
+ ((csubtypep cdr-type1 cdr-type2)
+ (frob-cdr car-type1 car-type2 cdr-type1 cdr-type2))
+ #+nil
+ ((csubtypep cdr-type2 cdr-type1)
+ (frob-cdr car-type2 car-type1 cdr-type2 cdr-type1))))))
+
+(!define-type-method (cons :simple-intersection2) (type1 type2)
+ (declare (type cons-type type1 type2))
+ (let (car-int2
+ cdr-int2)
+ (and (setf car-int2 (type-intersection2 (cons-type-car-type type1)
+ (cons-type-car-type type2)))
+ (setf cdr-int2 (type-intersection2 (cons-type-cdr-type type1)
+ (cons-type-cdr-type type2)))
+ (make-cons-type car-int2 cdr-int2))))