+(defun make-member-type (&key members)
+ (declare (type list members))
+ ;; if we have a pair of zeros (e.g. 0.0d0 and -0.0d0), then we can
+ ;; canonicalize to (DOUBLE-FLOAT 0.0d0 0.0d0), because numeric
+ ;; ranges are compared by arithmetic operators (while MEMBERship is
+ ;; compared by EQL). -- CSR, 2003-04-23
+ (let ((n-single (load-time-value
+ (make-unportable-float :single-float-negative-zero)))
+ (n-double (load-time-value
+ (make-unportable-float :double-float-negative-zero)))
+ #!+long-float
+ (n-long (load-time-value
+ (make-unportable-float :long-float-negative-zero)))
+ (singles nil)
+ (doubles nil)
+ #!+long-float
+ (longs nil))
+ ;; Just a single traversal, please! MEMBERS2 starts as with MEMBERS,
+ ;; sans any zeroes -- if there are any paired zeroes then the
+ ;; unpaired ones are added back to it.
+ (let (members2)
+ (dolist (elt members)
+ (if (and (numberp elt) (zerop elt))
+ (typecase elt
+ (single-float (push elt singles))
+ (double-float (push elt doubles))
+ #!+long-float
+ (long-float (push elt longs)))
+ (push elt members2)))
+ (let ((singlep (and (member 0.0f0 singles)
+ (member n-single singles)
+ (or (aver (= 2 (length singles))) t)))
+ (doublep (and (member 0.0d0 doubles)
+ (member n-double doubles)
+ (or (aver (= 2 (length doubles))) t)))
+ #!+long-float
+ (longp (and (member 0.0lo longs)
+ (member n-long longs)
+ (or (aver (= 2 (lenght longs))) t))))
+ (if (or singlep doublep #!+long-float longp)
+ (let (union-types)
+ (if singlep
+ (push (ctype-of 0.0f0) union-types)
+ (setf members2 (nconc singles members2)))
+ (if doublep
+ (push (ctype-of 0.0d0) union-types)
+ (setf members2 (nconc doubles members2)))
+ #!+long-float
+ (if longp
+ (push (ctype-of 0.0l0) union-types)
+ (setf members2 (nconc longs members2)))
+ (aver (not (null union-types)))
+ (make-union-type t
+ (if (null members2)
+ union-types
+ (cons (%make-member-type members2)
+ union-types))))
+ (%make-member-type members))))))
+
+;;; A COMPOUND-TYPE is a type defined out of a set of types, the
+;;; common parent of UNION-TYPE and INTERSECTION-TYPE.
+(defstruct (compound-type (:include ctype
+ (might-contain-other-types-p t))
+ (:constructor nil)
+ (:copier nil))
+ (types nil :type list :read-only t))
+
+;;; A UNION-TYPE represents a use of the OR type specifier which we
+;;; couldn't canonicalize to something simpler. Canonical form:
+;;; 1. All possible pairwise simplifications (using the UNION2 type
+;;; methods) have been performed. Thus e.g. there is never more
+;;; than one MEMBER-TYPE component. FIXME: As of sbcl-0.6.11.13,
+;;; this hadn't been fully implemented yet.
+;;; 2. There are never any UNION-TYPE components.
+(defstruct (union-type (:include compound-type
+ (class-info (type-class-or-lose 'union)))
+ (:constructor %make-union-type (enumerable types))
+ (:copier nil)))
+(define-cached-synonym make-union-type)
+
+;;; An INTERSECTION-TYPE represents a use of the AND type specifier
+;;; which we couldn't canonicalize to something simpler. Canonical form:
+;;; 1. All possible pairwise simplifications (using the INTERSECTION2
+;;; type methods) have been performed. Thus e.g. there is never more
+;;; than one MEMBER-TYPE component.
+;;; 2. There are never any INTERSECTION-TYPE components: we've
+;;; flattened everything into a single INTERSECTION-TYPE object.
+;;; 3. There are never any UNION-TYPE components. Either we should
+;;; use the distributive rule to rearrange things so that
+;;; unions contain intersections and not vice versa, or we
+;;; should just punt to using a HAIRY-TYPE.
+(defstruct (intersection-type (:include compound-type
+ (class-info (type-class-or-lose
+ 'intersection)))
+ (:constructor %make-intersection-type
+ (enumerable types))
+ (:copier nil)))
+
+;;; Return TYPE converted to canonical form for a situation where the
+;;; "type" '* (which SBCL still represents as a type even though ANSI
+;;; CL defines it as a related but different kind of placeholder) is
+;;; equivalent to type T.
+(defun type-*-to-t (type)
+ (if (type= type *wild-type*)
+ *universal-type*
+ type))
+
+;;; A CONS-TYPE is used to represent a CONS type.
+(defstruct (cons-type (:include ctype (class-info (type-class-or-lose 'cons)))
+ (:constructor
+ %make-cons-type (car-type
+ cdr-type))
+ (:copier nil))
+ ;; the CAR and CDR element types (to support ANSI (CONS FOO BAR) types)
+ ;;
+ ;; FIXME: Most or all other type structure slots could also be :READ-ONLY.
+ (car-type (missing-arg) :type ctype :read-only t)
+ (cdr-type (missing-arg) :type ctype :read-only t))
+(defun make-cons-type (car-type cdr-type)
+ (aver (not (or (eq car-type *wild-type*)
+ (eq cdr-type *wild-type*))))
+ (if (or (eq car-type *empty-type*)
+ (eq cdr-type *empty-type*))
+ *empty-type*
+ (%make-cons-type car-type cdr-type)))
+
+(defun cons-type-length-info (type)
+ (declare (type cons-type type))
+ (do ((min 1 (1+ min))
+ (cdr (cons-type-cdr-type type) (cons-type-cdr-type cdr)))
+ ((not (cons-type-p cdr))
+ (cond
+ ((csubtypep cdr (specifier-type 'null))
+ (values min t))
+ ((csubtypep *universal-type* cdr)
+ (values min nil))
+ ((type/= (type-intersection (specifier-type 'cons) cdr) *empty-type*)
+ (values min nil))
+ ((type/= (type-intersection (specifier-type 'null) cdr) *empty-type*)
+ (values min t))
+ (t (values min :maybe))))
+ ()))