src/code/early-type.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; This software is derived from the CMU CL system, which was
   5 ;;;; written at Carnegie Mellon University and released into the
   6 ;;;; public domain. The software is in the public domain and is
   7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
   8 ;;;; files for more information.
   9
  10 (in-package "SB!KERNEL")
  11
  12 (!begin-collecting-cold-init-forms)
  13
  14 ;;;; representations of types
  15
  16 ;;; A HAIRY-TYPE represents anything too weird to be described
  17 ;;; reasonably or to be useful, such as NOT, SATISFIES, unknown types,
  18 ;;; and unreasonably complicated types involving AND. We just remember
  19 ;;; the original type spec.
  20 (defstruct (hairy-type (:include ctype
  21                                  (class-info (type-class-or-lose 'hairy))
  22                                  (enumerable t)
  23                                  (might-contain-other-types-p t))
  24                        (:copier nil)
  25                        #!+cmu (:pure nil))
  26   ;; the Common Lisp type-specifier of the type we represent
  27   (specifier nil :type t))
  28
  29 (!define-type-class hairy)
  30
  31 ;;; An UNKNOWN-TYPE is a type not known to the type system (not yet
  32 ;;; defined). We make this distinction since we don't want to complain
  33 ;;; about types that are hairy but defined.
  34 (defstruct (unknown-type (:include hairy-type)
  35                          (:copier nil)))
  36
  37 (defstruct (negation-type (:include ctype
  38                                     (class-info (type-class-or-lose 'negation))
  39                                     ;; FIXME: is this right?  It's
  40                                     ;; what they had before, anyway
  41                                     (enumerable t)
  42                                     (might-contain-other-types-p t))
  43                           (:copier nil)
  44                           #!+cmu (:pure nil))
  45   (type (missing-arg) :type ctype))
  46
  47 (!define-type-class negation)
  48
  49 ;;; ARGS-TYPE objects are used both to represent VALUES types and
  50 ;;; to represent FUNCTION types.
  51 (defstruct (args-type (:include ctype)
  52                       (:constructor nil)
  53                       (:copier nil))
  54   ;; Lists of the type for each required and optional argument.
  55   (required nil :type list)
  56   (optional nil :type list)
  57   ;; The type for the rest arg. NIL if there is no &REST arg.
  58   (rest nil :type (or ctype null))
  59   ;; true if &KEY arguments are specified
  60   (keyp nil :type boolean)
  61   ;; list of KEY-INFO structures describing the &KEY arguments
  62   (keywords nil :type list)
  63   ;; true if other &KEY arguments are allowed
  64   (allowp nil :type boolean))
  65
  66 (defun canonicalize-args-type-args (required optional rest &optional keyp)
  67   (when (eq rest *empty-type*)
  68     ;; or vice-versa?
  69     (setq rest nil))
  70   (loop with last-not-rest = nil
  71         for i from 0
  72         for opt in optional
  73         do (cond ((eq opt *empty-type*)
  74                   (return (values required (subseq optional i) rest)))
  75                  ((and (not keyp) (neq opt rest))
  76                   (setq last-not-rest i)))
  77         finally (return (values required
  78                                 (cond (keyp
  79                                        optional)
  80                                       (last-not-rest
  81                                        (subseq optional 0 (1+ last-not-rest))))
  82                                 rest))))
  83
  84 (defun args-types (lambda-list-like-thing)
  85   (multiple-value-bind
  86         (required optional restp rest keyp keys allowp auxp aux
  87                   morep more-context more-count llk-p)
  88       (parse-lambda-list-like-thing lambda-list-like-thing :silent t)
  89     (declare (ignore aux morep more-context more-count))
  90     (when auxp
  91       (error "&AUX in a FUNCTION or VALUES type: ~S." lambda-list-like-thing))
  92     (let ((required (mapcar #'single-value-specifier-type required))
  93           (optional (mapcar #'single-value-specifier-type optional))
  94           (rest (when restp (single-value-specifier-type rest)))
  95           (keywords
  96            (collect ((key-info))
  97              (dolist (key keys)
  98                (unless (proper-list-of-length-p key 2)
  99                  (error "Keyword type description is not a two-list: ~S." key))
 100                (let ((kwd (first key)))
 101                  (when (find kwd (key-info) :key #'key-info-name)
 102                    (error "~@<repeated keyword ~S in lambda list: ~2I~_~S~:>"
 103                           kwd lambda-list-like-thing))
 104                  (key-info
 105                   (make-key-info
 106                    :name kwd
 107                    :type (single-value-specifier-type (second key))))))
 108              (key-info))))
 109       (multiple-value-bind (required optional rest)
 110           (canonicalize-args-type-args required optional rest keyp)
 111         (values required optional rest keyp keywords allowp llk-p)))))
 112
 113 (defstruct (values-type
 114             (:include args-type
 115                       (class-info (type-class-or-lose 'values)))
 116             (:constructor %make-values-type)
 117             (:copier nil)))
 118
 119 (defun-cached (make-values-type-cached
 120                :hash-bits 8
 121                :hash-function (lambda (req opt rest allowp)
 122                                 (logand (logxor
 123                                          (type-list-cache-hash req)
 124                                          (type-list-cache-hash opt)
 125                                          (if rest
 126                                              (type-hash-value rest)
 127                                              42)
 128                                          (sxhash allowp))
 129                                         #xFF)))
 130     ((required equal-but-no-car-recursion)
 131      (optional equal-but-no-car-recursion)
 132      (rest eq)
 133      (allowp eq))
 134   (%make-values-type :required required
 135                      :optional optional
 136                      :rest rest
 137                      :allowp allowp))
 138
 139 (defun make-values-type (&key (args nil argsp)
 140                          required optional rest allowp)
 141   (if argsp
 142       (if (eq args '*)
 143           *wild-type*
 144           (multiple-value-bind (required optional rest keyp keywords allowp
 145                                 llk-p)
 146               (args-types args)
 147             (declare (ignore keywords))
 148             (when keyp
 149               (error "&KEY appeared in a VALUES type specifier ~S."
 150                      `(values ,@args)))
 151             (if llk-p
 152                 (make-values-type :required required
 153                                   :optional optional
 154                                   :rest rest
 155                                   :allowp allowp)
 156                 (make-short-values-type required))))
 157       (multiple-value-bind (required optional rest)
 158           (canonicalize-args-type-args required optional rest)
 159         (cond ((and (null required)
 160                     (null optional)
 161                     (eq rest *universal-type*))
 162                *wild-type*)
 163               ((memq *empty-type* required)
 164                *empty-type*)
 165               (t (make-values-type-cached required optional
 166                                           rest allowp))))))
 167
 168 (!define-type-class values)
 169
 170 ;;; (SPECIFIER-TYPE 'FUNCTION) and its subtypes
 171 (defstruct (fun-type (:include args-type
 172                                (class-info (type-class-or-lose 'function)))
 173                      (:constructor
 174                       %make-fun-type (&key required optional rest
 175                                            keyp keywords allowp
 176                                            wild-args
 177                                            returns
 178                                       &aux (rest (if (eq rest *empty-type*)
 179                                                      nil
 180                                                      rest)))))
 181   ;; true if the arguments are unrestrictive, i.e. *
 182   (wild-args nil :type boolean)
 183   ;; type describing the return values. This is a values type
 184   ;; when multiple values were specified for the return.
 185   (returns (missing-arg) :type ctype))
 186 (defun make-fun-type (&rest initargs
 187                       &key (args nil argsp) returns &allow-other-keys)
 188   (if argsp
 189       (if (eq args '*)
 190           (if (eq returns *wild-type*)
 191               (specifier-type 'function)
 192               (%make-fun-type :wild-args t :returns returns))
 193           (multiple-value-bind (required optional rest keyp keywords allowp)
 194               (args-types args)
 195             (if (and (null required)
 196                      (null optional)
 197                      (eq rest *universal-type*)
 198                      (not keyp))
 199                 (if (eq returns *wild-type*)
 200                     (specifier-type 'function)
 201                     (%make-fun-type :wild-args t :returns returns))
 202                 (%make-fun-type :required required
 203                                 :optional optional
 204                                 :rest rest
 205                                 :keyp keyp
 206                                 :keywords keywords
 207                                 :allowp allowp
 208                                 :returns returns))))
 209       ;; FIXME: are we really sure that we won't make something that
 210       ;; looks like a completely wild function here?
 211       (apply #'%make-fun-type initargs)))
 212
 213 ;;; The CONSTANT-TYPE structure represents a use of the CONSTANT-ARG
 214 ;;; "type specifier", which is only meaningful in function argument
 215 ;;; type specifiers used within the compiler. (It represents something
 216 ;;; that the compiler knows to be a constant.)
 217 (defstruct (constant-type
 218             (:include ctype
 219                       (class-info (type-class-or-lose 'constant)))
 220             (:copier nil))
 221   ;; The type which the argument must be a constant instance of for this type
 222   ;; specifier to win.
 223   (type (missing-arg) :type ctype))
 224
 225 ;;; The NAMED-TYPE is used to represent *, T and NIL, the standard
 226 ;;; special cases, as well as other special cases needed to
 227 ;;; interpolate between regions of the type hierarchy, such as
 228 ;;; INSTANCE (which corresponds to all those classes with slots which
 229 ;;; are not funcallable), FUNCALLABLE-INSTANCE (those classes with
 230 ;;; slots which are funcallable) and EXTENDED-SEQUUENCE (non-LIST
 231 ;;; non-VECTOR classes which are also sequences).  These special cases
 232 ;;; are the ones that aren't really discussed by Baker in his
 233 ;;; "Decision Procedure for SUBTYPEP" paper.
 234 (defstruct (named-type (:include ctype
 235                                  (class-info (type-class-or-lose 'named)))
 236                        (:copier nil))
 237   (name nil :type symbol))
 238
 239 ;;; a list of all the float "formats" (i.e. internal representations;
 240 ;;; nothing to do with #'FORMAT), in order of decreasing precision
 241 (eval-when (:compile-toplevel :load-toplevel :execute)
 242   (defparameter *float-formats*
 243     '(long-float double-float single-float short-float)))
 244
 245 ;;; The type of a float format.
 246 (deftype float-format () `(member ,@*float-formats*))
 247
 248 ;;; A NUMERIC-TYPE represents any numeric type, including things
 249 ;;; such as FIXNUM.
 250 (defstruct (numeric-type (:include ctype
 251                                    (class-info (type-class-or-lose 'number)))
 252                          (:constructor %make-numeric-type)
 253                          (:copier nil))
 254   ;; the kind of numeric type we have, or NIL if not specified (just
 255   ;; NUMBER or COMPLEX)
 256   ;;
 257   ;; KLUDGE: A slot named CLASS for a non-CLASS value is bad.
 258   ;; Especially when a CLASS value *is* stored in another slot (called
 259   ;; CLASS-INFO:-). Perhaps this should be called CLASS-NAME? Also
 260   ;; weird that comment above says "Numeric-Type is used to represent
 261   ;; all numeric types" but this slot doesn't allow COMPLEX as an
 262   ;; option.. how does this fall into "not specified" NIL case above?
 263   ;; Perhaps someday we can switch to CLOS and make NUMERIC-TYPE
 264   ;; be an abstract base class and INTEGER-TYPE, RATIONAL-TYPE, and
 265   ;; whatnot be concrete subclasses..
 266   (class nil :type (member integer rational float nil) :read-only t)
 267   ;; "format" for a float type (i.e. type specifier for a CPU
 268   ;; representation of floating point, e.g. 'SINGLE-FLOAT -- nothing
 269   ;; to do with #'FORMAT), or NIL if not specified or not a float.
 270   ;; Formats which don't exist in a given implementation don't appear
 271   ;; here.
 272   (format nil :type (or float-format null) :read-only t)
 273   ;; Is this a complex numeric type?  Null if unknown (only in NUMBER).
 274   ;;
 275   ;; FIXME: I'm bewildered by FOO-P names for things not intended to
 276   ;; interpreted as truth values. Perhaps rename this COMPLEXNESS?
 277   (complexp :real :type (member :real :complex nil) :read-only t)
 278   ;; The upper and lower bounds on the value, or NIL if there is no
 279   ;; bound. If a list of a number, the bound is exclusive. Integer
 280   ;; types never have exclusive bounds, i.e. they may have them on
 281   ;; input, but they're canonicalized to inclusive bounds before we
 282   ;; store them here.
 283   (low nil :type (or number cons null) :read-only t)
 284   (high nil :type (or number cons null) :read-only t))
 285
 286 ;;; Impose canonicalization rules for NUMERIC-TYPE. Note that in some
 287 ;;; cases, despite the name, we return *EMPTY-TYPE* instead of a
 288 ;;; NUMERIC-TYPE.
 289 (defun make-numeric-type (&key class format (complexp :real) low high
 290                                enumerable)
 291   ;; if interval is empty
 292   (if (and low
 293            high
 294            (if (or (consp low) (consp high)) ; if either bound is exclusive
 295                (>= (type-bound-number low) (type-bound-number high))
 296                (> low high)))
 297       *empty-type*
 298       (multiple-value-bind (canonical-low canonical-high)
 299           (case class
 300             (integer
 301              ;; INTEGER types always have their LOW and HIGH bounds
 302              ;; represented as inclusive, not exclusive values.
 303              (values (if (consp low)
 304                          (1+ (type-bound-number low))
 305                          low)
 306                      (if (consp high)
 307                          (1- (type-bound-number high))
 308                          high)))
 309             (t
 310              ;; no canonicalization necessary
 311              (values low high)))
 312         (when (and (eq class 'rational)
 313                    (integerp canonical-low)
 314                    (integerp canonical-high)
 315                    (= canonical-low canonical-high))
 316           (setf class 'integer))
 317         (%make-numeric-type :class class
 318                             :format format
 319                             :complexp complexp
 320                             :low canonical-low
 321                             :high canonical-high
 322                             :enumerable enumerable))))
 323
 324 (defun modified-numeric-type (base
 325                               &key
 326                               (class      (numeric-type-class      base))
 327                               (format     (numeric-type-format     base))
 328                               (complexp   (numeric-type-complexp   base))
 329                               (low        (numeric-type-low        base))
 330                               (high       (numeric-type-high       base))
 331                               (enumerable (numeric-type-enumerable base)))
 332   (make-numeric-type :class class
 333                      :format format
 334                      :complexp complexp
 335                      :low low
 336                      :high high
 337                      :enumerable enumerable))
 338
 339 (defstruct (character-set-type
 340             (:include ctype
 341                       (class-info (type-class-or-lose 'character-set)))
 342             (:constructor %make-character-set-type)
 343             (:copier nil))
 344   (pairs (missing-arg) :type list :read-only t))
 345 (defun make-character-set-type (&key pairs)
 346   ; (aver (equal (mapcar #'car pairs)
 347   ;              (sort (mapcar #'car pairs) #'<)))
 348   ;; aver that the cars of the list elements are sorted into increasing order
 349   (aver (or (null pairs)
 350             (do ((p pairs (cdr p)))
 351                 ((null (cdr p)) t)
 352               (when (> (caar p) (caadr p)) (return nil)))))
 353   (let ((pairs (let (result)
 354                 (do ((pairs pairs (cdr pairs)))
 355                     ((null pairs) (nreverse result))
 356                   (destructuring-bind (low . high) (car pairs)
 357                     (loop for (low1 . high1) in (cdr pairs)
 358                           if (<= low1 (1+ high))
 359                           do (progn (setf high (max high high1))
 360                                     (setf pairs (cdr pairs)))
 361                           else do (return nil))
 362                     (cond
 363                       ((>= low sb!xc:char-code-limit))
 364                       ((< high 0))
 365                       (t (push (cons (max 0 low)
 366                                      (min high (1- sb!xc:char-code-limit)))
 367                                result))))))))
 368     (if (null pairs)
 369        *empty-type*
 370        (%make-character-set-type :pairs pairs))))
 371
 372 ;;; An ARRAY-TYPE is used to represent any array type, including
 373 ;;; things such as SIMPLE-BASE-STRING.
 374 (defstruct (array-type (:include ctype
 375                                  (class-info (type-class-or-lose 'array)))
 376                        (:constructor %make-array-type)
 377                        (:copier nil))
 378   ;; the dimensions of the array, or * if unspecified. If a dimension
 379   ;; is unspecified, it is *.
 380   (dimensions '* :type (or list (member *)))
 381   ;; Is this not a simple array type? (:MAYBE means that we don't know.)
 382   (complexp :maybe :type (member t nil :maybe))
 383   ;; the element type as originally specified
 384   (element-type (missing-arg) :type ctype)
 385   ;; the element type as it is specialized in this implementation
 386   (specialized-element-type *wild-type* :type ctype))
 387 (define-cached-synonym make-array-type)
 388
 389 ;;; A MEMBER-TYPE represent a use of the MEMBER type specifier. We
 390 ;;; bother with this at this level because MEMBER types are fairly
 391 ;;; important and union and intersection are well defined.
 392 (defstruct (member-type (:include ctype
 393                                   (class-info (type-class-or-lose 'member))
 394                                   (enumerable t))
 395                         (:copier nil)
 396                         (:constructor %make-member-type (xset fp-zeroes))
 397                         #-sb-xc-host (:pure nil))
 398   (xset (missing-arg) :type xset)
 399   (fp-zeroes (missing-arg) :type list))
 400 (defun make-member-type (&key xset fp-zeroes members)
 401   (unless xset
 402     (aver (not fp-zeroes))
 403     (setf xset (alloc-xset))
 404     (dolist (elt members)
 405       (if (fp-zero-p elt)
 406           (pushnew elt fp-zeroes)
 407           (add-to-xset elt xset))))
 408   ;; if we have a pair of zeros (e.g. 0.0d0 and -0.0d0), then we can
 409   ;; canonicalize to (DOUBLE-FLOAT 0.0d0 0.0d0), because numeric
 410   ;; ranges are compared by arithmetic operators (while MEMBERship is
 411   ;; compared by EQL).  -- CSR, 2003-04-23
 412   (let ((unpaired nil)
 413         (union-types nil))
 414     (do ((tail (cdr fp-zeroes) (cdr tail))
 415          (zero (car fp-zeroes) (car tail)))
 416         ((not zero))
 417       (macrolet ((frob (c)
 418                    `(let ((neg (neg-fp-zero zero)))
 419                       (if (member neg tail)
 420                           (push (ctype-of ,c) union-types)
 421                           (push zero unpaired)))))
 422         (etypecase zero
 423           (single-float (frob 0.0f0))
 424           (double-float (frob 0.0d0))
 425           #!+long-float
 426           (long-float (frob 0.0l0)))))
 427     ;; The actual member-type contains the XSET (with no FP zeroes),
 428     ;; and a list of unpaired zeroes.
 429     (let ((member-type (unless (and (xset-empty-p xset) (not unpaired))
 430                          (%make-member-type xset unpaired))))
 431       (cond (union-types
 432              (make-union-type t (if member-type
 433                                     (cons member-type union-types)
 434                                     union-types)))
 435             (member-type
 436              member-type)
 437             (t
 438              *empty-type*)))))
 439
 440 (defun member-type-size (type)
 441   (+ (length (member-type-fp-zeroes type))
 442      (xset-count (member-type-xset type))))
 443
 444 (defun member-type-member-p (x type)
 445   (if (fp-zero-p x)
 446       (and (member x (member-type-fp-zeroes type)) t)
 447       (xset-member-p x (member-type-xset type))))
 448
 449 (defun mapcar-member-type-members (function type)
 450   (declare (function function))
 451   (collect ((results))
 452     (map-xset (lambda (x)
 453                 (results (funcall function x)))
 454               (member-type-xset type))
 455     (dolist (zero (member-type-fp-zeroes type))
 456       (results (funcall function zero)))
 457     (results)))
 458
 459 (defun mapc-member-type-members (function type)
 460   (declare (function function))
 461   (map-xset function (member-type-xset type))
 462   (dolist (zero (member-type-fp-zeroes type))
 463     (funcall function zero)))
 464
 465 (defun member-type-members (type)
 466   (append (member-type-fp-zeroes type)
 467           (xset-members (member-type-xset type))))
 468
 469 ;;; A COMPOUND-TYPE is a type defined out of a set of types, the
 470 ;;; common parent of UNION-TYPE and INTERSECTION-TYPE.
 471 (defstruct (compound-type (:include ctype
 472                                     (might-contain-other-types-p t))
 473                           (:constructor nil)
 474                           (:copier nil))
 475   (types nil :type list :read-only t))
 476
 477 ;;; A UNION-TYPE represents a use of the OR type specifier which we
 478 ;;; couldn't canonicalize to something simpler. Canonical form:
 479 ;;;   1. All possible pairwise simplifications (using the UNION2 type
 480 ;;;      methods) have been performed. Thus e.g. there is never more
 481 ;;;      than one MEMBER-TYPE component. FIXME: As of sbcl-0.6.11.13,
 482 ;;;      this hadn't been fully implemented yet.
 483 ;;;   2. There are never any UNION-TYPE components.
 484 (defstruct (union-type (:include compound-type
 485                                  (class-info (type-class-or-lose 'union)))
 486                        (:constructor %make-union-type (enumerable types))
 487                        (:copier nil)))
 488 (define-cached-synonym make-union-type)
 489
 490 ;;; An INTERSECTION-TYPE represents a use of the AND type specifier
 491 ;;; which we couldn't canonicalize to something simpler. Canonical form:
 492 ;;;   1. All possible pairwise simplifications (using the INTERSECTION2
 493 ;;;      type methods) have been performed. Thus e.g. there is never more
 494 ;;;      than one MEMBER-TYPE component.
 495 ;;;   2. There are never any INTERSECTION-TYPE components: we've
 496 ;;;      flattened everything into a single INTERSECTION-TYPE object.
 497 ;;;   3. There are never any UNION-TYPE components. Either we should
 498 ;;;      use the distributive rule to rearrange things so that
 499 ;;;      unions contain intersections and not vice versa, or we
 500 ;;;      should just punt to using a HAIRY-TYPE.
 501 (defstruct (intersection-type (:include compound-type
 502                                         (class-info (type-class-or-lose
 503                                                      'intersection)))
 504                               (:constructor %make-intersection-type
 505                                             (enumerable types))
 506                               (:copier nil)))
 507
 508 ;;; Return TYPE converted to canonical form for a situation where the
 509 ;;; "type" '* (which SBCL still represents as a type even though ANSI
 510 ;;; CL defines it as a related but different kind of placeholder) is
 511 ;;; equivalent to type T.
 512 (defun type-*-to-t (type)
 513   (if (type= type *wild-type*)
 514       *universal-type*
 515       type))
 516
 517 ;;; A CONS-TYPE is used to represent a CONS type.
 518 (defstruct (cons-type (:include ctype (class-info (type-class-or-lose 'cons)))
 519                       (:constructor
 520                        %make-cons-type (car-type
 521                                         cdr-type))
 522                       (:copier nil))
 523   ;; the CAR and CDR element types (to support ANSI (CONS FOO BAR) types)
 524   ;;
 525   ;; FIXME: Most or all other type structure slots could also be :READ-ONLY.
 526   (car-type (missing-arg) :type ctype :read-only t)
 527   (cdr-type (missing-arg) :type ctype :read-only t))
 528 (defun make-cons-type (car-type cdr-type)
 529   (aver (not (or (eq car-type *wild-type*)
 530                  (eq cdr-type *wild-type*))))
 531   (if (or (eq car-type *empty-type*)
 532           (eq cdr-type *empty-type*))
 533       *empty-type*
 534       (%make-cons-type car-type cdr-type)))
 535
 536 (defun cons-type-length-info (type)
 537   (declare (type cons-type type))
 538   (do ((min 1 (1+ min))
 539        (cdr (cons-type-cdr-type type) (cons-type-cdr-type cdr)))
 540       ((not (cons-type-p cdr))
 541        (cond
 542          ((csubtypep cdr (specifier-type 'null))
 543           (values min t))
 544          ((csubtypep *universal-type* cdr)
 545           (values min nil))
 546          ((type/= (type-intersection (specifier-type 'cons) cdr) *empty-type*)
 547           (values min nil))
 548          ((type/= (type-intersection (specifier-type 'null) cdr) *empty-type*)
 549           (values min t))
 550          (t (values min :maybe))))
 551     ()))
 552
 553 \f
 554 ;;;; type utilities
 555
 556 ;;; Return the type structure corresponding to a type specifier. We
 557 ;;; pick off structure types as a special case.
 558 ;;;
 559 ;;; Note: VALUES-SPECIFIER-TYPE-CACHE-CLEAR must be called whenever a
 560 ;;; type is defined (or redefined).
 561 (defun-cached (values-specifier-type
 562                :hash-function (lambda (x)
 563                                 (logand (sxhash x) #x3FF))
 564                :hash-bits 10
 565                :init-wrapper !cold-init-forms)
 566               ((orig equal-but-no-car-recursion))
 567   (let ((u (uncross orig)))
 568     (or (info :type :builtin u)
 569         (let ((spec (type-expand u)))
 570           (cond
 571            ((and (not (eq spec u))
 572                  (info :type :builtin spec)))
 573            ((eq (info :type :kind spec) :instance)
 574             (find-classoid spec))
 575            ((typep spec 'classoid)
 576             (if (typep spec 'built-in-classoid)
 577                 (or (built-in-classoid-translation spec) spec)
 578                 spec))
 579            (t
 580             (when (and (atom spec)
 581                        (member spec '(and or not member eql satisfies values)))
 582               (error "The symbol ~S is not valid as a type specifier." spec))
 583             (let* ((lspec (if (atom spec) (list spec) spec))
 584                    (fun (info :type :translator (car lspec))))
 585               (cond (fun
 586                      (funcall fun lspec))
 587                     ((or (and (consp spec) (symbolp (car spec))
 588                               (not (info :type :builtin (car spec))))
 589                          (and (symbolp spec) (not (info :type :builtin spec))))
 590                      (when (and *type-system-initialized*
 591                                 (not (eq (info :type :kind spec)
 592                                          :forthcoming-defclass-type)))
 593                        (signal 'parse-unknown-type :specifier spec))
 594                      ;; (The RETURN-FROM here inhibits caching.)
 595                      (return-from values-specifier-type
 596                        (make-unknown-type :specifier spec)))
 597                     (t
 598                      (error "bad thing to be a type specifier: ~S"
 599                             spec))))))))))
 600
 601 ;;; This is like VALUES-SPECIFIER-TYPE, except that we guarantee to
 602 ;;; never return a VALUES type.
 603 (defun specifier-type (x)
 604   (let ((res (values-specifier-type x)))
 605     (when (or (values-type-p res)
 606               ;; bootstrap magic :-(
 607               (and (named-type-p res)
 608                    (eq (named-type-name res) '*)))
 609       (error "VALUES type illegal in this context:~%  ~S" x))
 610     res))
 611
 612 (defun single-value-specifier-type (x)
 613   (if (eq x '*)
 614       *universal-type*
 615       (specifier-type x)))
 616
 617 ;;; Similar to MACROEXPAND, but expands DEFTYPEs. We don't bother
 618 ;;; returning a second value.
 619 (defun type-expand (form)
 620   (let ((def (cond ((symbolp form)
 621                     (info :type :expander form))
 622                    ((and (consp form) (symbolp (car form)))
 623                     (info :type :expander (car form)))
 624                    (t nil))))
 625     (if def
 626         (type-expand (funcall def (if (consp form) form (list form))))
 627         form)))
 628
 629 ;;; Note that the type NAME has been (re)defined, updating the
 630 ;;; undefined warnings and VALUES-SPECIFIER-TYPE cache.
 631 (defun %note-type-defined (name)
 632   (declare (symbol name))
 633   (note-name-defined name :type)
 634   (when (boundp 'sb!kernel::*values-specifier-type-cache-vector*)
 635     (values-specifier-type-cache-clear))
 636   (values))
 637
 638 \f
 639 (!defun-from-collected-cold-init-forms !early-type-cold-init)