+;;;; CONS types
+
+(define-type-class cons)
+
+(def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*))
+ (make-cons-type (specifier-type car-type-spec)
+ (specifier-type cdr-type-spec)))
+
+(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-union) (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)))
+ (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 cdr-type1 cdr-type2)
+ cdr-type1)))))
+
+(define-type-method (cons :simple-intersection) (type1 type2)
+ (declare (type cons-type type1 type2))
+ (multiple-value-bind (int-car win-car)
+ (type-intersection (cons-type-car-type type1)
+ (cons-type-car-type type2))
+ (multiple-value-bind (int-cdr win-cdr)
+ (type-intersection (cons-type-cdr-type type1)
+ (cons-type-cdr-type type2))
+ (values (make-cons-type int-car int-cdr)
+ (and win-car win-cdr)))))
+\f