+ (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)
+ ((type= type (specifier-type 'simple-string)) 'simple-string)
+ ((type= type (specifier-type 'string)) 'string)
+ ((type= type (specifier-type 'complex)) 'complex)
+ ((type= type (specifier-type 'standard-char)) 'standard-char)
+ (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)
+ ;; 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)))
+ ;; 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:
+ ;;
+ ;; 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
+ (multiple-value-bind (sub-value sub-certain?)
+ (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 (single-value-specifier-type car-type-spec))
+ (cdr-type (single-value-specifier-type cdr-type-spec)))
+ (make-cons-type car-type cdr-type)))
+
+(!define-type-method (cons :negate) (type)
+ (if (and (eq (cons-type-car-type type) *universal-type*)
+ (eq (cons-type-cdr-type type) *universal-type*))
+ (make-negation-type :type type)
+ (type-union
+ (make-negation-type :type (specifier-type 'cons))
+ (cond
+ ((and (not (eq (cons-type-car-type type) *universal-type*))
+ (not (eq (cons-type-cdr-type type) *universal-type*)))
+ (type-union
+ (make-cons-type
+ (type-negation (cons-type-car-type type))
+ *universal-type*)
+ (make-cons-type
+ *universal-type*
+ (type-negation (cons-type-cdr-type type)))))
+ ((not (eq (cons-type-car-type type) *universal-type*))
+ (make-cons-type
+ (type-negation (cons-type-car-type type))
+ *universal-type*))
+ ((not (eq (cons-type-cdr-type type) *universal-type*))
+ (make-cons-type
+ *universal-type*
+ (type-negation (cons-type-cdr-type type))))
+ (t (bug "Weird CONS type ~S" 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))
+ (multiple-value-bind (car-match car-win)
+ (type= (cons-type-car-type type1) (cons-type-car-type type2))
+ (multiple-value-bind (cdr-match cdr-win)
+ (type= (cons-type-cdr-type type1) (cons-type-cdr-type type2))
+ (cond ((and car-match cdr-match)
+ (aver (and car-win cdr-win))
+ (values t t))
+ (t
+ (values nil
+ ;; FIXME: Ideally we would like to detect and handle
+ ;; (CONS UNKNOWN INTEGER) (CONS UNKNOWN SYMBOL) => NIL, T
+ ;; but just returning a secondary true on (and car-win cdr-win)
+ ;; unfortunately breaks other things. --NS 2006-08-16
+ (and (or (and (not car-match) car-win)
+ (and (not cdr-match) cdr-win))
+ (not (and (cons-type-might-be-empty-type type1)
+ (cons-type-might-be-empty-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 (and (not val-car) win-car)
+ (and (not val-cdr) 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))
+ car-not1
+ car-not2)
+ ;; UGH. -- CSR, 2003-02-24
+ (macrolet ((frob-car (car1 car2 cdr1 cdr2
+ &optional (not1 nil not1p))
+ `(type-union
+ (make-cons-type ,car1 (type-union ,cdr1 ,cdr2))
+ (make-cons-type
+ (type-intersection ,car2
+ ,(if not1p
+ not1
+ `(type-negation ,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))
+ ;; more general case of the above, but harder to compute
+ ((progn
+ (setf car-not1 (type-negation car-type1))
+ (multiple-value-bind (yes win)
+ (csubtypep car-type2 car-not1)
+ (and (not yes) win)))
+ (frob-car car-type1 car-type2 cdr-type1 cdr-type2 car-not1))
+ ((progn
+ (setf car-not2 (type-negation car-type2))
+ (multiple-value-bind (yes win)
+ (csubtypep car-type1 car-not2)
+ (and (not yes) win)))
+ (frob-car car-type2 car-type1 cdr-type2 cdr-type1 car-not2))
+ ;; 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 (type-intersection2 (cons-type-car-type type1)
+ (cons-type-car-type type2)))
+ (cdr-int2 (type-intersection2 (cons-type-cdr-type type1)
+ (cons-type-cdr-type type2))))
+ (cond
+ ((and car-int2 cdr-int2) (make-cons-type car-int2 cdr-int2))
+ (car-int2 (make-cons-type car-int2
+ (type-intersection
+ (cons-type-cdr-type type1)
+ (cons-type-cdr-type type2))))
+ (cdr-int2 (make-cons-type
+ (type-intersection (cons-type-car-type type1)
+ (cons-type-car-type type2))
+ cdr-int2)))))
+
+(!define-superclasses cons ((cons)) !cold-init-forms)
+\f
+;;;; CHARACTER-SET types
+
+(!define-type-class character-set)
+
+(!def-type-translator character-set
+ (&optional (pairs '((0 . #.(1- sb!xc:char-code-limit)))))
+ (make-character-set-type :pairs pairs))
+
+(!define-type-method (character-set :negate) (type)
+ (let ((pairs (character-set-type-pairs type)))
+ (if (and (= (length pairs) 1)
+ (= (caar pairs) 0)
+ (= (cdar pairs) (1- sb!xc:char-code-limit)))
+ (make-negation-type :type type)
+ (let ((not-character
+ (make-negation-type
+ :type (make-character-set-type
+ :pairs '((0 . #.(1- sb!xc:char-code-limit)))))))
+ (type-union
+ not-character
+ (make-character-set-type
+ :pairs (let (not-pairs)
+ (when (> (caar pairs) 0)
+ (push (cons 0 (1- (caar pairs))) not-pairs))
+ (do* ((tail pairs (cdr tail))
+ (high1 (cdar tail) (cdar tail))
+ (low2 (caadr tail) (caadr tail)))
+ ((null (cdr tail))
+ (when (< (cdar tail) (1- sb!xc:char-code-limit))
+ (push (cons (1+ (cdar tail))
+ (1- sb!xc:char-code-limit))
+ not-pairs))
+ (nreverse not-pairs))
+ (push (cons (1+ high1) (1- low2)) not-pairs)))))))))
+
+(!define-type-method (character-set :unparse) (type)
+ (cond
+ ((type= type (specifier-type 'character)) 'character)
+ ((type= type (specifier-type 'base-char)) 'base-char)
+ ((type= type (specifier-type 'extended-char)) 'extended-char)
+ ((type= type (specifier-type 'standard-char)) 'standard-char)
+ (t (let ((pairs (character-set-type-pairs type)))
+ `(member ,@(loop for (low . high) in pairs
+ nconc (loop for code from low upto high
+ collect (sb!xc:code-char code))))))))
+
+(!define-type-method (character-set :simple-=) (type1 type2)
+ (let ((pairs1 (character-set-type-pairs type1))
+ (pairs2 (character-set-type-pairs type2)))
+ (values (equal pairs1 pairs2) t)))
+
+(!define-type-method (character-set :simple-subtypep) (type1 type2)
+ (values
+ (dolist (pair (character-set-type-pairs type1) t)
+ (unless (position pair (character-set-type-pairs type2)
+ :test (lambda (x y) (and (>= (car x) (car y))
+ (<= (cdr x) (cdr y)))))
+ (return nil)))
+ t))
+
+(!define-type-method (character-set :simple-union2) (type1 type2)
+ ;; KLUDGE: the canonizing in the MAKE-CHARACTER-SET-TYPE function
+ ;; actually does the union for us. It might be a little fragile to
+ ;; rely on it.
+ (make-character-set-type
+ :pairs (merge 'list
+ (copy-alist (character-set-type-pairs type1))
+ (copy-alist (character-set-type-pairs type2))
+ #'< :key #'car)))
+
+(!define-type-method (character-set :simple-intersection2) (type1 type2)
+ ;; KLUDGE: brute force.
+#|
+ (let (pairs)
+ (dolist (pair1 (character-set-type-pairs type1)
+ (make-character-set-type
+ :pairs (sort pairs #'< :key #'car)))
+ (dolist (pair2 (character-set-type-pairs type2))
+ (cond
+ ((<= (car pair1) (car pair2) (cdr pair1))
+ (push (cons (car pair2) (min (cdr pair1) (cdr pair2))) pairs))
+ ((<= (car pair2) (car pair1) (cdr pair2))
+ (push (cons (car pair1) (min (cdr pair1) (cdr pair2))) pairs))))))
+|#
+ (make-character-set-type
+ :pairs (intersect-type-pairs
+ (character-set-type-pairs type1)
+ (character-set-type-pairs type2))))
+
+;;;
+;;; Intersect two ordered lists of pairs
+;;; Each list is of the form ((start1 . end1) ... (startn . endn)),
+;;; where start1 <= end1 < start2 <= end2 < ... < startn <= endn.
+;;; Each pair represents the integer interval start..end.
+;;;
+(defun intersect-type-pairs (alist1 alist2)
+ (if (and alist1 alist2)
+ (let ((res nil)
+ (pair1 (pop alist1))
+ (pair2 (pop alist2)))
+ (loop
+ (when (> (car pair1) (car pair2))
+ (rotatef pair1 pair2)
+ (rotatef alist1 alist2))
+ (let ((pair1-cdr (cdr pair1)))
+ (cond
+ ((> (car pair2) pair1-cdr)
+ ;; No over lap -- discard pair1
+ (unless alist1 (return))
+ (setq pair1 (pop alist1)))
+ ((<= (cdr pair2) pair1-cdr)
+ (push (cons (car pair2) (cdr pair2)) res)
+ (cond
+ ((= (cdr pair2) pair1-cdr)
+ (unless alist1 (return))
+ (unless alist2 (return))
+ (setq pair1 (pop alist1)
+ pair2 (pop alist2)))
+ (t ;; (< (cdr pair2) pair1-cdr)
+ (unless alist2 (return))
+ (setq pair1 (cons (1+ (cdr pair2)) pair1-cdr))
+ (setq pair2 (pop alist2)))))
+ (t ;; (> (cdr pair2) (cdr pair1))
+ (push (cons (car pair2) pair1-cdr) res)
+ (unless alist1 (return))
+ (setq pair2 (cons (1+ pair1-cdr) (cdr pair2)))
+ (setq pair1 (pop alist1))))))
+ (nreverse res))
+ nil))
+