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