+ (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))))
+ ()))
+
+;;; A SIMD-PACK-TYPE is used to represent a SIMD-PACK type.
+#!+sb-simd-pack
+(defstruct (simd-pack-type
+ (:include ctype (class-info (type-class-or-lose 'simd-pack)))
+ (:constructor %make-simd-pack-type (element-type))
+ (:copier nil))
+ (element-type (missing-arg)
+ :type (cons #||(member #.*simd-pack-element-types*) ||#)
+ :read-only t))
+
+#!+sb-simd-pack
+(defun make-simd-pack-type (element-type)
+ (aver (neq element-type *wild-type*))
+ (if (eq element-type *empty-type*)
+ *empty-type*
+ (%make-simd-pack-type
+ (dolist (pack-type *simd-pack-element-types*
+ (error "~S element type must be a subtype of ~
+ ~{~S~#[~;, or ~:;, ~]~}."
+ 'simd-pack *simd-pack-element-types*))
+ (when (csubtypep element-type (specifier-type pack-type))
+ (return (list pack-type)))))))
+
+\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 (typexpand u)))
+ (cond
+ ((and (not (eq spec u))
+ (info :type :builtin spec)))
+ ((and (consp spec) (symbolp (car spec))
+ (info :type :builtin (car spec))
+ (let ((expander (info :type :expander (car spec))))
+ (and expander (values-specifier-type (funcall expander 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; this
+ ;; does not only make sense from a compiler
+ ;; diagnostics point of view but is also
+ ;; indispensable for proper workingness of
+ ;; VALID-TYPE-SPECIFIER-P.)
+ (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)))
+
+(defun typexpand-1 (type-specifier &optional env)
+ #!+sb-doc
+ "Takes and expands a type specifier once like MACROEXPAND-1.
+Returns two values: the expansion, and a boolean that is true when
+expansion happened."
+ (declare (type type-specifier type-specifier))
+ (declare (ignore env))
+ (multiple-value-bind (expander lspec)
+ (let ((spec type-specifier))
+ (cond ((and (symbolp spec) (info :type :builtin spec))
+ ;; We do not expand builtins even though it'd be
+ ;; possible to do so sometimes (e.g. STRING) for two
+ ;; reasons:
+ ;;
+ ;; a) From a user's point of view, CL types are opaque.
+ ;;
+ ;; b) so (EQUAL (TYPEXPAND 'STRING) (TYPEXPAND-ALL 'STRING))
+ (values nil nil))
+ ((symbolp spec)
+ (values (info :type :expander spec) (list spec)))
+ ((and (consp spec) (symbolp (car spec)) (info :type :builtin (car spec)))
+ ;; see above
+ (values nil nil))
+ ((and (consp spec) (symbolp (car spec)))
+ (values (info :type :expander (car spec)) spec))
+ (t nil)))
+ (if expander
+ (values (funcall expander lspec) t)
+ (values type-specifier nil))))
+
+(defun typexpand (type-specifier &optional env)
+ #!+sb-doc
+ "Takes and expands a type specifier repeatedly like MACROEXPAND.
+Returns two values: the expansion, and a boolean that is true when
+expansion happened."
+ (declare (type type-specifier type-specifier))
+ (multiple-value-bind (expansion flag)
+ (typexpand-1 type-specifier env)
+ (if flag
+ (values (typexpand expansion env) t)
+ (values expansion flag))))
+
+(defun typexpand-all (type-specifier &optional env)
+ #!+sb-doc
+ "Takes and expands a type specifier recursively like MACROEXPAND-ALL."
+ (declare (type type-specifier type-specifier))
+ (declare (ignore env))
+ ;; I first thought this would not be a good implementation because
+ ;; it signals an error on e.g. (CONS 1 2) until I realized that
+ ;; walking and calling TYPEXPAND would also result in errors, and
+ ;; it actually makes sense.
+ ;;
+ ;; There's still a small problem in that
+ ;; (TYPEXPAND-ALL '(CONS * FIXNUM)) => (CONS T FIXNUM)
+ ;; whereas walking+typexpand would result in (CONS * FIXNUM).
+ ;;
+ ;; Similiarly, (TYPEXPAND-ALL '(FUNCTION (&REST T) *)) => FUNCTION.
+ (type-specifier (values-specifier-type type-specifier)))
+
+(defun defined-type-name-p (name &optional env)
+ #!+sb-doc
+ "Returns T if NAME is known to name a type specifier, otherwise NIL."
+ (declare (symbol name))
+ (declare (ignore env))
+ (and (info :type :kind name) t))
+
+(defun valid-type-specifier-p (type-specifier &optional env)
+ #!+sb-doc
+ "Returns T if TYPE-SPECIFIER is a valid type specifier, otherwise NIL.
+
+There may be different metrics on what constitutes a \"valid type
+specifier\" depending on context. If this function does not suit your
+exact need, you may be able to craft a particular solution using a
+combination of DEFINED-TYPE-NAME-P and the TYPEXPAND functions.
+
+The definition of \"valid type specifier\" employed by this function
+is based on the following mnemonic:
+
+ \"Would TYPEP accept it as second argument?\"
+
+Except that unlike TYPEP, this function fully supports compound
+FUNCTION type specifiers, and the VALUES type specifier, too.
+
+In particular, VALID-TYPE-SPECIFIER-P will return NIL if
+TYPE-SPECIFIER is not a class, not a symbol that is known to name a
+type specifier, and not a cons that represents a known compound type
+specifier in a syntactically and recursively correct way.
+
+Examples:
+
+ (valid-type-specifier-p '(cons * *)) => T
+ (valid-type-specifier-p '#:foo) => NIL
+ (valid-type-specifier-p '(cons * #:foo)) => NIL
+ (valid-type-specifier-p '(cons 1 *) => NIL
+
+Experimental."
+ (declare (ignore env))
+ (handler-case (prog1 t (values-specifier-type type-specifier))
+ (parse-unknown-type () nil)
+ (error () nil)))