+;;; 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