-;;; 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)
- ;; FIXME: The THE FIXNUM stuff is
- ;; redundant in SBCL (or modern CMU
- ;; CL) because of type inference.
- (the fixnum
- (logand (the fixnum (sxhash x))
- #x3FF)))
- :hash-bits 10
- :init-wrapper !cold-init-forms)
- ((orig eq))
- (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)
- (sb!xc:find-class spec))
- ((typep spec 'class)
- ;; There doesn't seem to be any way to translate
- ;; (TYPEP SPEC 'BUILT-IN-CLASS) into something which can be
- ;; executed on the host Common Lisp at cross-compilation time.
- #+sb-xc-host (error
- "stub: (TYPEP SPEC 'BUILT-IN-CLASS) on xc host")
- (if (typep spec 'built-in-class)
- (or (built-in-class-translation spec) spec)
- spec))
- (t
- (let* (;; FIXME: This automatic promotion of FOO-style
- ;; specs to (FOO)-style specs violates the ANSI
- ;; standard. Unfortunately, we can't fix the
- ;; problem just by removing it, since then things
- ;; downstream should break. But at some point we
- ;; should fix this and the things downstream too.
- (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)))
- (symbolp spec))
- (when *type-system-initialized*
- (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))))))))))
-
-;;; 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 (values-type-p res)
- (error "VALUES type illegal in this context:~% ~S" x))
- res))
-
-;;; 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)))