src/code/late-type.lisp

   1 ;;;; This file contains the definition of non-CLASS types (e.g.
   2 ;;;; subtypes of interesting BUILT-IN-CLASSes) and the interfaces to
   3 ;;;; the type system. Common Lisp type specifiers are parsed into a
   4 ;;;; somewhat canonical internal type representation that supports
   5 ;;;; type union, intersection, etc. (Except that ALIEN types have
   6 ;;;; moved out..)
   7
   8 ;;;; This software is part of the SBCL system. See the README file for
   9 ;;;; more information.
  10 ;;;;
  11 ;;;; This software is derived from the CMU CL system, which was
  12 ;;;; written at Carnegie Mellon University and released into the
  13 ;;;; public domain. The software is in the public domain and is
  14 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  15 ;;;; files for more information.
  16
  17 (in-package "SB!KERNEL")
  18
  19 (!begin-collecting-cold-init-forms)
  20
  21 ;;; ### Remaining incorrectnesses:
  22 ;;;
  23 ;;; TYPE-UNION (and the OR type) doesn't properly canonicalize an
  24 ;;; exhaustive partition or coalesce contiguous ranges of numeric
  25 ;;; types.
  26 ;;;
  27 ;;; There are all sorts of nasty problems with open bounds on FLOAT
  28 ;;; types (and probably FLOAT types in general.)
  29 ;;;
  30 ;;; RATIO and BIGNUM are not recognized as numeric types.
  31
  32 ;;; FIXME: It seems to me that this should be set to NIL by default,
  33 ;;; and perhaps not even optionally set to T.
  34 (defvar *use-implementation-types* t
  35   #!+sb-doc
  36   "*USE-IMPLEMENTATION-TYPES* is a semi-public flag which determines how
  37    restrictive we are in determining type membership. If two types are the
  38    same in the implementation, then we will consider them them the same when
  39    this switch is on. When it is off, we try to be as restrictive as the
  40    language allows, allowing us to detect more errors. Currently, this only
  41    affects array types.")
  42
  43 (!cold-init-forms (setq *use-implementation-types* t))
  44
  45 ;;; These functions are used as method for types which need a complex
  46 ;;; subtypep method to handle some superclasses, but cover a subtree
  47 ;;; of the type graph (i.e. there is no simple way for any other type
  48 ;;; class to be a subtype.) There are always still complex ways,
  49 ;;; namely UNION and MEMBER types, so we must give TYPE1's method a
  50 ;;; chance to run, instead of immediately returning NIL, T.
  51 (defun delegate-complex-subtypep-arg2 (type1 type2)
  52   (let ((subtypep-arg1
  53          (type-class-complex-subtypep-arg1
  54           (type-class-info type1))))
  55     (if subtypep-arg1
  56         (funcall subtypep-arg1 type1 type2)
  57         (values nil t))))
  58 (defun delegate-complex-intersection (type1 type2)
  59   (let ((method (type-class-complex-intersection (type-class-info type1))))
  60     (if (and method (not (eq method #'delegate-complex-intersection)))
  61         (funcall method type2 type1)
  62         (vanilla-intersection type1 type2))))
  63
  64 ;;; This is used by !DEFINE-SUPERCLASSES to define the SUBTYPE-ARG1
  65 ;;; method. INFO is a list of conses
  66 ;;;   (SUPERCLASS-CLASS . {GUARD-TYPE-SPECIFIER | NIL}).
  67 ;;; This will never be called with a hairy type as TYPE2, since the
  68 ;;; hairy type TYPE2 method gets first crack.
  69 (defun !has-superclasses-complex-subtypep-arg1 (type1 type2 info)
  70   (values
  71    (and (sb!xc:typep type2 'sb!xc:class)
  72         (dolist (x info nil)
  73           (when (or (not (cdr x))
  74                     (csubtypep type1 (specifier-type (cdr x))))
  75             (return
  76              (or (eq type2 (car x))
  77                  (let ((inherits (layout-inherits (class-layout (car x)))))
  78                    (dotimes (i (length inherits) nil)
  79                      (when (eq type2 (layout-class (svref inherits i)))
  80                        (return t)))))))))
  81    t))
  82
  83 ;;; This function takes a list of specs, each of the form
  84 ;;;    (SUPERCLASS-NAME &OPTIONAL GUARD).
  85 ;;; Consider one spec (with no guard): any instance of the named
  86 ;;; TYPE-CLASS is also a subtype of the named superclass and of any of
  87 ;;; its superclasses. If there are multiple specs, then some will have
  88 ;;; guards. We choose the first spec whose guard is a supertype of
  89 ;;; TYPE1 and use its superclass. In effect, a sequence of guards
  90 ;;;    G0, G1, G2
  91 ;;; is actually
  92 ;;;    G0,(and G1 (not G0)), (and G2 (not (or G0 G1))).
  93 ;;;
  94 ;;; WHEN controls when the forms are executed.
  95 (defmacro !define-superclasses (type-class-name specs when)
  96   (let ((type-class (gensym "TYPE-CLASS-"))
  97         (info (gensym "INFO")))
  98     `(,when
  99        (let ((,type-class (type-class-or-lose ',type-class-name))
 100              (,info (mapcar (lambda (spec)
 101                               (destructuring-bind
 102                                   (super &optional guard)
 103                                   spec
 104                                 (cons (sb!xc:find-class super) guard)))
 105                             ',specs)))
 106          (setf (type-class-complex-subtypep-arg1 ,type-class)
 107                (lambda (type1 type2)
 108                  (!has-superclasses-complex-subtypep-arg1 type1 type2 ,info)))
 109          (setf (type-class-complex-subtypep-arg2 ,type-class)
 110                #'delegate-complex-subtypep-arg2)
 111          (setf (type-class-complex-intersection ,type-class)
 112                #'delegate-complex-intersection)))))
 113 \f
 114 ;;;; FUNCTION and VALUES types
 115 ;;;;
 116 ;;;; Pretty much all of the general type operations are illegal on
 117 ;;;; VALUES types, since we can't discriminate using them, do
 118 ;;;; SUBTYPEP, etc. FUNCTION types are acceptable to the normal type
 119 ;;;; operations, but are generally considered to be equivalent to
 120 ;;;; FUNCTION. These really aren't true types in any type theoretic
 121 ;;;; sense, but we still parse them into CTYPE structures for two
 122 ;;;; reasons:
 123
 124 ;;;; -- Parsing and unparsing work the same way, and indeed we can't
 125 ;;;;    tell whether a type is a function or values type without
 126 ;;;;    parsing it.
 127 ;;;; -- Many of the places that can be annotated with real types can
 128 ;;;;    also be annotated with function or values types.
 129
 130 ;;; the description of a keyword argument
 131 (defstruct (key-info #-sb-xc-host (:pure t))
 132   ;; the keyword
 133   (name (required-argument) :type keyword)
 134   ;; the type of the argument value
 135   (type (required-argument) :type ctype))
 136
 137 (!define-type-method (values :simple-subtypep :complex-subtypep-arg1)
 138                     (type1 type2)
 139   (declare (ignore type2))
 140   (error "Subtypep is illegal on this type:~%  ~S" (type-specifier type1)))
 141
 142 (!define-type-method (values :complex-subtypep-arg2)
 143                     (type1 type2)
 144   (declare (ignore type1))
 145   (error "Subtypep is illegal on this type:~%  ~S" (type-specifier type2)))
 146
 147 (!define-type-method (values :unparse) (type)
 148   (cons 'values (unparse-args-types type)))
 149
 150 ;;; Return true if LIST1 and LIST2 have the same elements in the same
 151 ;;; positions according to TYPE=. We return NIL, NIL if there is an
 152 ;;; uncertain comparison.
 153 (defun type=-list (list1 list2)
 154   (declare (list list1 list2))
 155   (do ((types1 list1 (cdr types1))
 156        (types2 list2 (cdr types2)))
 157       ((or (null types1) (null types2))
 158        (if (or types1 types2)
 159            (values nil t)
 160            (values t t)))
 161     (multiple-value-bind (val win)
 162         (type= (first types1) (first types2))
 163       (unless win
 164         (return (values nil nil)))
 165       (unless val
 166         (return (values nil t))))))
 167
 168 (!define-type-method (values :simple-=) (type1 type2)
 169   (let ((rest1 (args-type-rest type1))
 170         (rest2 (args-type-rest type2)))
 171     (cond ((or (args-type-keyp type1) (args-type-keyp type2)
 172                (args-type-allowp type1) (args-type-allowp type2))
 173            (values nil nil))
 174           ((and rest1 rest2 (type/= rest1 rest2))
 175            (type= rest1 rest2))
 176           ((or rest1 rest2)
 177            (values nil t))
 178           (t
 179            (multiple-value-bind (req-val req-win)
 180                (type=-list (values-type-required type1)
 181                            (values-type-required type2))
 182              (multiple-value-bind (opt-val opt-win)
 183                  (type=-list (values-type-optional type1)
 184                              (values-type-optional type2))
 185                (values (and req-val opt-val) (and req-win opt-win))))))))
 186
 187 (!define-type-class function)
 188
 189 ;;; a flag that we can bind to cause complex function types to be
 190 ;;; unparsed as FUNCTION. This is useful when we want a type that we
 191 ;;; can pass to TYPEP.
 192 (defvar *unparse-function-type-simplify*)
 193 (!cold-init-forms (setq *unparse-function-type-simplify* nil))
 194
 195 (!define-type-method (function :unparse) (type)
 196   (if *unparse-function-type-simplify*
 197       'function
 198       (list 'function
 199             (if (function-type-wild-args type)
 200                 '*
 201                 (unparse-args-types type))
 202             (type-specifier
 203              (function-type-returns type)))))
 204
 205 ;;; Since all function types are equivalent to FUNCTION, they are all
 206 ;;; subtypes of each other.
 207 (!define-type-method (function :simple-subtypep) (type1 type2)
 208   (declare (ignore type1 type2))
 209   (values t t))
 210
 211 (!define-superclasses function ((function)) !cold-init-forms)
 212
 213 ;;; The union or intersection of two FUNCTION types is FUNCTION.
 214 (!define-type-method (function :simple-union) (type1 type2)
 215   (declare (ignore type1 type2))
 216   (specifier-type 'function))
 217 (!define-type-method (function :simple-intersection) (type1 type2)
 218   (declare (ignore type1 type2))
 219   (values (specifier-type 'function) t))
 220
 221 ;;; ### Not very real, but good enough for redefining transforms
 222 ;;; according to type:
 223 (!define-type-method (function :simple-=) (type1 type2)
 224   (values (equalp type1 type2) t))
 225
 226 (!define-type-class constant :inherits values)
 227
 228 (!define-type-method (constant :unparse) (type)
 229   `(constant-argument ,(type-specifier (constant-type-type type))))
 230
 231 (!define-type-method (constant :simple-=) (type1 type2)
 232   (type= (constant-type-type type1) (constant-type-type type2)))
 233
 234 (!def-type-translator constant-argument (type)
 235   (make-constant-type :type (specifier-type type)))
 236
 237 ;;; Given a LAMBDA-LIST-like values type specification and an ARGS-TYPE
 238 ;;; structure, fill in the slots in the structure accordingly. This is
 239 ;;; used for both FUNCTION and VALUES types.
 240 (declaim (ftype (function (list args-type) (values)) parse-args-types))
 241 (defun parse-args-types (lambda-list result)
 242   (multiple-value-bind (required optional restp rest keyp keys allowp aux)
 243       (parse-lambda-list lambda-list)
 244     (when aux
 245       (error "&Aux in a FUNCTION or VALUES type: ~S." lambda-list))
 246     (setf (args-type-required result) (mapcar #'specifier-type required))
 247     (setf (args-type-optional result) (mapcar #'specifier-type optional))
 248     (setf (args-type-rest result) (if restp (specifier-type rest) nil))
 249     (setf (args-type-keyp result) keyp)
 250     (collect ((key-info))
 251       (dolist (key keys)
 252         (unless (proper-list-of-length-p key 2)
 253           (error "Keyword type description is not a two-list: ~S." key))
 254         (let ((kwd (first key)))
 255           (when (find kwd (key-info) :key #'key-info-name)
 256             (error "Repeated keyword ~S in lambda list: ~S." kwd lambda-list))
 257           (key-info (make-key-info :name kwd
 258                                    :type (specifier-type (second key))))))
 259       (setf (args-type-keywords result) (key-info)))
 260     (setf (args-type-allowp result) allowp)
 261     (values)))
 262
 263 ;;; Return the lambda-list-like type specification corresponding
 264 ;;; to an ARGS-TYPE.
 265 (declaim (ftype (function (args-type) list) unparse-args-types))
 266 (defun unparse-args-types (type)
 267   (collect ((result))
 268
 269     (dolist (arg (args-type-required type))
 270       (result (type-specifier arg)))
 271
 272     (when (args-type-optional type)
 273       (result '&optional)
 274       (dolist (arg (args-type-optional type))
 275         (result (type-specifier arg))))
 276
 277     (when (args-type-rest type)
 278       (result '&rest)
 279       (result (type-specifier (args-type-rest type))))
 280
 281     (when (args-type-keyp type)
 282       (result '&key)
 283       (dolist (key (args-type-keywords type))
 284         (result (list (key-info-name key)
 285                       (type-specifier (key-info-type key))))))
 286
 287     (when (args-type-allowp type)
 288       (result '&allow-other-keys))
 289
 290     (result)))
 291
 292 (!def-type-translator function (&optional (args '*) (result '*))
 293   (let ((res (make-function-type
 294               :returns (values-specifier-type result))))
 295     (if (eq args '*)
 296         (setf (function-type-wild-args res) t)
 297         (parse-args-types args res))
 298     res))
 299
 300 (!def-type-translator values (&rest values)
 301   (let ((res (make-values-type)))
 302     (parse-args-types values res)
 303     res))
 304 \f
 305 ;;;; VALUES types interfaces
 306 ;;;;
 307 ;;;; We provide a few special operations that can be meaningfully used
 308 ;;;; on VALUES types (as well as on any other type).
 309
 310 ;;; Return the type of the first value indicated by TYPE. This is used
 311 ;;; by people who don't want to have to deal with VALUES types.
 312 #!-sb-fluid (declaim (freeze-type values-type))
 313 ; (inline single-value-type))
 314 (defun single-value-type (type)
 315   (declare (type ctype type))
 316   (cond ((values-type-p type)
 317          (or (car (args-type-required type))
 318              (if (args-type-optional type)
 319                  (type-union (car (args-type-optional type))
 320                              (specifier-type 'null)))
 321              (args-type-rest type)
 322              (specifier-type 'null)))
 323         ((eq type *wild-type*)
 324          *universal-type*)
 325         (t
 326          type)))
 327
 328 ;;; Return the minmum number of arguments that a function can be
 329 ;;; called with, and the maximum number or NIL. If not a function
 330 ;;; type, return NIL, NIL.
 331 (defun function-type-nargs (type)
 332   (declare (type ctype type))
 333   (if (function-type-p type)
 334       (let ((fixed (length (args-type-required type))))
 335         (if (or (args-type-rest type)
 336                 (args-type-keyp type)
 337                 (args-type-allowp type))
 338             (values fixed nil)
 339             (values fixed (+ fixed (length (args-type-optional type))))))
 340       (values nil nil)))
 341
 342 ;;; Determine whether TYPE corresponds to a definite number of values.
 343 ;;; The first value is a list of the types for each value, and the
 344 ;;; second value is the number of values. If the number of values is
 345 ;;; not fixed, then return NIL and :UNKNOWN.
 346 (defun values-types (type)
 347   (declare (type ctype type))
 348   (cond ((eq type *wild-type*)
 349          (values nil :unknown))
 350         ((not (values-type-p type))
 351          (values (list type) 1))
 352         ((or (args-type-optional type)
 353              (args-type-rest type)
 354              (args-type-keyp type)
 355              (args-type-allowp type))
 356          (values nil :unknown))
 357         (t
 358          (let ((req (args-type-required type)))
 359            (values (mapcar #'single-value-type req) (length req))))))
 360
 361 ;;; Return two values:
 362 ;;; 1. A list of all the positional (fixed and optional) types.
 363 ;;; 2. The &REST type (if any). If keywords allowed, *UNIVERSAL-TYPE*.
 364 ;;;    If no keywords or &REST, then the DEFAULT-TYPE.
 365 (defun values-type-types (type &optional (default-type *empty-type*))
 366   (declare (type values-type type))
 367   (values (append (args-type-required type)
 368                   (args-type-optional type))
 369           (cond ((args-type-keyp type) *universal-type*)
 370                 ((args-type-rest type))
 371                 (t
 372                  default-type))))
 373
 374 ;;; Return a list of OPERATION applied to the types in TYPES1 and
 375 ;;; TYPES2, padding with REST2 as needed. TYPES1 must not be shorter
 376 ;;; than TYPES2. The second value is T if OPERATION always returned a
 377 ;;; true second value.
 378 (defun fixed-values-op (types1 types2 rest2 operation)
 379   (declare (list types1 types2) (type ctype rest2) (type function operation))
 380   (let ((exact t))
 381     (values (mapcar #'(lambda (t1 t2)
 382                         (multiple-value-bind (res win)
 383                             (funcall operation t1 t2)
 384                           (unless win
 385                             (setq exact nil))
 386                           res))
 387                     types1
 388                     (append types2
 389                             (make-list (- (length types1) (length types2))
 390                                        :initial-element rest2)))
 391             exact)))
 392
 393 ;;; If Type isn't a values type, then make it into one:
 394 ;;;    <type>  ==>  (values type &rest t)
 395 (defun coerce-to-values (type)
 396   (declare (type ctype type))
 397   (if (values-type-p type)
 398       type
 399       (make-values-type :required (list type) :rest *universal-type*)))
 400
 401 ;;; Do the specified OPERATION on TYPE1 and TYPE2, which may be any
 402 ;;; type, including VALUES types. With VALUES types such as:
 403 ;;;    (VALUES a0 a1)
 404 ;;;    (VALUES b0 b1)
 405 ;;; we compute the more useful result
 406 ;;;    (VALUES (<operation> a0 b0) (<operation> a1 b1))
 407 ;;; rather than the precise result
 408 ;;;    (<operation> (values a0 a1) (values b0 b1))
 409 ;;; This has the virtue of always keeping the VALUES type specifier
 410 ;;; outermost, and retains all of the information that is really
 411 ;;; useful for static type analysis. We want to know what is always
 412 ;;; true of each value independently. It is worthless to know that IF
 413 ;;; the first value is B0 then the second will be B1.
 414 ;;;
 415 ;;; If the VALUES count signatures differ, then we produce a result with
 416 ;;; the required VALUE count chosen by NREQ when applied to the number
 417 ;;; of required values in TYPE1 and TYPE2. Any &KEY values become
 418 ;;; &REST T (anyone who uses keyword values deserves to lose.)
 419 ;;;
 420 ;;; The second value is true if the result is definitely empty or if
 421 ;;; OPERATION returned true as its second value each time we called
 422 ;;; it. Since we approximate the intersection of VALUES types, the
 423 ;;; second value being true doesn't mean the result is exact.
 424 (defun args-type-op (type1 type2 operation nreq default-type)
 425   (declare (type ctype type1 type2 default-type)
 426            (type function operation nreq))
 427   (if (or (values-type-p type1) (values-type-p type2))
 428       (let ((type1 (coerce-to-values type1))
 429             (type2 (coerce-to-values type2)))
 430         (multiple-value-bind (types1 rest1)
 431             (values-type-types type1 default-type)
 432           (multiple-value-bind (types2 rest2)
 433               (values-type-types type2 default-type)
 434             (multiple-value-bind (rest rest-exact)
 435                 (funcall operation rest1 rest2)
 436               (multiple-value-bind (res res-exact)
 437                   (if (< (length types1) (length types2))
 438                       (fixed-values-op types2 types1 rest1 operation)
 439                       (fixed-values-op types1 types2 rest2 operation))
 440                 (let* ((req (funcall nreq
 441                                      (length (args-type-required type1))
 442                                      (length (args-type-required type2))))
 443                        (required (subseq res 0 req))
 444                        (opt (subseq res req))
 445                        (opt-last (position rest opt :test-not #'type=
 446                                            :from-end t)))
 447                   (if (find *empty-type* required :test #'type=)
 448                       (values *empty-type* t)
 449                       (values (make-values-type
 450                                :required required
 451                                :optional (if opt-last
 452                                              (subseq opt 0 (1+ opt-last))
 453                                              ())
 454                                :rest (if (eq rest default-type) nil rest))
 455                               (and rest-exact res-exact)))))))))
 456       (funcall operation type1 type2)))
 457
 458 ;;; Do a union or intersection operation on types that might be values
 459 ;;; types. The result is optimized for utility rather than exactness,
 460 ;;; but it is guaranteed that it will be no smaller (more restrictive)
 461 ;;; than the precise result.
 462 ;;;
 463 ;;; The return convention seems to be analogous to
 464 ;;; TYPES-INTERSECT. -- WHN 19990910.
 465 (defun-cached (values-type-union :hash-function type-cache-hash
 466                                  :hash-bits 8
 467                                  :default nil
 468                                  :init-wrapper !cold-init-forms)
 469               ((type1 eq) (type2 eq))
 470   (declare (type ctype type1 type2))
 471   (cond ((or (eq type1 *wild-type*) (eq type2 *wild-type*)) *wild-type*)
 472         ((eq type1 *empty-type*) type2)
 473         ((eq type2 *empty-type*) type1)
 474         (t
 475          (values (args-type-op type1 type2 #'type-union #'min *empty-type*)))))
 476 (defun-cached (values-type-intersection :hash-function type-cache-hash
 477                                         :hash-bits 8
 478                                         :values 2
 479                                         :default (values nil :empty)
 480                                         :init-wrapper !cold-init-forms)
 481               ((type1 eq) (type2 eq))
 482   (declare (type ctype type1 type2))
 483   (cond ((eq type1 *wild-type*) (values type2 t))
 484         ((eq type2 *wild-type*) (values type1 t))
 485         (t
 486          (args-type-op type1 type2
 487                        #'type-intersection
 488                        #'max
 489                        (specifier-type 'null)))))
 490
 491 ;;; This is like TYPES-INTERSECT, except that it sort of works on
 492 ;;; VALUES types. Note that due to the semantics of
 493 ;;; VALUES-TYPE-INTERSECTION, this might return (VALUES T T) when
 494 ;;; there isn't really any intersection (?).
 495 ;;;
 496 ;;; The return convention seems to be analogous to
 497 ;;; TYPES-INTERSECT. -- WHN 19990910.
 498 (defun values-types-intersect (type1 type2)
 499   (cond ((or (eq type1 *empty-type*) (eq type2 *empty-type*))
 500          (values 't t))
 501         ((or (values-type-p type1) (values-type-p type2))
 502          (multiple-value-bind (res win) (values-type-intersection type1 type2)
 503            (values (not (eq res *empty-type*))
 504                    win)))
 505         (t
 506          (types-intersect type1 type2))))
 507
 508 ;;; a SUBTYPEP-like operation that can be used on any types, including
 509 ;;; VALUES types
 510 (defun-cached (values-subtypep :hash-function type-cache-hash
 511                                :hash-bits 8
 512                                :values 2
 513                                :default (values nil :empty)
 514                                :init-wrapper !cold-init-forms)
 515               ((type1 eq) (type2 eq))
 516   (declare (type ctype type1 type2))
 517   (cond ((eq type2 *wild-type*) (values t t))
 518         ((eq type1 *wild-type*)
 519          (values (eq type2 *universal-type*) t))
 520         ((not (values-types-intersect type1 type2))
 521          (values nil t))
 522         (t
 523          (if (or (values-type-p type1) (values-type-p type2))
 524              (let ((type1 (coerce-to-values type1))
 525                    (type2 (coerce-to-values type2)))
 526                (multiple-value-bind (types1 rest1) (values-type-types type1)
 527                  (multiple-value-bind (types2 rest2) (values-type-types type2)
 528                    (cond ((< (length (values-type-required type1))
 529                              (length (values-type-required type2)))
 530                           (values nil t))
 531                          ((< (length types1) (length types2))
 532                           (values nil nil))
 533                          ((or (values-type-keyp type1)
 534                               (values-type-keyp type2))
 535                           (values nil nil))
 536                          (t
 537                           (do ((t1 types1 (rest t1))
 538                                (t2 types2 (rest t2)))
 539                               ((null t2)
 540                                (csubtypep rest1 rest2))
 541                             (multiple-value-bind (res win-p)
 542                                 (csubtypep (first t1) (first t2))
 543                               (unless win-p
 544                                 (return (values nil nil)))
 545                               (unless res
 546                                 (return (values nil t))))))))))
 547              (csubtypep type1 type2)))))
 548 \f
 549 ;;;; type method interfaces
 550
 551 ;;; like SUBTYPEP, only works on CTYPE structures
 552 (defun-cached (csubtypep :hash-function type-cache-hash
 553                          :hash-bits 8
 554                          :values 2
 555                          :default (values nil :empty)
 556                          :init-wrapper !cold-init-forms)
 557               ((type1 eq) (type2 eq))
 558   (declare (type ctype type1 type2))
 559   (cond ((or (eq type1 type2)
 560              (eq type1 *empty-type*)
 561              (eq type2 *wild-type*))
 562          (values t t))
 563         ((or (eq type1 *wild-type*)
 564              (eq type2 *empty-type*))
 565          (values nil t))
 566         (t
 567          (!invoke-type-method :simple-subtypep :complex-subtypep-arg2
 568                               type1 type2
 569                               :complex-arg1 :complex-subtypep-arg1))))
 570
 571 ;;; Just parse the type specifiers and call CSUBTYPE.
 572 (defun sb!xc:subtypep (type1 type2)
 573   #!+sb-doc
 574   "Return two values indicating the relationship between type1 and type2.
 575   If values are T and T, type1 definitely is a subtype of type2.
 576   If values are NIL and T, type1 definitely is not a subtype of type2.
 577   If values are NIL and NIL, it couldn't be determined."
 578   (csubtypep (specifier-type type1) (specifier-type type2)))
 579
 580 ;;; If two types are definitely equivalent, return true. The second
 581 ;;; value indicates whether the first value is definitely correct.
 582 ;;; This should only fail in the presence of HAIRY types.
 583 (defun-cached (type= :hash-function type-cache-hash
 584                      :hash-bits 8
 585                      :values 2
 586                      :default (values nil :empty)
 587                      :init-wrapper !cold-init-forms)
 588               ((type1 eq) (type2 eq))
 589   (declare (type ctype type1 type2))
 590   (if (eq type1 type2)
 591       (values t t)
 592       (!invoke-type-method :simple-= :complex-= type1 type2)))
 593
 594 ;;; Not exactly the negation of TYPE=, since when the relationship is
 595 ;;; uncertain, we still return NIL, NIL. This is useful in cases where
 596 ;;; the conservative assumption is =.
 597 (defun type/= (type1 type2)
 598   (declare (type ctype type1 type2))
 599   (multiple-value-bind (res win) (type= type1 type2)
 600     (if win
 601         (values (not res) t)
 602         (values nil nil))))
 603
 604 ;;; Find a type which includes both types. Any inexactness is
 605 ;;; represented by the fuzzy element types; we return a single value
 606 ;;; that is precise to the best of our knowledge. This result is
 607 ;;; simplified into the canonical form, thus is not a UNION type
 608 ;;; unless there is no other way to represent the result.
 609 (defun-cached (type-union :hash-function type-cache-hash
 610                           :hash-bits 8
 611                           :init-wrapper !cold-init-forms)
 612               ((type1 eq) (type2 eq))
 613   (declare (type ctype type1 type2))
 614   (if (eq type1 type2)
 615       type1
 616       (let ((res (!invoke-type-method :simple-union :complex-union
 617                                       type1 type2
 618                                       :default :vanilla)))
 619         (cond ((eq res :vanilla)
 620                (or (vanilla-union type1 type2)
 621                    (make-union-type (list type1 type2))))
 622               (res)
 623               (t
 624                (make-union-type (list type1 type2)))))))
 625
 626 ;;; Return as restrictive a type as we can discover that is no more
 627 ;;; restrictive than the intersection of Type1 and Type2. The second
 628 ;;; value is true if the result is exact. At worst, we randomly return
 629 ;;; one of the arguments as the first value (trying not to return a
 630 ;;; hairy type).
 631 (defun-cached (type-intersection :hash-function type-cache-hash
 632                                  :hash-bits 8
 633                                  :values 2
 634                                  :default (values nil :empty)
 635                                  :init-wrapper !cold-init-forms)
 636               ((type1 eq) (type2 eq))
 637   (declare (type ctype type1 type2))
 638   (if (eq type1 type2)
 639       (values type1 t)
 640       (!invoke-type-method :simple-intersection :complex-intersection
 641                            type1 type2
 642                            :default (values *empty-type* t))))
 643
 644 ;;; The first value is true unless the types don't intersect. The
 645 ;;; second value is true if the first value is definitely correct. NIL
 646 ;;; is considered to intersect with any type. If T is a subtype of
 647 ;;; either type, then we also return T, T. This way we consider hairy
 648 ;;; types to intersect with T.
 649 (defun types-intersect (type1 type2)
 650   (declare (type ctype type1 type2))
 651   (if (or (eq type1 *empty-type*) (eq type2 *empty-type*))
 652       (values t t)
 653       (multiple-value-bind (val winp) (type-intersection type1 type2)
 654         (cond ((not winp)
 655                (if (or (csubtypep *universal-type* type1)
 656                        (csubtypep *universal-type* type2))
 657                    (values t t)
 658                    (values t nil)))
 659               ((eq val *empty-type*) (values nil t))
 660               (t (values t t))))))
 661
 662 ;;; Return a Common Lisp type specifier corresponding to the TYPE
 663 ;;; object.
 664 (defun type-specifier (type)
 665   (declare (type ctype type))
 666   (funcall (type-class-unparse (type-class-info type)) type))
 667
 668 ;;; (VALUES-SPECIFIER-TYPE and SPECIFIER-TYPE moved from here to
 669 ;;; early-type.lisp by WHN ca. 19990201.)
 670
 671 ;;; Take a list of type specifiers, computing the translation of each
 672 ;;; specifier and defining it as a builtin type.
 673 (declaim (ftype (function (list) (values)) precompute-types))
 674 (defun precompute-types (specs)
 675   (dolist (spec specs)
 676     (let ((res (specifier-type spec)))
 677       (unless (unknown-type-p res)
 678         (setf (info :type :builtin spec) res)
 679         (setf (info :type :kind spec) :primitive))))
 680   (values))
 681 \f
 682 ;;;; built-in types
 683
 684 (!define-type-class named)
 685
 686 (defvar *wild-type*)
 687 (defvar *empty-type*)
 688 (defvar *universal-type*)
 689
 690 (!cold-init-forms
 691  (macrolet ((frob (name var)
 692               `(progn
 693                  (setq ,var (make-named-type :name ',name))
 694                  (setf (info :type :kind ',name) :primitive)
 695                  (setf (info :type :builtin ',name) ,var))))
 696    ;; KLUDGE: In ANSI, * isn't really the name of a type, it's just a
 697    ;; special symbol which can be stuck in some places where an
 698    ;; ordinary type can go, e.g. (ARRAY * 1) instead of (ARRAY T 1).
 699    ;; At some point, in order to become more standard, we should
 700    ;; convert all the classic CMU CL legacy *s and *WILD-TYPE*s into
 701    ;; Ts and *UNIVERSAL-TYPE*s.
 702    (frob * *wild-type*)
 703    (frob nil *empty-type*)
 704    (frob t *universal-type*)))
 705
 706 (!define-type-method (named :simple-=) (type1 type2)
 707   (values (eq type1 type2) t))
 708
 709 (!define-type-method (named :simple-subtypep) (type1 type2)
 710   (values (or (eq type1 *empty-type*) (eq type2 *wild-type*)) t))
 711
 712 (!define-type-method (named :complex-subtypep-arg1) (type1 type2)
 713   (assert (not (hairy-type-p type2)))
 714   (values (eq type1 *empty-type*) t))
 715
 716 (!define-type-method (named :complex-subtypep-arg2) (type1 type2)
 717   (if (hairy-type-p type1)
 718       (values nil nil)
 719       (values (not (eq type2 *empty-type*)) t)))
 720
 721 (!define-type-method (named :complex-intersection) (type1 type2)
 722   (vanilla-intersection type1 type2))
 723
 724 (!define-type-method (named :unparse) (x)
 725   (named-type-name x))
 726 \f
 727 ;;;; hairy and unknown types
 728
 729 (!define-type-method (hairy :unparse) (x) (hairy-type-specifier x))
 730
 731 (!define-type-method (hairy :simple-subtypep) (type1 type2)
 732   (let ((hairy-spec1 (hairy-type-specifier type1))
 733         (hairy-spec2 (hairy-type-specifier type2)))
 734     (cond ((and (consp hairy-spec1) (eq (car hairy-spec1) 'not)
 735                 (consp hairy-spec2) (eq (car hairy-spec2) 'not))
 736            (csubtypep (specifier-type (cadr hairy-spec2))
 737                       (specifier-type (cadr hairy-spec1))))
 738           ((equal hairy-spec1 hairy-spec2)
 739            (values t t))
 740           (t
 741            (values nil nil)))))
 742
 743 (!define-type-method (hairy :complex-subtypep-arg2) (type1 type2)
 744   (let ((hairy-spec (hairy-type-specifier type2)))
 745     (cond ((and (consp hairy-spec) (eq (car hairy-spec) 'not))
 746            (multiple-value-bind (val win)
 747                (type-intersection type1 (specifier-type (cadr hairy-spec)))
 748              (if win
 749                  (values (eq val *empty-type*) t)
 750                  (values nil nil))))
 751           (t
 752            (values nil nil)))))
 753
 754 (!define-type-method (hairy :complex-subtypep-arg1 :complex-=) (type1 type2)
 755   (declare (ignore type1 type2))
 756   (values nil nil))
 757
 758 (!define-type-method (hairy :simple-intersection :complex-intersection)
 759                     (type1 type2)
 760   (declare (ignore type2))
 761   (values type1 nil))
 762
 763 (!define-type-method (hairy :complex-union) (type1 type2)
 764   (make-union-type (list type1 type2)))
 765
 766 (!define-type-method (hairy :simple-=) (type1 type2)
 767   (if (equal (hairy-type-specifier type1)
 768              (hairy-type-specifier type2))
 769       (values t t)
 770       (values nil nil)))
 771
 772 (!def-type-translator not (&whole whole type)
 773   (declare (ignore type))
 774   (make-hairy-type :specifier whole))
 775
 776 (!def-type-translator satisfies (&whole whole fun)
 777   (declare (ignore fun))
 778   (make-hairy-type :specifier whole))
 779 \f
 780 ;;;; numeric types
 781
 782 ;;; A list of all the float formats, in order of decreasing precision.
 783 (eval-when (:compile-toplevel :load-toplevel :execute)
 784   (defparameter *float-formats*
 785     '(long-float double-float single-float short-float)))
 786
 787 ;;; The type of a float format.
 788 (deftype float-format () `(member ,@*float-formats*))
 789
 790 #!+negative-zero-is-not-zero
 791 (defun make-numeric-type (&key class format (complexp :real) low high
 792                                enumerable)
 793   (flet ((canonicalise-low-bound (x)
 794            ;; Canonicalise a low bound of (-0.0) to 0.0.
 795            (if (and (consp x) (floatp (car x)) (zerop (car x))
 796                     (minusp (float-sign (car x))))
 797                (float 0.0 (car x))
 798                x))
 799          (canonicalise-high-bound (x)
 800            ;; Canonicalise a high bound of (+0.0) to -0.0.
 801            (if (and (consp x) (floatp (car x)) (zerop (car x))
 802                     (plusp (float-sign (car x))))
 803                (float -0.0 (car x))
 804                x)))
 805     (%make-numeric-type :class class
 806                         :format format
 807                         :complexp complexp
 808                         :low (canonicalise-low-bound low)
 809                         :high (canonicalise-high-bound high)
 810                         :enumerable enumerable)))
 811
 812 (!define-type-class number)
 813
 814 (!define-type-method (number :simple-=) (type1 type2)
 815   (values
 816    (and (eq (numeric-type-class type1) (numeric-type-class type2))
 817         (eq (numeric-type-format type1) (numeric-type-format type2))
 818         (eq (numeric-type-complexp type1) (numeric-type-complexp type2))
 819         (equal (numeric-type-low type1) (numeric-type-low type2))
 820         (equal (numeric-type-high type1) (numeric-type-high type2)))
 821    t))
 822
 823 (!define-type-method (number :unparse) (type)
 824   (let* ((complexp (numeric-type-complexp type))
 825          (low (numeric-type-low type))
 826          (high (numeric-type-high type))
 827          (base (case (numeric-type-class type)
 828                  (integer 'integer)
 829                  (rational 'rational)
 830                  (float (or (numeric-type-format type) 'float))
 831                  (t 'real))))
 832     (let ((base+bounds
 833            (cond ((and (eq base 'integer) high low)
 834                   (let ((high-count (logcount high))
 835                         (high-length (integer-length high)))
 836                     (cond ((= low 0)
 837                            (cond ((= high 0) '(integer 0 0))
 838                                  ((= high 1) 'bit)
 839                                  ((and (= high-count high-length)
 840                                        (plusp high-length))
 841                                   `(unsigned-byte ,high-length))
 842                                  (t
 843                                   `(mod ,(1+ high)))))
 844                           ((and (= low sb!vm:*target-most-negative-fixnum*)
 845                                 (= high sb!vm:*target-most-positive-fixnum*))
 846                            'fixnum)
 847                           ((and (= low (lognot high))
 848                                 (= high-count high-length)
 849                                 (> high-count 0))
 850                            `(signed-byte ,(1+ high-length)))
 851                           (t
 852                            `(integer ,low ,high)))))
 853                  (high `(,base ,(or low '*) ,high))
 854                  (low
 855                   (if (and (eq base 'integer) (= low 0))
 856                       'unsigned-byte
 857                       `(,base ,low)))
 858                  (t base))))
 859       (ecase complexp
 860         (:real
 861          base+bounds)
 862         (:complex
 863          (if (eq base+bounds 'real)
 864              'complex
 865              `(complex ,base+bounds)))
 866         ((nil)
 867          (assert (eq base+bounds 'real))
 868          'number)))))
 869
 870 ;;; Return true if X is "less than or equal" to Y, taking open bounds
 871 ;;; into consideration. CLOSED is the predicate used to test the bound
 872 ;;; on a closed interval (e.g. <=), and OPEN is the predicate used on
 873 ;;; open bounds (e.g. <). Y is considered to be the outside bound, in
 874 ;;; the sense that if it is infinite (NIL), then the test succeeds,
 875 ;;; whereas if X is infinite, then the test fails (unless Y is also
 876 ;;; infinite).
 877 ;;;
 878 ;;; This is for comparing bounds of the same kind, e.g. upper and
 879 ;;; upper. Use NUMERIC-BOUND-TEST* for different kinds of bounds.
 880 #!-negative-zero-is-not-zero
 881 (defmacro numeric-bound-test (x y closed open)
 882   `(cond ((not ,y) t)
 883          ((not ,x) nil)
 884          ((consp ,x)
 885           (if (consp ,y)
 886               (,closed (car ,x) (car ,y))
 887               (,closed (car ,x) ,y)))
 888          (t
 889           (if (consp ,y)
 890               (,open ,x (car ,y))
 891               (,closed ,x ,y)))))
 892
 893 #!+negative-zero-is-not-zero
 894 (defmacro numeric-bound-test-zero (op x y)
 895   `(if (and (zerop ,x) (zerop ,y) (floatp ,x) (floatp ,y))
 896        (,op (float-sign ,x) (float-sign ,y))
 897        (,op ,x ,y)))
 898
 899 #!+negative-zero-is-not-zero
 900 (defmacro numeric-bound-test (x y closed open)
 901   `(cond ((not ,y) t)
 902          ((not ,x) nil)
 903          ((consp ,x)
 904           (if (consp ,y)
 905               (numeric-bound-test-zero ,closed (car ,x) (car ,y))
 906               (numeric-bound-test-zero ,closed (car ,x) ,y)))
 907          (t
 908           (if (consp ,y)
 909               (numeric-bound-test-zero ,open ,x (car ,y))
 910               (numeric-bound-test-zero ,closed ,x ,y)))))
 911
 912 ;;; This is used to compare upper and lower bounds. This is different
 913 ;;; from the same-bound case:
 914 ;;; -- Since X = NIL is -infinity, whereas y = NIL is +infinity, we
 915 ;;;    return true if *either* arg is NIL.
 916 ;;; -- an open inner bound is "greater" and also squeezes the interval,
 917 ;;;    causing us to use the OPEN test for those cases as well.
 918 #!-negative-zero-is-not-zero
 919 (defmacro numeric-bound-test* (x y closed open)
 920   `(cond ((not ,y) t)
 921          ((not ,x) t)
 922          ((consp ,x)
 923           (if (consp ,y)
 924               (,open (car ,x) (car ,y))
 925               (,open (car ,x) ,y)))
 926          (t
 927           (if (consp ,y)
 928               (,open ,x (car ,y))
 929               (,closed ,x ,y)))))
 930
 931 #!+negative-zero-is-not-zero
 932 (defmacro numeric-bound-test* (x y closed open)
 933   `(cond ((not ,y) t)
 934          ((not ,x) t)
 935          ((consp ,x)
 936           (if (consp ,y)
 937               (numeric-bound-test-zero ,open (car ,x) (car ,y))
 938               (numeric-bound-test-zero ,open (car ,x) ,y)))
 939          (t
 940           (if (consp ,y)
 941               (numeric-bound-test-zero ,open ,x (car ,y))
 942               (numeric-bound-test-zero ,closed ,x ,y)))))
 943
 944 ;;; Return whichever of the numeric bounds X and Y is "maximal"
 945 ;;; according to the predicates CLOSED (e.g. >=) and OPEN (e.g. >).
 946 ;;; This is only meaningful for maximizing like bounds, i.e. upper and
 947 ;;; upper. If MAX-P is true, then we return NIL if X or Y is NIL,
 948 ;;; otherwise we return the other arg.
 949 (defmacro numeric-bound-max (x y closed open max-p)
 950   (once-only ((n-x x)
 951               (n-y y))
 952     `(cond ((not ,n-x) ,(if max-p nil n-y))
 953            ((not ,n-y) ,(if max-p nil n-x))
 954            ((consp ,n-x)
 955             (if (consp ,n-y)
 956                 (if (,closed (car ,n-x) (car ,n-y)) ,n-x ,n-y)
 957                 (if (,open (car ,n-x) ,n-y) ,n-x ,n-y)))
 958            (t
 959             (if (consp ,n-y)
 960                 (if (,open (car ,n-y) ,n-x) ,n-y ,n-x)
 961                 (if (,closed ,n-y ,n-x) ,n-y ,n-x))))))
 962
 963 (!define-type-method (number :simple-subtypep) (type1 type2)
 964   (let ((class1 (numeric-type-class type1))
 965         (class2 (numeric-type-class type2))
 966         (complexp2 (numeric-type-complexp type2))
 967         (format2 (numeric-type-format type2))
 968         (low1 (numeric-type-low type1))
 969         (high1 (numeric-type-high type1))
 970         (low2 (numeric-type-low type2))
 971         (high2 (numeric-type-high type2)))
 972     ;; If one is complex and the other isn't, they are disjoint.
 973     (cond ((not (or (eq (numeric-type-complexp type1) complexp2)
 974                     (null complexp2)))
 975            (values nil t))
 976           ;; If the classes are specified and different, the types are
 977           ;; disjoint unless type2 is rational and type1 is integer.
 978           ((not (or (eq class1 class2)
 979                     (null class2)
 980                     (and (eq class1 'integer)
 981                          (eq class2 'rational))))
 982            (values nil t))
 983           ;; If the float formats are specified and different, the types
 984           ;; are disjoint.
 985           ((not (or (eq (numeric-type-format type1) format2)
 986                     (null format2)))
 987            (values nil t))
 988           ;; Check the bounds.
 989           ((and (numeric-bound-test low1 low2 >= >)
 990                 (numeric-bound-test high1 high2 <= <))
 991            (values t t))
 992           (t
 993            (values nil t)))))
 994
 995 (!define-superclasses number ((generic-number)) !cold-init-forms)
 996
 997 ;;; If the high bound of LOW is adjacent to the low bound of HIGH,
 998 ;;; then return true, otherwise NIL.
 999 (defun numeric-types-adjacent (low high)
1000   (let ((low-bound (numeric-type-high low))
1001         (high-bound (numeric-type-low high)))
1002     (cond ((not (and low-bound high-bound)) nil)
1003           ((and (consp low-bound) (consp high-bound)) nil)
1004           ((consp low-bound)
1005            #!-negative-zero-is-not-zero
1006            (let ((low-value (car low-bound)))
1007              (or (eql low-value high-bound)
1008                  (and (eql low-value -0f0) (eql high-bound 0f0))
1009                  (and (eql low-value 0f0) (eql high-bound -0f0))
1010                  (and (eql low-value -0d0) (eql high-bound 0d0))
1011                  (and (eql low-value 0d0) (eql high-bound -0d0))))
1012            #!+negative-zero-is-not-zero
1013            (eql (car low-bound) high-bound))
1014           ((consp high-bound)
1015            #!-negative-zero-is-not-zero
1016            (let ((high-value (car high-bound)))
1017              (or (eql high-value low-bound)
1018                  (and (eql high-value -0f0) (eql low-bound 0f0))
1019                  (and (eql high-value 0f0) (eql low-bound -0f0))
1020                  (and (eql high-value -0d0) (eql low-bound 0d0))
1021                  (and (eql high-value 0d0) (eql low-bound -0d0))))
1022            #!+negative-zero-is-not-zero
1023            (eql (car high-bound) low-bound))
1024           #!+negative-zero-is-not-zero
1025           ((or (and (eql low-bound -0f0) (eql high-bound 0f0))
1026                (and (eql low-bound -0d0) (eql high-bound 0d0))))
1027           ((and (eq (numeric-type-class low) 'integer)
1028                 (eq (numeric-type-class high) 'integer))
1029            (eql (1+ low-bound) high-bound))
1030           (t
1031            nil))))
1032
1033 ;;; Return a numeric type that is a supertype for both TYPE1 and TYPE2.
1034 ;;;
1035 ;;; ### Note: we give up early to keep from dropping lots of information on
1036 ;;; the floor by returning overly general types.
1037 (!define-type-method (number :simple-union) (type1 type2)
1038   (declare (type numeric-type type1 type2))
1039   (cond ((csubtypep type1 type2) type2)
1040         ((csubtypep type2 type1) type1)
1041         (t
1042          (let ((class1 (numeric-type-class type1))
1043                (format1 (numeric-type-format type1))
1044                (complexp1 (numeric-type-complexp type1))
1045                (class2 (numeric-type-class type2))
1046                (format2 (numeric-type-format type2))
1047                (complexp2 (numeric-type-complexp type2)))
1048            (when (and (eq class1 class2)
1049                       (eq format1 format2)
1050                       (eq complexp1 complexp2)
1051                       (or (numeric-types-intersect type1 type2)
1052                           (numeric-types-adjacent type1 type2)
1053                           (numeric-types-adjacent type2 type1)))
1054              (make-numeric-type
1055               :class class1
1056               :format format1
1057               :complexp complexp1
1058               :low (numeric-bound-max (numeric-type-low type1)
1059                                       (numeric-type-low type2)
1060                                       <= < t)
1061               :high (numeric-bound-max (numeric-type-high type1)
1062                                        (numeric-type-high type2)
1063                                        >= > t)))))))
1064
1065 (!cold-init-forms
1066   (setf (info :type :kind 'number) :primitive)
1067   (setf (info :type :builtin 'number)
1068         (make-numeric-type :complexp nil)))
1069
1070 (!def-type-translator complex (&optional (spec '*))
1071   (if (eq spec '*)
1072       (make-numeric-type :complexp :complex)
1073       (let ((type (specifier-type spec)))
1074         (unless (numeric-type-p type)
1075           (error "Component type for Complex is not numeric: ~S." spec))
1076         (when (eq (numeric-type-complexp type) :complex)
1077           (error "Component type for Complex is complex: ~S." spec))
1078         (let ((res (copy-numeric-type type)))
1079           (setf (numeric-type-complexp res) :complex)
1080           res))))
1081
1082 ;;; If X is *, return NIL, otherwise return the bound, which must be a
1083 ;;; member of TYPE or a one-element list of a member of TYPE.
1084 #!-sb-fluid (declaim (inline canonicalized-bound))
1085 (defun canonicalized-bound (bound type)
1086   (cond ((eq bound '*) nil)
1087         ((or (sb!xc:typep bound type)
1088              (and (consp bound)
1089                   (sb!xc:typep (car bound) type)
1090                   (null (cdr bound))))
1091           bound)
1092         (t
1093          (error "Bound is not ~S, a ~S or a list of a ~S: ~S"
1094                 '*
1095                 type
1096                 type
1097                 bound))))
1098
1099 (!def-type-translator integer (&optional (low '*) (high '*))
1100   (let* ((l (canonicalized-bound low 'integer))
1101          (lb (if (consp l) (1+ (car l)) l))
1102          (h (canonicalized-bound high 'integer))
1103          (hb (if (consp h) (1- (car h)) h)))
1104     (when (and hb lb (< hb lb))
1105       (error "Lower bound ~S is greater than upper bound ~S." l h))
1106     (make-numeric-type :class 'integer
1107                        :complexp :real
1108                        :enumerable (not (null (and l h)))
1109                        :low lb
1110                        :high hb)))
1111
1112 (defmacro def-bounded-type (type class format)
1113   `(!def-type-translator ,type (&optional (low '*) (high '*))
1114      (let ((lb (canonicalized-bound low ',type))
1115            (hb (canonicalized-bound high ',type)))
1116        (unless (numeric-bound-test* lb hb <= <)
1117          (error "Lower bound ~S is not less than upper bound ~S." low high))
1118        (make-numeric-type :class ',class :format ',format :low lb :high hb))))
1119
1120 (def-bounded-type rational rational nil)
1121 (def-bounded-type float float nil)
1122 (def-bounded-type real nil nil)
1123
1124 (defmacro define-float-format (f)
1125   `(def-bounded-type ,f float ,f))
1126
1127 (define-float-format short-float)
1128 (define-float-format single-float)
1129 (define-float-format double-float)
1130 (define-float-format long-float)
1131
1132 (defun numeric-types-intersect (type1 type2)
1133   (declare (type numeric-type type1 type2))
1134   (let* ((class1 (numeric-type-class type1))
1135          (class2 (numeric-type-class type2))
1136          (complexp1 (numeric-type-complexp type1))
1137          (complexp2 (numeric-type-complexp type2))
1138          (format1 (numeric-type-format type1))
1139          (format2 (numeric-type-format type2))
1140          (low1 (numeric-type-low type1))
1141          (high1 (numeric-type-high type1))
1142          (low2 (numeric-type-low type2))
1143          (high2 (numeric-type-high type2)))
1144     ;; If one is complex and the other isn't, then they are disjoint.
1145     (cond ((not (or (eq complexp1 complexp2)
1146                     (null complexp1) (null complexp2)))
1147            nil)
1148           ;; If either type is a float, then the other must either be
1149           ;; specified to be a float or unspecified. Otherwise, they
1150           ;; are disjoint.
1151           ((and (eq class1 'float)
1152                 (not (member class2 '(float nil)))) nil)
1153           ((and (eq class2 'float)
1154                 (not (member class1 '(float nil)))) nil)
1155           ;; If the float formats are specified and different, the
1156           ;; types are disjoint.
1157           ((not (or (eq format1 format2) (null format1) (null format2)))
1158            nil)
1159           (t
1160            ;; Check the bounds. This is a bit odd because we must
1161            ;; always have the outer bound of the interval as the
1162            ;; second arg.
1163            (if (numeric-bound-test high1 high2 <= <)
1164                (or (and (numeric-bound-test low1 low2 >= >)
1165                         (numeric-bound-test* low1 high2 <= <))
1166                    (and (numeric-bound-test low2 low1 >= >)
1167                         (numeric-bound-test* low2 high1 <= <)))
1168                (or (and (numeric-bound-test* low2 high1 <= <)
1169                         (numeric-bound-test low2 low1 >= >))
1170                    (and (numeric-bound-test high2 high1 <= <)
1171                         (numeric-bound-test* high2 low1 >= >))))))))
1172
1173 ;;; Take the numeric bound X and convert it into something that can be
1174 ;;; used as a bound in a numeric type with the specified CLASS and
1175 ;;; FORMAT. If UP-P is true, then we round up as needed, otherwise we
1176 ;;; round down. UP-P true implies that X is a lower bound, i.e. (N) > N.
1177 ;;;
1178 ;;; This is used by NUMERIC-TYPE-INTERSECTION to mash the bound into
1179 ;;; the appropriate type number. X may only be a float when CLASS is
1180 ;;; FLOAT.
1181 ;;;
1182 ;;; ### Note: it is possible for the coercion to a float to overflow
1183 ;;; or underflow. This happens when the bound doesn't fit in the
1184 ;;; specified format. In this case, we should really return the
1185 ;;; appropriate {Most | Least}-{Positive | Negative}-XXX-Float float
1186 ;;; of desired format. But these conditions aren't currently signalled
1187 ;;; in any useful way.
1188 ;;;
1189 ;;; Also, when converting an open rational bound into a float we
1190 ;;; should probably convert it to a closed bound of the closest float
1191 ;;; in the specified format. KLUDGE: In general, open float bounds are
1192 ;;; screwed up. -- (comment from original CMU CL)
1193 (defun round-numeric-bound (x class format up-p)
1194   (if x
1195       (let ((cx (if (consp x) (car x) x)))
1196         (ecase class
1197           ((nil rational) x)
1198           (integer
1199            (if (and (consp x) (integerp cx))
1200                (if up-p (1+ cx) (1- cx))
1201                (if up-p (ceiling cx) (floor cx))))
1202           (float
1203            (let ((res (if format (coerce cx format) (float cx))))
1204              (if (consp x) (list res) res)))))
1205       nil))
1206
1207 ;;; Handle the case of TYPE-INTERSECTION on two numeric types. We use
1208 ;;; TYPES-INTERSECT to throw out the case of types with no
1209 ;;; intersection. If an attribute in TYPE1 is unspecified, then we use
1210 ;;; TYPE2's attribute, which must be at least as restrictive. If the
1211 ;;; types intersect, then the only attributes that can be specified
1212 ;;; and different are the class and the bounds.
1213 ;;;
1214 ;;; When the class differs, we use the more restrictive class. The
1215 ;;; only interesting case is RATIONAL/INTEGER, since RATIONAL includes
1216 ;;; INTEGER.
1217 ;;;
1218 ;;; We make the result lower (upper) bound the maximum (minimum) of
1219 ;;; the argument lower (upper) bounds. We convert the bounds into the
1220 ;;; appropriate numeric type before maximizing. This avoids possible
1221 ;;; confusion due to mixed-type comparisons (but I think the result is
1222 ;;; the same).
1223 (!define-type-method (number :simple-intersection) (type1 type2)
1224   (declare (type numeric-type type1 type2))
1225   (if (numeric-types-intersect type1 type2)
1226       (let* ((class1 (numeric-type-class type1))
1227              (class2 (numeric-type-class type2))
1228              (class (ecase class1
1229                       ((nil) class2)
1230                       ((integer float) class1)
1231                       (rational (if (eq class2 'integer)
1232                                        'integer
1233                                        'rational))))
1234              (format (or (numeric-type-format type1)
1235                          (numeric-type-format type2))))
1236         (values
1237          (make-numeric-type
1238           :class class
1239           :format format
1240           :complexp (or (numeric-type-complexp type1)
1241                         (numeric-type-complexp type2))
1242           :low (numeric-bound-max
1243                 (round-numeric-bound (numeric-type-low type1)
1244                                      class format t)
1245                 (round-numeric-bound (numeric-type-low type2)
1246                                      class format t)
1247                 > >= nil)
1248           :high (numeric-bound-max
1249                  (round-numeric-bound (numeric-type-high type1)
1250                                       class format nil)
1251                  (round-numeric-bound (numeric-type-high type2)
1252                                       class format nil)
1253                  < <= nil))
1254          t))
1255       (values *empty-type* t)))
1256
1257 ;;; Given two float formats, return the one with more precision. If
1258 ;;; either one is null, return NIL.
1259 (defun float-format-max (f1 f2)
1260   (when (and f1 f2)
1261     (dolist (f *float-formats* (error "bad float format: ~S" f1))
1262       (when (or (eq f f1) (eq f f2))
1263         (return f)))))
1264
1265 ;;; Return the result of an operation on TYPE1 and TYPE2 according to
1266 ;;; the rules of numeric contagion. This is always NUMBER, some float
1267 ;;; format (possibly complex) or RATIONAL. Due to rational
1268 ;;; canonicalization, there isn't much we can do here with integers or
1269 ;;; rational complex numbers.
1270 ;;;
1271 ;;; If either argument is not a NUMERIC-TYPE, then return NUMBER. This
1272 ;;; is useful mainly for allowing types that are technically numbers,
1273 ;;; but not a NUMERIC-TYPE.
1274 (defun numeric-contagion (type1 type2)
1275   (if (and (numeric-type-p type1) (numeric-type-p type2))
1276       (let ((class1 (numeric-type-class type1))
1277             (class2 (numeric-type-class type2))
1278             (format1 (numeric-type-format type1))
1279             (format2 (numeric-type-format type2))
1280             (complexp1 (numeric-type-complexp type1))
1281             (complexp2 (numeric-type-complexp type2)))
1282         (cond ((or (null complexp1)
1283                    (null complexp2))
1284                (specifier-type 'number))
1285               ((eq class1 'float)
1286                (make-numeric-type
1287                 :class 'float
1288                 :format (ecase class2
1289                           (float (float-format-max format1 format2))
1290                           ((integer rational) format1)
1291                           ((nil)
1292                            ;; A double-float with any real number is a
1293                            ;; double-float.
1294                            #!-long-float
1295                            (if (eq format1 'double-float)
1296                              'double-float
1297                              nil)
1298                            ;; A long-float with any real number is a
1299                            ;; long-float.
1300                            #!+long-float
1301                            (if (eq format1 'long-float)
1302                              'long-float
1303                              nil)))
1304                 :complexp (if (or (eq complexp1 :complex)
1305                                   (eq complexp2 :complex))
1306                               :complex
1307                               :real)))
1308               ((eq class2 'float) (numeric-contagion type2 type1))
1309               ((and (eq complexp1 :real) (eq complexp2 :real))
1310                (make-numeric-type
1311                 :class (and class1 class2 'rational)
1312                 :complexp :real))
1313               (t
1314                (specifier-type 'number))))
1315       (specifier-type 'number)))
1316 \f
1317 ;;;; array types
1318
1319 (!define-type-class array)
1320
1321 ;;; What this does depends on the setting of the
1322 ;;; *USE-IMPLEMENTATION-TYPES* switch. If true, return the specialized
1323 ;;; element type, otherwise return the original element type.
1324 (defun specialized-element-type-maybe (type)
1325   (declare (type array-type type))
1326   (if *use-implementation-types*
1327       (array-type-specialized-element-type type)
1328       (array-type-element-type type)))
1329
1330 (!define-type-method (array :simple-=) (type1 type2)
1331   (values (and (equal (array-type-dimensions type1)
1332                       (array-type-dimensions type2))
1333                (eq (array-type-complexp type1)
1334                    (array-type-complexp type2))
1335                (type= (specialized-element-type-maybe type1)
1336                       (specialized-element-type-maybe type2)))
1337           t))
1338
1339 (!define-type-method (array :unparse) (type)
1340   (let ((dims (array-type-dimensions type))
1341         (eltype (type-specifier (array-type-element-type type)))
1342         (complexp (array-type-complexp type)))
1343     (cond ((eq dims '*)
1344            (if (eq eltype '*)
1345                (if complexp 'array 'simple-array)
1346                (if complexp `(array ,eltype) `(simple-array ,eltype))))
1347           ((= (length dims) 1)
1348            (if complexp
1349                (if (eq (car dims) '*)
1350                    (case eltype
1351                      (bit 'bit-vector)
1352                      (base-char 'base-string)
1353                      (character 'string)
1354                      (* 'vector)
1355                      (t `(vector ,eltype)))
1356                    (case eltype
1357                      (bit `(bit-vector ,(car dims)))
1358                      (base-char `(base-string ,(car dims)))
1359                      (character `(string ,(car dims)))
1360                      (t `(vector ,eltype ,(car dims)))))
1361                (if (eq (car dims) '*)
1362                    (case eltype
1363                      (bit 'simple-bit-vector)
1364                      (base-char 'simple-base-string)
1365                      (character 'simple-string)
1366                      ((t) 'simple-vector)
1367                      (t `(simple-array ,eltype (*))))
1368                    (case eltype
1369                      (bit `(simple-bit-vector ,(car dims)))
1370                      (base-char `(simple-base-string ,(car dims)))
1371                      (character `(simple-string ,(car dims)))
1372                      ((t) `(simple-vector ,(car dims)))
1373                      (t `(simple-array ,eltype ,dims))))))
1374           (t
1375            (if complexp
1376                `(array ,eltype ,dims)
1377                `(simple-array ,eltype ,dims))))))
1378
1379 (!define-type-method (array :simple-subtypep) (type1 type2)
1380   (let ((dims1 (array-type-dimensions type1))
1381         (dims2 (array-type-dimensions type2))
1382         (complexp2 (array-type-complexp type2)))
1383     ;; See whether dimensions are compatible.
1384     (cond ((not (or (eq dims2 '*)
1385                     (and (not (eq dims1 '*))
1386                          ;; (sbcl-0.6.4 has trouble figuring out that
1387                          ;; DIMS1 and DIMS2 must be lists at this
1388                          ;; point, and knowing that is important to
1389                          ;; compiling EVERY efficiently.)
1390                          (= (length (the list dims1))
1391                             (length (the list dims2)))
1392                          (every (lambda (x y)
1393                                   (or (eq y '*) (eql x y)))
1394                                 (the list dims1)
1395                                 (the list dims2)))))
1396            (values nil t))
1397           ;; See whether complexpness is compatible.
1398           ((not (or (eq complexp2 :maybe)
1399                     (eq (array-type-complexp type1) complexp2)))
1400            (values nil t))
1401           ;; If the TYPE2 eltype is wild, we win. Otherwise, the types
1402           ;; must be identical.
1403           ((or (eq (array-type-element-type type2) *wild-type*)
1404                (type= (specialized-element-type-maybe type1)
1405                       (specialized-element-type-maybe type2)))
1406            (values t t))
1407           (t
1408            (values nil t)))))
1409
1410 (!define-superclasses array
1411   ((string string)
1412    (vector vector)
1413    (array))
1414   !cold-init-forms)
1415
1416 (defun array-types-intersect (type1 type2)
1417   (declare (type array-type type1 type2))
1418   (let ((dims1 (array-type-dimensions type1))
1419         (dims2 (array-type-dimensions type2))
1420         (complexp1 (array-type-complexp type1))
1421         (complexp2 (array-type-complexp type2)))
1422     ;; See whether dimensions are compatible.
1423     (cond ((not (or (eq dims1 '*) (eq dims2 '*)
1424                     (and (= (length dims1) (length dims2))
1425                          (every #'(lambda (x y)
1426                                     (or (eq x '*) (eq y '*) (= x y)))
1427                                 dims1 dims2))))
1428            (values nil t))
1429           ;; See whether complexpness is compatible.
1430           ((not (or (eq complexp1 :maybe)
1431                     (eq complexp2 :maybe)
1432                     (eq complexp1 complexp2)))
1433            (values nil t))
1434           ;; If either element type is wild, then they intersect.
1435           ;; Otherwise, the types must be identical.
1436           ((or (eq (array-type-element-type type1) *wild-type*)
1437                (eq (array-type-element-type type2) *wild-type*)
1438                (type= (specialized-element-type-maybe type1)
1439                       (specialized-element-type-maybe type2)))
1440
1441            (values t t))
1442           (t
1443            (values nil t)))))
1444
1445 (!define-type-method (array :simple-intersection) (type1 type2)
1446   (declare (type array-type type1 type2))
1447   (if (array-types-intersect type1 type2)
1448       (let ((dims1 (array-type-dimensions type1))
1449             (dims2 (array-type-dimensions type2))
1450             (complexp1 (array-type-complexp type1))
1451             (complexp2 (array-type-complexp type2))
1452             (eltype1 (array-type-element-type type1))
1453             (eltype2 (array-type-element-type type2)))
1454         (values
1455          (specialize-array-type
1456           (make-array-type
1457            :dimensions (cond ((eq dims1 '*) dims2)
1458                              ((eq dims2 '*) dims1)
1459                              (t
1460                               (mapcar (lambda (x y) (if (eq x '*) y x))
1461                                       dims1 dims2)))
1462            :complexp (if (eq complexp1 :maybe) complexp2 complexp1)
1463            :element-type (if (eq eltype1 *wild-type*) eltype2 eltype1)))
1464          t))
1465       (values *empty-type* t)))
1466
1467 ;;; Check a supplied dimension list to determine whether it is legal,
1468 ;;; and return it in canonical form (as either '* or a list).
1469 (defun canonical-array-dimensions (dims)
1470   (typecase dims
1471     ((member *) dims)
1472     (integer
1473      (when (minusp dims)
1474        (error "Arrays can't have a negative number of dimensions: ~S" dims))
1475      (when (>= dims sb!xc:array-rank-limit)
1476        (error "array type with too many dimensions: ~S" dims))
1477      (make-list dims :initial-element '*))
1478     (list
1479      (when (>= (length dims) sb!xc:array-rank-limit)
1480        (error "array type with too many dimensions: ~S" dims))
1481      (dolist (dim dims)
1482        (unless (eq dim '*)
1483          (unless (and (integerp dim)
1484                       (>= dim 0)
1485                       (< dim sb!xc:array-dimension-limit))
1486            (error "bad dimension in array type: ~S" dim))))
1487      dims)
1488     (t
1489      (error "Array dimensions is not a list, integer or *:~%  ~S" dims))))
1490 \f
1491 ;;;; MEMBER types
1492
1493 (!define-type-class member)
1494
1495 (!define-type-method (member :unparse) (type)
1496   (let ((members (member-type-members type)))
1497     (if (equal members '(nil))
1498         'null
1499         `(member ,@members))))
1500
1501 (!define-type-method (member :simple-subtypep) (type1 type2)
1502   (values (subsetp (member-type-members type1) (member-type-members type2))
1503           t))
1504
1505 (!define-type-method (member :complex-subtypep-arg1) (type1 type2)
1506   (block PUNT
1507     (values (every-type-op ctypep type2 (member-type-members type1)
1508                            :list-first t)
1509             t)))
1510
1511 ;;; We punt if the odd type is enumerable and intersects with the
1512 ;;; MEMBER type. If not enumerable, then it is definitely not a
1513 ;;; subtype of the MEMBER type.
1514 (!define-type-method (member :complex-subtypep-arg2) (type1 type2)
1515   (cond ((not (type-enumerable type1)) (values nil t))
1516         ((types-intersect type1 type2) (values nil nil))
1517         (t
1518          (values nil t))))
1519
1520 (!define-type-method (member :simple-intersection) (type1 type2)
1521   (let ((mem1 (member-type-members type1))
1522         (mem2 (member-type-members type2)))
1523     (values (cond ((subsetp mem1 mem2) type1)
1524                   ((subsetp mem2 mem1) type2)
1525                   (t
1526                    (let ((res (intersection mem1 mem2)))
1527                      (if res
1528                          (make-member-type :members res)
1529                          *empty-type*))))
1530             t)))
1531
1532 (!define-type-method (member :complex-intersection) (type1 type2)
1533   (block PUNT
1534     (collect ((members))
1535       (let ((mem2 (member-type-members type2)))
1536         (dolist (member mem2)
1537           (multiple-value-bind (val win) (ctypep member type1)
1538             (unless win
1539               (return-from PUNT (values type2 nil)))
1540             (when val (members member))))
1541
1542         (values (cond ((subsetp mem2 (members)) type2)
1543                       ((null (members)) *empty-type*)
1544                       (t
1545                        (make-member-type :members (members))))
1546                 t)))))
1547
1548 ;;; We don't need a :COMPLEX-UNION, since the only interesting case is a union
1549 ;;; type, and the member/union interaction is handled by the union type
1550 ;;; method.
1551 (!define-type-method (member :simple-union) (type1 type2)
1552   (let ((mem1 (member-type-members type1))
1553         (mem2 (member-type-members type2)))
1554     (cond ((subsetp mem1 mem2) type2)
1555           ((subsetp mem2 mem1) type1)
1556           (t
1557            (make-member-type :members (union mem1 mem2))))))
1558
1559 (!define-type-method (member :simple-=) (type1 type2)
1560   (let ((mem1 (member-type-members type1))
1561         (mem2 (member-type-members type2)))
1562     (values (and (subsetp mem1 mem2) (subsetp mem2 mem1))
1563             t)))
1564
1565 (!define-type-method (member :complex-=) (type1 type2)
1566   (if (type-enumerable type1)
1567       (multiple-value-bind (val win) (csubtypep type2 type1)
1568         (if (or val (not win))
1569             (values nil nil)
1570             (values nil t)))
1571       (values nil t)))
1572
1573 (!def-type-translator member (&rest members)
1574   (if members
1575     (make-member-type :members (remove-duplicates members))
1576     *empty-type*))
1577 \f
1578 ;;;; union types
1579
1580 ;;; Make a union type from the specifier types, setting ENUMERABLE in
1581 ;;; the result if all are enumerable.
1582 (defun make-union-type (types)
1583   (declare (list types))
1584   (%make-union-type (every #'type-enumerable types) types))
1585
1586 (!define-type-class union)
1587
1588 ;;; If LIST, then return that, otherwise the OR of the component types.
1589 (!define-type-method (union :unparse) (type)
1590   (declare (type ctype type))
1591   (if (type= type (specifier-type 'list))
1592       'list
1593       `(or ,@(mapcar #'type-specifier (union-type-types type)))))
1594
1595 ;;; Two union types are equal if every type in one is equal to some
1596 ;;; type in the other.
1597 (!define-type-method (union :simple-=) (type1 type2)
1598   (block PUNT
1599     (let ((types1 (union-type-types type1))
1600           (types2 (union-type-types type2)))
1601       (values (and (dolist (type1 types1 t)
1602                      (unless (any-type-op type= type1 types2)
1603                        (return nil)))
1604                    (dolist (type2 types2 t)
1605                      (unless (any-type-op type= type2 types1)
1606                        (return nil))))
1607               t))))
1608
1609 ;;; Similarly, a union type is a subtype of another if every element
1610 ;;; of TYPE1 is a subtype of some element of TYPE2.
1611 (!define-type-method (union :simple-subtypep) (type1 type2)
1612   (block PUNT
1613     (let ((types2 (union-type-types type2)))
1614       (values (dolist (type1 (union-type-types type1) t)
1615                 (unless (any-type-op csubtypep type1 types2)
1616                   (return nil)))
1617               t))))
1618
1619 (!define-type-method (union :complex-subtypep-arg1) (type1 type2)
1620   (block PUNT
1621     (values (every-type-op csubtypep type2 (union-type-types type1)
1622                            :list-first t)
1623             t)))
1624
1625 (!define-type-method (union :complex-subtypep-arg2) (type1 type2)
1626   (block PUNT
1627     (values (any-type-op csubtypep type1 (union-type-types type2)) t)))
1628
1629 (!define-type-method (union :complex-union) (type1 type2)
1630   (let* ((class1 (type-class-info type1)))
1631     (collect ((res))
1632       (let ((this-type type1))
1633         (dolist (type (union-type-types type2)
1634                       (if (res)
1635                           (make-union-type (cons this-type (res)))
1636                           this-type))
1637           (cond ((eq (type-class-info type) class1)
1638                  (let ((union (funcall (type-class-simple-union class1)
1639                                        this-type type)))
1640                    (if union
1641                        (setq this-type union)
1642                        (res type))))
1643                 ((csubtypep type this-type))
1644                 ((csubtypep type1 type) (return type2))
1645                 (t
1646                  (res type))))))))
1647
1648 ;;; For the union of union types, we let the :COMPLEX-UNION method do
1649 ;;; the work.
1650 (!define-type-method (union :simple-union) (type1 type2)
1651   (let ((res type1))
1652     (dolist (t2 (union-type-types type2) res)
1653       (setq res (type-union res t2)))))
1654
1655 (!define-type-method (union :simple-intersection :complex-intersection)
1656                     (type1 type2)
1657   (let ((res *empty-type*)
1658         (win t))
1659     (dolist (type (union-type-types type2) (values res win))
1660       (multiple-value-bind (int w) (type-intersection type1 type)
1661         (setq res (type-union res int))
1662         (unless w (setq win nil))))))
1663
1664 (!def-type-translator or (&rest types)
1665   (reduce #'type-union
1666           (mapcar #'specifier-type types)
1667           :initial-value *empty-type*))
1668
1669 ;;; We don't actually have intersection types, since the result of
1670 ;;; reasonable type intersections is always describable as a union of
1671 ;;; simple types. If something is too hairy to fit this mold, then we
1672 ;;; make a hairy type.
1673 (!def-type-translator and (&whole spec &rest types)
1674   (let ((res *wild-type*))
1675     (dolist (type types res)
1676       (let ((ctype (specifier-type type)))
1677         (multiple-value-bind (int win) (type-intersection res ctype)
1678           (unless win
1679             (return (make-hairy-type :specifier spec)))
1680           (setq res int))))))
1681 \f
1682 ;;;; CONS types
1683
1684 (!define-type-class cons)
1685
1686 (!def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*))
1687   (make-cons-type (specifier-type car-type-spec)
1688                   (specifier-type cdr-type-spec)))
1689
1690 (!define-type-method (cons :unparse) (type)
1691   (let ((car-eltype (type-specifier (cons-type-car-type type)))
1692         (cdr-eltype (type-specifier (cons-type-cdr-type type))))
1693     (if (and (member car-eltype '(t *))
1694              (member cdr-eltype '(t *)))
1695         'cons
1696         `(cons ,car-eltype ,cdr-eltype))))
1697
1698 (!define-type-method (cons :simple-=) (type1 type2)
1699   (declare (type cons-type type1 type2))
1700   (and (type= (cons-type-car-type type1) (cons-type-car-type type2))
1701        (type= (cons-type-cdr-type type1) (cons-type-cdr-type type2))))
1702
1703 (!define-type-method (cons :simple-subtypep) (type1 type2)
1704   (declare (type cons-type type1 type2))
1705   (multiple-value-bind (val-car win-car)
1706       (csubtypep (cons-type-car-type type1) (cons-type-car-type type2))
1707     (multiple-value-bind (val-cdr win-cdr)
1708         (csubtypep (cons-type-cdr-type type1) (cons-type-cdr-type type2))
1709       (if (and val-car val-cdr)
1710           (values t (and win-car win-cdr))
1711           (values nil (or win-car win-cdr))))))
1712
1713 ;;; Give up if a precise type is not possible, to avoid returning
1714 ;;; overly general types.
1715 (!define-type-method (cons :simple-union) (type1 type2)
1716   (declare (type cons-type type1 type2))
1717   (let ((car-type1 (cons-type-car-type type1))
1718         (car-type2 (cons-type-car-type type2))
1719         (cdr-type1 (cons-type-cdr-type type1))
1720         (cdr-type2 (cons-type-cdr-type type2)))
1721     (cond ((type= car-type1 car-type2)
1722            (make-cons-type car-type1
1723                            (type-union cdr-type1 cdr-type2)))
1724           ((type= cdr-type1 cdr-type2)
1725            (make-cons-type (type-union cdr-type1 cdr-type2)
1726                            cdr-type1)))))
1727
1728 (!define-type-method (cons :simple-intersection) (type1 type2)
1729   (declare (type cons-type type1 type2))
1730   (multiple-value-bind (int-car win-car)
1731       (type-intersection (cons-type-car-type type1)
1732                          (cons-type-car-type type2))
1733     (multiple-value-bind (int-cdr win-cdr)
1734         (type-intersection (cons-type-cdr-type type1)
1735                            (cons-type-cdr-type type2))
1736       (values (make-cons-type int-car int-cdr)
1737               (and win-car win-cdr)))))
1738 \f
1739 ;;; Return the type that describes all objects that are in X but not
1740 ;;; in Y. If we can't determine this type, then return NIL.
1741 ;;;
1742 ;;; For now, we only are clever dealing with union and member types.
1743 ;;; If either type is not a union type, then we pretend that it is a
1744 ;;; union of just one type. What we do is remove from X all the types
1745 ;;; that are a subtype any type in Y. If any type in X intersects with
1746 ;;; a type in Y but is not a subtype, then we give up.
1747 ;;;
1748 ;;; We must also special-case any member type that appears in the
1749 ;;; union. We remove from X's members all objects that are TYPEP to Y.
1750 ;;; If Y has any members, we must be careful that none of those
1751 ;;; members are CTYPEP to any of Y's non-member types. We give up in
1752 ;;; this case, since to compute that difference we would have to break
1753 ;;; the type from X into some collection of types that represents the
1754 ;;; type without that particular element. This seems too hairy to be
1755 ;;; worthwhile, given its low utility.
1756 (defun type-difference (x y)
1757   (let ((x-types (if (union-type-p x) (union-type-types x) (list x)))
1758         (y-types (if (union-type-p y) (union-type-types y) (list y))))
1759     (collect ((res))
1760       (dolist (x-type x-types)
1761         (if (member-type-p x-type)
1762             (collect ((members))
1763               (dolist (mem (member-type-members x-type))
1764                 (multiple-value-bind (val win) (ctypep mem y)
1765                   (unless win (return-from type-difference nil))
1766                   (unless val
1767                     (members mem))))
1768               (when (members)
1769                 (res (make-member-type :members (members)))))
1770             (dolist (y-type y-types (res x-type))
1771               (multiple-value-bind (val win) (csubtypep x-type y-type)
1772                 (unless win (return-from type-difference nil))
1773                 (when val (return))
1774                 (when (types-intersect x-type y-type)
1775                   (return-from type-difference nil))))))
1776
1777       (let ((y-mem (find-if #'member-type-p y-types)))
1778         (when y-mem
1779           (let ((members (member-type-members y-mem)))
1780             (dolist (x-type x-types)
1781               (unless (member-type-p x-type)
1782                 (dolist (member members)
1783                   (multiple-value-bind (val win) (ctypep member x-type)
1784                     (when (or (not win) val)
1785                       (return-from type-difference nil)))))))))
1786
1787       (cond ((null (res)) *empty-type*)
1788             ((null (rest (res))) (first (res)))
1789             (t
1790              (make-union-type (res)))))))
1791 \f
1792 (!def-type-translator array (&optional (element-type '*)
1793                                       (dimensions '*))
1794   (specialize-array-type
1795    (make-array-type :dimensions (canonical-array-dimensions dimensions)
1796                     :element-type (specifier-type element-type))))
1797
1798 (!def-type-translator simple-array (&optional (element-type '*)
1799                                              (dimensions '*))
1800   (specialize-array-type
1801    (make-array-type :dimensions (canonical-array-dimensions dimensions)
1802                     :element-type (specifier-type element-type)
1803                     :complexp nil)))
1804 \f
1805 (!defun-from-collected-cold-init-forms !late-type-cold-init)