+ (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
+ ;; Unparse into either MEMBER or CHARACTER-SET. We use MEMBER if there
+ ;; are at most as many characters than there are character code ranges.
+ (let* ((pairs (character-set-type-pairs type))
+ (count (length pairs))
+ (chars (loop named outer
+ for (low . high) in pairs
+ nconc (loop for code from low upto high
+ collect (sb!xc:code-char code)
+ when (minusp (decf count))
+ do (return-from outer t)))))
+ (if (eq chars t)
+ `(character-set ,pairs)
+ `(member ,@chars))))))
+
+(!define-type-method (character-set :singleton-p) (type)
+ (let* ((pairs (character-set-type-pairs type))
+ (pair (first pairs)))
+ (if (and (typep pairs '(cons t null))
+ (eql (car pair) (cdr pair)))
+ (values t (code-char (car pair)))
+ (values nil nil))))
+
+(!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))
+