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