+ (class-info (type-class-or-lose 'member))
+ (enumerable t))
+ (:copier nil)
+ (:constructor %make-member-type (xset fp-zeroes))
+ #-sb-xc-host (:pure nil))
+ (xset (missing-arg) :type xset)
+ (fp-zeroes (missing-arg) :type list))
+(defun make-member-type (&key xset fp-zeroes members)
+ (unless xset
+ (aver (not fp-zeroes))
+ (setf xset (alloc-xset))
+ (dolist (elt members)
+ (if (fp-zero-p elt)
+ (pushnew elt fp-zeroes)
+ (add-to-xset elt xset))))
+ ;; 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 ((unpaired nil)
+ (union-types nil))
+ (do ((tail (cdr fp-zeroes) (cdr tail))
+ (zero (car fp-zeroes) (car tail)))
+ ((not zero))
+ (macrolet ((frob (c)
+ `(let ((neg (neg-fp-zero zero)))
+ (if (member neg tail)
+ (push (ctype-of ,c) union-types)
+ (push zero unpaired)))))
+ (etypecase zero
+ (single-float (frob 0.0f0))
+ (double-float (frob 0.0d0))
+ #!+long-float
+ (long-float (frob 0.0l0)))))
+ ;; The actual member-type contains the XSET (with no FP zeroes),
+ ;; and a list of unpaired zeroes.
+ (let ((member-type (unless (and (xset-empty-p xset) (not unpaired))
+ (%make-member-type xset unpaired))))
+ (cond (union-types
+ (make-union-type t (if member-type
+ (cons member-type union-types)
+ union-types)))
+ (member-type
+ member-type)
+ (t
+ *empty-type*)))))
+
+(defun member-type-size (type)
+ (+ (length (member-type-fp-zeroes type))
+ (xset-count (member-type-xset type))))
+
+(defun member-type-member-p (x type)
+ (if (fp-zero-p x)
+ (and (member x (member-type-fp-zeroes type)) t)
+ (xset-member-p x (member-type-xset type))))
+
+(defun mapcar-member-type-members (function type)
+ (declare (function function))
+ (collect ((results))
+ (map-xset (lambda (x)
+ (results (funcall function x)))
+ (member-type-xset type))
+ (dolist (zero (member-type-fp-zeroes type))
+ (results (funcall function zero)))
+ (results)))
+
+(defun mapc-member-type-members (function type)
+ (declare (function function))
+ (map-xset function (member-type-xset type))
+ (dolist (zero (member-type-fp-zeroes type))
+ (funcall function zero)))
+
+(defun member-type-members (type)
+ (append (member-type-fp-zeroes type)
+ (xset-members (member-type-xset type))))
+
+;;; 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))))
+ ()))
+
+\f
+;;;; type utilities
+
+;;; Return the type structure corresponding to a type specifier. We
+;;; pick off structure types as a special case.
+;;;
+;;; Note: VALUES-SPECIFIER-TYPE-CACHE-CLEAR must be called whenever a
+;;; type is defined (or redefined).
+(defun-cached (values-specifier-type
+ :hash-function (lambda (x)
+ (logand (sxhash x) #x3FF))
+ :hash-bits 10
+ :init-wrapper !cold-init-forms)
+ ((orig equal-but-no-car-recursion))
+ (let ((u (uncross orig)))
+ (or (info :type :builtin u)
+ (let ((spec (type-expand u)))
+ (cond
+ ((and (not (eq spec u))
+ (info :type :builtin spec)))
+ ((eq (info :type :kind spec) :instance)
+ (find-classoid spec))
+ ((typep spec 'classoid)
+ (if (typep spec 'built-in-classoid)
+ (or (built-in-classoid-translation spec) spec)
+ spec))
+ (t
+ (when (and (atom spec)
+ (member spec '(and or not member eql satisfies values)))
+ (error "The symbol ~S is not valid as a type specifier." spec))
+ (let* ((lspec (if (atom spec) (list spec) spec))
+ (fun (info :type :translator (car lspec))))
+ (cond (fun
+ (funcall fun lspec))
+ ((or (and (consp spec) (symbolp (car spec))
+ (not (info :type :builtin (car spec))))
+ (and (symbolp spec) (not (info :type :builtin spec))))
+ (when (and *type-system-initialized*
+ (not (eq (info :type :kind spec)
+ :forthcoming-defclass-type)))
+ (signal 'parse-unknown-type :specifier spec))
+ ;; (The RETURN-FROM here inhibits caching.)
+ (return-from values-specifier-type
+ (make-unknown-type :specifier spec)))
+ (t
+ (error "bad thing to be a type specifier: ~S"
+ spec))))))))))
+
+;;; This is like VALUES-SPECIFIER-TYPE, except that we guarantee to
+;;; never return a VALUES type.
+(defun specifier-type (x)
+ (let ((res (values-specifier-type x)))
+ (when (or (values-type-p res)
+ ;; bootstrap magic :-(
+ (and (named-type-p res)
+ (eq (named-type-name res) '*)))
+ (error "VALUES type illegal in this context:~% ~S" x))
+ res))
+
+(defun single-value-specifier-type (x)
+ (if (eq x '*)
+ *universal-type*
+ (specifier-type x)))
+
+;;; Similar to MACROEXPAND, but expands DEFTYPEs. We don't bother
+;;; returning a second value.
+(defun type-expand (form)
+ (let ((def (cond ((symbolp form)
+ (info :type :expander form))
+ ((and (consp form) (symbolp (car form)))
+ (info :type :expander (car form)))
+ (t nil))))
+ (if def
+ (type-expand (funcall def (if (consp form) form (list form))))
+ form)))
+
+;;; Note that the type NAME has been (re)defined, updating the