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: ~2I~_~S~:>"
 257                    kwd lambda-list))
 258           (key-info (make-key-info :name kwd
 259                                    :type (specifier-type (second key))))))
 260       (setf (args-type-keywords result) (key-info)))
 261     (setf (args-type-allowp result) allowp)
 262     (values)))
 263
 264 ;;; Return the lambda-list-like type specification corresponding
 265 ;;; to an ARGS-TYPE.
 266 (declaim (ftype (function (args-type) list) unparse-args-types))
 267 (defun unparse-args-types (type)
 268   (collect ((result))
 269
 270     (dolist (arg (args-type-required type))
 271       (result (type-specifier arg)))
 272
 273     (when (args-type-optional type)
 274       (result '&optional)
 275       (dolist (arg (args-type-optional type))
 276         (result (type-specifier arg))))
 277
 278     (when (args-type-rest type)
 279       (result '&rest)
 280       (result (type-specifier (args-type-rest type))))
 281
 282     (when (args-type-keyp type)
 283       (result '&key)
 284       (dolist (key (args-type-keywords type))
 285         (result (list (key-info-name key)
 286                       (type-specifier (key-info-type key))))))
 287
 288     (when (args-type-allowp type)
 289       (result '&allow-other-keys))
 290
 291     (result)))
 292
 293 (!def-type-translator function (&optional (args '*) (result '*))
 294   (let ((res (make-function-type
 295               :returns (values-specifier-type result))))
 296     (if (eq args '*)
 297         (setf (function-type-wild-args res) t)
 298         (parse-args-types args res))
 299     res))
 300
 301 (!def-type-translator values (&rest values)
 302   (let ((res (make-values-type)))
 303     (parse-args-types values res)
 304     res))
 305 \f
 306 ;;;; VALUES types interfaces
 307 ;;;;
 308 ;;;; We provide a few special operations that can be meaningfully used
 309 ;;;; on VALUES types (as well as on any other type).
 310
 311 ;;; Return the type of the first value indicated by TYPE. This is used
 312 ;;; by people who don't want to have to deal with VALUES types.
 313 #!-sb-fluid (declaim (freeze-type values-type))
 314 ; (inline single-value-type))
 315 (defun single-value-type (type)
 316   (declare (type ctype type))
 317   (cond ((values-type-p type)
 318          (or (car (args-type-required type))
 319              (if (args-type-optional type)
 320                  (type-union (car (args-type-optional type))
 321                              (specifier-type 'null)))
 322              (args-type-rest type)
 323              (specifier-type 'null)))
 324         ((eq type *wild-type*)
 325          *universal-type*)
 326         (t
 327          type)))
 328
 329 ;;; Return the minmum number of arguments that a function can be
 330 ;;; called with, and the maximum number or NIL. If not a function
 331 ;;; type, return NIL, NIL.
 332 (defun function-type-nargs (type)
 333   (declare (type ctype type))
 334   (if (function-type-p type)
 335       (let ((fixed (length (args-type-required type))))
 336         (if (or (args-type-rest type)
 337                 (args-type-keyp type)
 338                 (args-type-allowp type))
 339             (values fixed nil)
 340             (values fixed (+ fixed (length (args-type-optional type))))))
 341       (values nil nil)))
 342
 343 ;;; Determine whether TYPE corresponds to a definite number of values.
 344 ;;; The first value is a list of the types for each value, and the
 345 ;;; second value is the number of values. If the number of values is
 346 ;;; not fixed, then return NIL and :UNKNOWN.
 347 (defun values-types (type)
 348   (declare (type ctype type))
 349   (cond ((eq type *wild-type*)
 350          (values nil :unknown))
 351         ((not (values-type-p type))
 352          (values (list type) 1))
 353         ((or (args-type-optional type)
 354              (args-type-rest type)
 355              (args-type-keyp type)
 356              (args-type-allowp type))
 357          (values nil :unknown))
 358         (t
 359          (let ((req (args-type-required type)))
 360            (values (mapcar #'single-value-type req) (length req))))))
 361
 362 ;;; Return two values:
 363 ;;; 1. A list of all the positional (fixed and optional) types.
 364 ;;; 2. The &REST type (if any). If keywords allowed, *UNIVERSAL-TYPE*.
 365 ;;;    If no keywords or &REST, then the DEFAULT-TYPE.
 366 (defun values-type-types (type &optional (default-type *empty-type*))
 367   (declare (type values-type type))
 368   (values (append (args-type-required type)
 369                   (args-type-optional type))
 370           (cond ((args-type-keyp type) *universal-type*)
 371                 ((args-type-rest type))
 372                 (t
 373                  default-type))))
 374
 375 ;;; Return a list of OPERATION applied to the types in TYPES1 and
 376 ;;; TYPES2, padding with REST2 as needed. TYPES1 must not be shorter
 377 ;;; than TYPES2. The second value is T if OPERATION always returned a
 378 ;;; true second value.
 379 (defun fixed-values-op (types1 types2 rest2 operation)
 380   (declare (list types1 types2) (type ctype rest2) (type function operation))
 381   (let ((exact t))
 382     (values (mapcar #'(lambda (t1 t2)
 383                         (multiple-value-bind (res win)
 384                             (funcall operation t1 t2)
 385                           (unless win
 386                             (setq exact nil))
 387                           res))
 388                     types1
 389                     (append types2
 390                             (make-list (- (length types1) (length types2))
 391                                        :initial-element rest2)))
 392             exact)))
 393
 394 ;;; If Type isn't a values type, then make it into one:
 395 ;;;    <type>  ==>  (values type &rest t)
 396 (defun coerce-to-values (type)
 397   (declare (type ctype type))
 398   (if (values-type-p type)
 399       type
 400       (make-values-type :required (list type) :rest *universal-type*)))
 401
 402 ;;; Do the specified OPERATION on TYPE1 and TYPE2, which may be any
 403 ;;; type, including VALUES types. With VALUES types such as:
 404 ;;;    (VALUES a0 a1)
 405 ;;;    (VALUES b0 b1)
 406 ;;; we compute the more useful result
 407 ;;;    (VALUES (<operation> a0 b0) (<operation> a1 b1))
 408 ;;; rather than the precise result
 409 ;;;    (<operation> (values a0 a1) (values b0 b1))
 410 ;;; This has the virtue of always keeping the VALUES type specifier
 411 ;;; outermost, and retains all of the information that is really
 412 ;;; useful for static type analysis. We want to know what is always
 413 ;;; true of each value independently. It is worthless to know that IF
 414 ;;; the first value is B0 then the second will be B1.
 415 ;;;
 416 ;;; If the VALUES count signatures differ, then we produce a result with
 417 ;;; the required VALUE count chosen by NREQ when applied to the number
 418 ;;; of required values in TYPE1 and TYPE2. Any &KEY values become
 419 ;;; &REST T (anyone who uses keyword values deserves to lose.)
 420 ;;;
 421 ;;; The second value is true if the result is definitely empty or if
 422 ;;; OPERATION returned true as its second value each time we called
 423 ;;; it. Since we approximate the intersection of VALUES types, the
 424 ;;; second value being true doesn't mean the result is exact.
 425 (defun args-type-op (type1 type2 operation nreq default-type)
 426   (declare (type ctype type1 type2 default-type)
 427            (type function operation nreq))
 428   (if (or (values-type-p type1) (values-type-p type2))
 429       (let ((type1 (coerce-to-values type1))
 430             (type2 (coerce-to-values type2)))
 431         (multiple-value-bind (types1 rest1)
 432             (values-type-types type1 default-type)
 433           (multiple-value-bind (types2 rest2)
 434               (values-type-types type2 default-type)
 435             (multiple-value-bind (rest rest-exact)
 436                 (funcall operation rest1 rest2)
 437               (multiple-value-bind (res res-exact)
 438                   (if (< (length types1) (length types2))
 439                       (fixed-values-op types2 types1 rest1 operation)
 440                       (fixed-values-op types1 types2 rest2 operation))
 441                 (let* ((req (funcall nreq
 442                                      (length (args-type-required type1))
 443                                      (length (args-type-required type2))))
 444                        (required (subseq res 0 req))
 445                        (opt (subseq res req))
 446                        (opt-last (position rest opt :test-not #'type=
 447                                            :from-end t)))
 448                   (if (find *empty-type* required :test #'type=)
 449                       (values *empty-type* t)
 450                       (values (make-values-type
 451                                :required required
 452                                :optional (if opt-last
 453                                              (subseq opt 0 (1+ opt-last))
 454                                              ())
 455                                :rest (if (eq rest default-type) nil rest))
 456                               (and rest-exact res-exact)))))))))
 457       (funcall operation type1 type2)))
 458
 459 ;;; Do a union or intersection operation on types that might be values
 460 ;;; types. The result is optimized for utility rather than exactness,
 461 ;;; but it is guaranteed that it will be no smaller (more restrictive)
 462 ;;; than the precise result.
 463 ;;;
 464 ;;; The return convention seems to be analogous to
 465 ;;; TYPES-INTERSECT. -- WHN 19990910.
 466 (defun-cached (values-type-union :hash-function type-cache-hash
 467                                  :hash-bits 8
 468                                  :default nil
 469                                  :init-wrapper !cold-init-forms)
 470               ((type1 eq) (type2 eq))
 471   (declare (type ctype type1 type2))
 472   (cond ((or (eq type1 *wild-type*) (eq type2 *wild-type*)) *wild-type*)
 473         ((eq type1 *empty-type*) type2)
 474         ((eq type2 *empty-type*) type1)
 475         (t
 476          (values (args-type-op type1 type2 #'type-union #'min *empty-type*)))))
 477 (defun-cached (values-type-intersection :hash-function type-cache-hash
 478                                         :hash-bits 8
 479                                         :values 2
 480                                         :default (values nil :empty)
 481                                         :init-wrapper !cold-init-forms)
 482               ((type1 eq) (type2 eq))
 483   (declare (type ctype type1 type2))
 484   (cond ((eq type1 *wild-type*) (values type2 t))
 485         ((eq type2 *wild-type*) (values type1 t))
 486         (t
 487          (args-type-op type1 type2
 488                        #'type-intersection
 489                        #'max
 490                        (specifier-type 'null)))))
 491
 492 ;;; This is like TYPES-INTERSECT, except that it sort of works on
 493 ;;; VALUES types. Note that due to the semantics of
 494 ;;; VALUES-TYPE-INTERSECTION, this might return (VALUES T T) when
 495 ;;; there isn't really any intersection (?).
 496 ;;;
 497 ;;; The return convention seems to be analogous to
 498 ;;; TYPES-INTERSECT. -- WHN 19990910.
 499 (defun values-types-intersect (type1 type2)
 500   (cond ((or (eq type1 *empty-type*) (eq type2 *empty-type*))
 501          (values 't t))
 502         ((or (values-type-p type1) (values-type-p type2))
 503          (multiple-value-bind (res win) (values-type-intersection type1 type2)
 504            (values (not (eq res *empty-type*))
 505                    win)))
 506         (t
 507          (types-intersect type1 type2))))
 508
 509 ;;; a SUBTYPEP-like operation that can be used on any types, including
 510 ;;; VALUES types
 511 (defun-cached (values-subtypep :hash-function type-cache-hash
 512                                :hash-bits 8
 513                                :values 2
 514                                :default (values nil :empty)
 515                                :init-wrapper !cold-init-forms)
 516               ((type1 eq) (type2 eq))
 517   (declare (type ctype type1 type2))
 518   (cond ((eq type2 *wild-type*) (values t t))
 519         ((eq type1 *wild-type*)
 520          (values (eq type2 *universal-type*) t))
 521         ((not (values-types-intersect type1 type2))
 522          (values nil t))
 523         (t
 524          (if (or (values-type-p type1) (values-type-p type2))
 525              (let ((type1 (coerce-to-values type1))
 526                    (type2 (coerce-to-values type2)))
 527                (multiple-value-bind (types1 rest1) (values-type-types type1)
 528                  (multiple-value-bind (types2 rest2) (values-type-types type2)
 529                    (cond ((< (length (values-type-required type1))
 530                              (length (values-type-required type2)))
 531                           (values nil t))
 532                          ((< (length types1) (length types2))
 533                           (values nil nil))
 534                          ((or (values-type-keyp type1)
 535                               (values-type-keyp type2))
 536                           (values nil nil))
 537                          (t
 538                           (do ((t1 types1 (rest t1))
 539                                (t2 types2 (rest t2)))
 540                               ((null t2)
 541                                (csubtypep rest1 rest2))
 542                             (multiple-value-bind (res win-p)
 543                                 (csubtypep (first t1) (first t2))
 544                               (unless win-p
 545                                 (return (values nil nil)))
 546                               (unless res
 547                                 (return (values nil t))))))))))
 548              (csubtypep type1 type2)))))
 549 \f
 550 ;;;; type method interfaces
 551
 552 ;;; like SUBTYPEP, only works on CTYPE structures
 553 (defun-cached (csubtypep :hash-function type-cache-hash
 554                          :hash-bits 8
 555                          :values 2
 556                          :default (values nil :empty)
 557                          :init-wrapper !cold-init-forms)
 558               ((type1 eq) (type2 eq))
 559   (declare (type ctype type1 type2))
 560   (cond ((or (eq type1 type2)
 561              (eq type1 *empty-type*)
 562              (eq type2 *wild-type*))
 563          (values t t))
 564         ((or (eq type1 *wild-type*)
 565              (eq type2 *empty-type*))
 566          (values nil t))
 567         (t
 568          (!invoke-type-method :simple-subtypep :complex-subtypep-arg2
 569                               type1 type2
 570                               :complex-arg1 :complex-subtypep-arg1))))
 571
 572 ;;; Just parse the type specifiers and call CSUBTYPE.
 573 (defun sb!xc:subtypep (type1 type2)
 574   #!+sb-doc
 575   "Return two values indicating the relationship between type1 and type2.
 576   If values are T and T, type1 definitely is a subtype of type2.
 577   If values are NIL and T, type1 definitely is not a subtype of type2.
 578   If values are NIL and NIL, it couldn't be determined."
 579   (csubtypep (specifier-type type1) (specifier-type type2)))
 580
 581 ;;; If two types are definitely equivalent, return true. The second
 582 ;;; value indicates whether the first value is definitely correct.
 583 ;;; This should only fail in the presence of HAIRY types.
 584 (defun-cached (type= :hash-function type-cache-hash
 585                      :hash-bits 8
 586                      :values 2
 587                      :default (values nil :empty)
 588                      :init-wrapper !cold-init-forms)
 589               ((type1 eq) (type2 eq))
 590   (declare (type ctype type1 type2))
 591   (if (eq type1 type2)
 592       (values t t)
 593       (!invoke-type-method :simple-= :complex-= type1 type2)))
 594
 595 ;;; Not exactly the negation of TYPE=, since when the relationship is
 596 ;;; uncertain, we still return NIL, NIL. This is useful in cases where
 597 ;;; the conservative assumption is =.
 598 (defun type/= (type1 type2)
 599   (declare (type ctype type1 type2))
 600   (multiple-value-bind (res win) (type= type1 type2)
 601     (if win
 602         (values (not res) t)
 603         (values nil nil))))
 604
 605 ;;; Find a type which includes both types. Any inexactness is
 606 ;;; represented by the fuzzy element types; we return a single value
 607 ;;; that is precise to the best of our knowledge. This result is
 608 ;;; simplified into the canonical form, thus is not a UNION type
 609 ;;; unless there is no other way to represent the result.
 610 (defun-cached (type-union :hash-function type-cache-hash
 611                           :hash-bits 8
 612                           :init-wrapper !cold-init-forms)
 613               ((type1 eq) (type2 eq))
 614   (declare (type ctype type1 type2))
 615   (if (eq type1 type2)
 616       type1
 617       (let ((res (!invoke-type-method :simple-union :complex-union
 618                                       type1 type2
 619                                       :default :vanilla)))
 620         (cond ((eq res :vanilla)
 621                (or (vanilla-union type1 type2)
 622                    (make-union-type-or-something (list type1 type2))))
 623               (res)
 624               (t
 625                (make-union-type-or-something (list type1 type2)))))))
 626
 627 ;;; Return as restrictive a type as we can discover that is no more
 628 ;;; restrictive than the intersection of TYPE1 and TYPE2. The second
 629 ;;; value is true if the result is exact. At worst, we randomly return
 630 ;;; one of the arguments as the first value (trying not to return a
 631 ;;; hairy type).
 632 (defun-cached (type-intersection :hash-function type-cache-hash
 633                                  :hash-bits 8
 634                                  :values 2
 635                                  :default (values nil :empty)
 636                                  :init-wrapper !cold-init-forms)
 637               ((type1 eq) (type2 eq))
 638   (declare (type ctype type1 type2))
 639   (if (eq type1 type2)
 640       (values type1 t)
 641       (!invoke-type-method :simple-intersection :complex-intersection
 642                            type1 type2
 643                            :default (values *empty-type* t))))
 644
 645 ;;; The first value is true unless the types don't intersect. The
 646 ;;; second value is true if the first value is definitely correct. NIL
 647 ;;; is considered to intersect with any type. If T is a subtype of
 648 ;;; either type, then we also return T, T. This way we consider hairy
 649 ;;; types to intersect with T.
 650 (defun types-intersect (type1 type2)
 651   (declare (type ctype type1 type2))
 652   (if (or (eq type1 *empty-type*) (eq type2 *empty-type*))
 653       (values t t)
 654       (multiple-value-bind (val winp) (type-intersection type1 type2)
 655         (cond ((not winp)
 656                (if (or (csubtypep *universal-type* type1)
 657                        (csubtypep *universal-type* type2))
 658                    (values t t)
 659                    (values t nil)))
 660               ((eq val *empty-type*) (values nil t))
 661               (t (values t t))))))
 662
 663 ;;; Return a Common Lisp type specifier corresponding to the TYPE
 664 ;;; object.
 665 (defun type-specifier (type)
 666   (declare (type ctype type))
 667   (funcall (type-class-unparse (type-class-info type)) type))
 668
 669 ;;; (VALUES-SPECIFIER-TYPE and SPECIFIER-TYPE moved from here to
 670 ;;; early-type.lisp by WHN ca. 19990201.)
 671
 672 ;;; Take a list of type specifiers, computing the translation of each
 673 ;;; specifier and defining it as a builtin type.
 674 (declaim (ftype (function (list) (values)) precompute-types))
 675 (defun precompute-types (specs)
 676   (dolist (spec specs)
 677     (let ((res (specifier-type spec)))
 678       (unless (unknown-type-p res)
 679         (setf (info :type :builtin spec) res)
 680         (setf (info :type :kind spec) :primitive))))
 681   (values))
 682 \f
 683 ;;;; built-in types
 684
 685 (!define-type-class named)
 686
 687 (defvar *wild-type*)
 688 (defvar *empty-type*)
 689 (defvar *universal-type*)
 690
 691 (!cold-init-forms
 692  (macrolet ((frob (name var)
 693               `(progn
 694                  (setq ,var (make-named-type :name ',name))
 695                  (setf (info :type :kind ',name) :primitive)
 696                  (setf (info :type :builtin ',name) ,var))))
 697    ;; KLUDGE: In ANSI, * isn't really the name of a type, it's just a
 698    ;; special symbol which can be stuck in some places where an
 699    ;; ordinary type can go, e.g. (ARRAY * 1) instead of (ARRAY T 1).
 700    ;; At some point, in order to become more standard, we should
 701    ;; convert all the classic CMU CL legacy *s and *WILD-TYPE*s into
 702    ;; Ts and *UNIVERSAL-TYPE*s.
 703    (frob * *wild-type*)
 704    (frob nil *empty-type*)
 705    (frob t *universal-type*)))
 706
 707 (!define-type-method (named :simple-=) (type1 type2)
 708   (values (eq type1 type2) t))
 709
 710 (!define-type-method (named :simple-subtypep) (type1 type2)
 711   (values (or (eq type1 *empty-type*) (eq type2 *wild-type*)) t))
 712
 713 (!define-type-method (named :complex-subtypep-arg1) (type1 type2)
 714   (assert (not (hairy-type-p type2)))
 715   (values (eq type1 *empty-type*) t))
 716
 717 (!define-type-method (named :complex-subtypep-arg2) (type1 type2)
 718   (if (hairy-type-p type1)
 719       (values nil nil)
 720       (values (not (eq type2 *empty-type*)) t)))
 721
 722 (!define-type-method (named :complex-intersection) (type1 type2)
 723   (vanilla-intersection type1 type2))
 724
 725 (!define-type-method (named :unparse) (x)
 726   (named-type-name x))
 727 \f
 728 ;;;; hairy and unknown types
 729
 730 (!define-type-method (hairy :unparse) (x) (hairy-type-specifier x))
 731
 732 (!define-type-method (hairy :simple-subtypep) (type1 type2)
 733   (let ((hairy-spec1 (hairy-type-specifier type1))
 734         (hairy-spec2 (hairy-type-specifier type2)))
 735     (cond ((and (consp hairy-spec1) (eq (car hairy-spec1) 'not)
 736                 (consp hairy-spec2) (eq (car hairy-spec2) 'not))
 737            (csubtypep (specifier-type (cadr hairy-spec2))
 738                       (specifier-type (cadr hairy-spec1))))
 739           ((equal hairy-spec1 hairy-spec2)
 740            (values t t))
 741           (t
 742            (values nil nil)))))
 743
 744 (!define-type-method (hairy :complex-subtypep-arg2) (type1 type2)
 745   (let ((hairy-spec (hairy-type-specifier type2)))
 746     (cond ((and (consp hairy-spec) (eq (car hairy-spec) 'not))
 747            (multiple-value-bind (val win)
 748                (type-intersection type1 (specifier-type (cadr hairy-spec)))
 749              (if win
 750                  (values (eq val *empty-type*) t)
 751                  (values nil nil))))
 752           (t
 753            (values nil nil)))))
 754
 755 (!define-type-method (hairy :complex-subtypep-arg1 :complex-=) (type1 type2)
 756   (declare (ignore type1 type2))
 757   (values nil nil))
 758
 759 (!define-type-method (hairy :simple-intersection :complex-intersection)
 760                     (type1 type2)
 761   (declare (ignore type2))
 762   (values type1 nil))
 763
 764 (!define-type-method (hairy :complex-union) (type1 type2)
 765   (make-union-type-or-something (list type1 type2)))
 766
 767 (!define-type-method (hairy :simple-=) (type1 type2)
 768   (if (equal (hairy-type-specifier type1)
 769              (hairy-type-specifier type2))
 770       (values t t)
 771       (values nil nil)))
 772
 773 (!def-type-translator not (&whole whole type)
 774   (declare (ignore type))
 775   (make-hairy-type :specifier whole))
 776
 777 (!def-type-translator satisfies (&whole whole fun)
 778   (declare (ignore fun))
 779   (make-hairy-type :specifier whole))
 780 \f
 781 ;;;; numeric types
 782
 783 ;;; A list of all the float formats, in order of decreasing precision.
 784 (eval-when (:compile-toplevel :load-toplevel :execute)
 785   (defparameter *float-formats*
 786     '(long-float double-float single-float short-float)))
 787
 788 ;;; The type of a float format.
 789 (deftype float-format () `(member ,@*float-formats*))
 790
 791 #!+negative-zero-is-not-zero
 792 (defun make-numeric-type (&key class format (complexp :real) low high
 793                                enumerable)
 794   (flet ((canonicalise-low-bound (x)
 795            ;; Canonicalise a low bound of (-0.0) to 0.0.
 796            (if (and (consp x) (floatp (car x)) (zerop (car x))
 797                     (minusp (float-sign (car x))))
 798                (float 0.0 (car x))
 799                x))
 800          (canonicalise-high-bound (x)
 801            ;; Canonicalise a high bound of (+0.0) to -0.0.
 802            (if (and (consp x) (floatp (car x)) (zerop (car x))
 803                     (plusp (float-sign (car x))))
 804                (float -0.0 (car x))
 805                x)))
 806     (%make-numeric-type :class class
 807                         :format format
 808                         :complexp complexp
 809                         :low (canonicalise-low-bound low)
 810                         :high (canonicalise-high-bound high)
 811                         :enumerable enumerable)))
 812
 813 (!define-type-class number)
 814
 815 (!define-type-method (number :simple-=) (type1 type2)
 816   (values
 817    (and (eq (numeric-type-class type1) (numeric-type-class type2))
 818         (eq (numeric-type-format type1) (numeric-type-format type2))
 819         (eq (numeric-type-complexp type1) (numeric-type-complexp type2))
 820         (equal (numeric-type-low type1) (numeric-type-low type2))
 821         (equal (numeric-type-high type1) (numeric-type-high type2)))
 822    t))
 823
 824 (!define-type-method (number :unparse) (type)
 825   (let* ((complexp (numeric-type-complexp type))
 826          (low (numeric-type-low type))
 827          (high (numeric-type-high type))
 828          (base (case (numeric-type-class type)
 829                  (integer 'integer)
 830                  (rational 'rational)
 831                  (float (or (numeric-type-format type) 'float))
 832                  (t 'real))))
 833     (let ((base+bounds
 834            (cond ((and (eq base 'integer) high low)
 835                   (let ((high-count (logcount high))
 836                         (high-length (integer-length high)))
 837                     (cond ((= low 0)
 838                            (cond ((= high 0) '(integer 0 0))
 839                                  ((= high 1) 'bit)
 840                                  ((and (= high-count high-length)
 841                                        (plusp high-length))
 842                                   `(unsigned-byte ,high-length))
 843                                  (t
 844                                   `(mod ,(1+ high)))))
 845                           ((and (= low sb!vm:*target-most-negative-fixnum*)
 846                                 (= high sb!vm:*target-most-positive-fixnum*))
 847                            'fixnum)
 848                           ((and (= low (lognot high))
 849                                 (= high-count high-length)
 850                                 (> high-count 0))
 851                            `(signed-byte ,(1+ high-length)))
 852                           (t
 853                            `(integer ,low ,high)))))
 854                  (high `(,base ,(or low '*) ,high))
 855                  (low
 856                   (if (and (eq base 'integer) (= low 0))
 857                       'unsigned-byte
 858                       `(,base ,low)))
 859                  (t base))))
 860       (ecase complexp
 861         (:real
 862          base+bounds)
 863         (:complex
 864          (if (eq base+bounds 'real)
 865              'complex
 866              `(complex ,base+bounds)))
 867         ((nil)
 868          (assert (eq base+bounds 'real))
 869          'number)))))
 870
 871 ;;; Return true if X is "less than or equal" to Y, taking open bounds
 872 ;;; into consideration. CLOSED is the predicate used to test the bound
 873 ;;; on a closed interval (e.g. <=), and OPEN is the predicate used on
 874 ;;; open bounds (e.g. <). Y is considered to be the outside bound, in
 875 ;;; the sense that if it is infinite (NIL), then the test succeeds,
 876 ;;; whereas if X is infinite, then the test fails (unless Y is also
 877 ;;; infinite).
 878 ;;;
 879 ;;; This is for comparing bounds of the same kind, e.g. upper and
 880 ;;; upper. Use NUMERIC-BOUND-TEST* for different kinds of bounds.
 881 #!-negative-zero-is-not-zero
 882 (defmacro numeric-bound-test (x y closed open)
 883   `(cond ((not ,y) t)
 884          ((not ,x) nil)
 885          ((consp ,x)
 886           (if (consp ,y)
 887               (,closed (car ,x) (car ,y))
 888               (,closed (car ,x) ,y)))
 889          (t
 890           (if (consp ,y)
 891               (,open ,x (car ,y))
 892               (,closed ,x ,y)))))
 893
 894 #!+negative-zero-is-not-zero
 895 (defmacro numeric-bound-test-zero (op x y)
 896   `(if (and (zerop ,x) (zerop ,y) (floatp ,x) (floatp ,y))
 897        (,op (float-sign ,x) (float-sign ,y))
 898        (,op ,x ,y)))
 899
 900 #!+negative-zero-is-not-zero
 901 (defmacro numeric-bound-test (x y closed open)
 902   `(cond ((not ,y) t)
 903          ((not ,x) nil)
 904          ((consp ,x)
 905           (if (consp ,y)
 906               (numeric-bound-test-zero ,closed (car ,x) (car ,y))
 907               (numeric-bound-test-zero ,closed (car ,x) ,y)))
 908          (t
 909           (if (consp ,y)
 910               (numeric-bound-test-zero ,open ,x (car ,y))
 911               (numeric-bound-test-zero ,closed ,x ,y)))))
 912
 913 ;;; This is used to compare upper and lower bounds. This is different
 914 ;;; from the same-bound case:
 915 ;;; -- Since X = NIL is -infinity, whereas y = NIL is +infinity, we
 916 ;;;    return true if *either* arg is NIL.
 917 ;;; -- an open inner bound is "greater" and also squeezes the interval,
 918 ;;;    causing us to use the OPEN test for those cases as well.
 919 #!-negative-zero-is-not-zero
 920 (defmacro numeric-bound-test* (x y closed open)
 921   `(cond ((not ,y) t)
 922          ((not ,x) t)
 923          ((consp ,x)
 924           (if (consp ,y)
 925               (,open (car ,x) (car ,y))
 926               (,open (car ,x) ,y)))
 927          (t
 928           (if (consp ,y)
 929               (,open ,x (car ,y))
 930               (,closed ,x ,y)))))
 931
 932 #!+negative-zero-is-not-zero
 933 (defmacro numeric-bound-test* (x y closed open)
 934   `(cond ((not ,y) t)
 935          ((not ,x) t)
 936          ((consp ,x)
 937           (if (consp ,y)
 938               (numeric-bound-test-zero ,open (car ,x) (car ,y))
 939               (numeric-bound-test-zero ,open (car ,x) ,y)))
 940          (t
 941           (if (consp ,y)
 942               (numeric-bound-test-zero ,open ,x (car ,y))
 943               (numeric-bound-test-zero ,closed ,x ,y)))))
 944
 945 ;;; Return whichever of the numeric bounds X and Y is "maximal"
 946 ;;; according to the predicates CLOSED (e.g. >=) and OPEN (e.g. >).
 947 ;;; This is only meaningful for maximizing like bounds, i.e. upper and
 948 ;;; upper. If MAX-P is true, then we return NIL if X or Y is NIL,
 949 ;;; otherwise we return the other arg.
 950 (defmacro numeric-bound-max (x y closed open max-p)
 951   (once-only ((n-x x)
 952               (n-y y))
 953     `(cond ((not ,n-x) ,(if max-p nil n-y))
 954            ((not ,n-y) ,(if max-p nil n-x))
 955            ((consp ,n-x)
 956             (if (consp ,n-y)
 957                 (if (,closed (car ,n-x) (car ,n-y)) ,n-x ,n-y)
 958                 (if (,open (car ,n-x) ,n-y) ,n-x ,n-y)))
 959            (t
 960             (if (consp ,n-y)
 961                 (if (,open (car ,n-y) ,n-x) ,n-y ,n-x)
 962                 (if (,closed ,n-y ,n-x) ,n-y ,n-x))))))
 963
 964 (!define-type-method (number :simple-subtypep) (type1 type2)
 965   (let ((class1 (numeric-type-class type1))
 966         (class2 (numeric-type-class type2))
 967         (complexp2 (numeric-type-complexp type2))
 968         (format2 (numeric-type-format type2))
 969         (low1 (numeric-type-low type1))
 970         (high1 (numeric-type-high type1))
 971         (low2 (numeric-type-low type2))
 972         (high2 (numeric-type-high type2)))
 973     ;; If one is complex and the other isn't, they are disjoint.
 974     (cond ((not (or (eq (numeric-type-complexp type1) complexp2)
 975                     (null complexp2)))
 976            (values nil t))
 977           ;; If the classes are specified and different, the types are
 978           ;; disjoint unless type2 is rational and type1 is integer.
 979           ((not (or (eq class1 class2)
 980                     (null class2)
 981                     (and (eq class1 'integer)
 982                          (eq class2 'rational))))
 983            (values nil t))
 984           ;; If the float formats are specified and different, the types
 985           ;; are disjoint.
 986           ((not (or (eq (numeric-type-format type1) format2)
 987                     (null format2)))
 988            (values nil t))
 989           ;; Check the bounds.
 990           ((and (numeric-bound-test low1 low2 >= >)
 991                 (numeric-bound-test high1 high2 <= <))
 992            (values t t))
 993           (t
 994            (values nil t)))))
 995
 996 (!define-superclasses number ((generic-number)) !cold-init-forms)
 997
 998 ;;; If the high bound of LOW is adjacent to the low bound of HIGH,
 999 ;;; then return true, otherwise NIL.
1000 (defun numeric-types-adjacent (low high)
1001   (let ((low-bound (numeric-type-high low))
1002         (high-bound (numeric-type-low high)))
1003     (cond ((not (and low-bound high-bound)) nil)
1004           ((and (consp low-bound) (consp high-bound)) nil)
1005           ((consp low-bound)
1006            #!-negative-zero-is-not-zero
1007            (let ((low-value (car low-bound)))
1008              (or (eql low-value high-bound)
1009                  (and (eql low-value -0f0) (eql high-bound 0f0))
1010                  (and (eql low-value 0f0) (eql high-bound -0f0))
1011                  (and (eql low-value -0d0) (eql high-bound 0d0))
1012                  (and (eql low-value 0d0) (eql high-bound -0d0))))
1013            #!+negative-zero-is-not-zero
1014            (eql (car low-bound) high-bound))
1015           ((consp high-bound)
1016            #!-negative-zero-is-not-zero
1017            (let ((high-value (car high-bound)))
1018              (or (eql high-value low-bound)
1019                  (and (eql high-value -0f0) (eql low-bound 0f0))
1020                  (and (eql high-value 0f0) (eql low-bound -0f0))
1021                  (and (eql high-value -0d0) (eql low-bound 0d0))
1022                  (and (eql high-value 0d0) (eql low-bound -0d0))))
1023            #!+negative-zero-is-not-zero
1024            (eql (car high-bound) low-bound))
1025           #!+negative-zero-is-not-zero
1026           ((or (and (eql low-bound -0f0) (eql high-bound 0f0))
1027                (and (eql low-bound -0d0) (eql high-bound 0d0))))
1028           ((and (eq (numeric-type-class low) 'integer)
1029                 (eq (numeric-type-class high) 'integer))
1030            (eql (1+ low-bound) high-bound))
1031           (t
1032            nil))))
1033
1034 ;;; Return a numeric type that is a supertype for both TYPE1 and TYPE2.
1035 ;;;
1036 ;;; ### Note: we give up early to keep from dropping lots of information on
1037 ;;; the floor by returning overly general types.
1038 (!define-type-method (number :simple-union) (type1 type2)
1039   (declare (type numeric-type type1 type2))
1040   (cond ((csubtypep type1 type2) type2)
1041         ((csubtypep type2 type1) type1)
1042         (t
1043          (let ((class1 (numeric-type-class type1))
1044                (format1 (numeric-type-format type1))
1045                (complexp1 (numeric-type-complexp type1))
1046                (class2 (numeric-type-class type2))
1047                (format2 (numeric-type-format type2))
1048                (complexp2 (numeric-type-complexp type2)))
1049            (when (and (eq class1 class2)
1050                       (eq format1 format2)
1051                       (eq complexp1 complexp2)
1052                       (or (numeric-types-intersect type1 type2)
1053                           (numeric-types-adjacent type1 type2)
1054                           (numeric-types-adjacent type2 type1)))
1055              (make-numeric-type
1056               :class class1
1057               :format format1
1058               :complexp complexp1
1059               :low (numeric-bound-max (numeric-type-low type1)
1060                                       (numeric-type-low type2)
1061                                       <= < t)
1062               :high (numeric-bound-max (numeric-type-high type1)
1063                                        (numeric-type-high type2)
1064                                        >= > t)))))))
1065
1066 (!cold-init-forms
1067   (setf (info :type :kind 'number) :primitive)
1068   (setf (info :type :builtin 'number)
1069         (make-numeric-type :complexp nil)))
1070
1071 (!def-type-translator complex (&optional (spec '*))
1072   (if (eq spec '*)
1073       (make-numeric-type :complexp :complex)
1074       (let ((type (specifier-type spec)))
1075         (unless (numeric-type-p type)
1076           (error "Component type for Complex is not numeric: ~S." spec))
1077         (when (eq (numeric-type-complexp type) :complex)
1078           (error "Component type for Complex is complex: ~S." spec))
1079         (let ((res (copy-numeric-type type)))
1080           (setf (numeric-type-complexp res) :complex)
1081           res))))
1082
1083 ;;; If X is *, return NIL, otherwise return the bound, which must be a
1084 ;;; member of TYPE or a one-element list of a member of TYPE.
1085 #!-sb-fluid (declaim (inline canonicalized-bound))
1086 (defun canonicalized-bound (bound type)
1087   (cond ((eq bound '*) nil)
1088         ((or (sb!xc:typep bound type)
1089              (and (consp bound)
1090                   (sb!xc:typep (car bound) type)
1091                   (null (cdr bound))))
1092           bound)
1093         (t
1094          (error "Bound is not ~S, a ~S or a list of a ~S: ~S"
1095                 '*
1096                 type
1097                 type
1098                 bound))))
1099
1100 (!def-type-translator integer (&optional (low '*) (high '*))
1101   (let* ((l (canonicalized-bound low 'integer))
1102          (lb (if (consp l) (1+ (car l)) l))
1103          (h (canonicalized-bound high 'integer))
1104          (hb (if (consp h) (1- (car h)) h)))
1105     (when (and hb lb (< hb lb))
1106       (error "Lower bound ~S is greater than upper bound ~S." l h))
1107     (make-numeric-type :class 'integer
1108                        :complexp :real
1109                        :enumerable (not (null (and l h)))
1110                        :low lb
1111                        :high hb)))
1112
1113 (defmacro def-bounded-type (type class format)
1114   `(!def-type-translator ,type (&optional (low '*) (high '*))
1115      (let ((lb (canonicalized-bound low ',type))
1116            (hb (canonicalized-bound high ',type)))
1117        (unless (numeric-bound-test* lb hb <= <)
1118          (error "Lower bound ~S is not less than upper bound ~S." low high))
1119        (make-numeric-type :class ',class :format ',format :low lb :high hb))))
1120
1121 (def-bounded-type rational rational nil)
1122 (def-bounded-type float float nil)
1123 (def-bounded-type real nil nil)
1124
1125 (defmacro define-float-format (f)
1126   `(def-bounded-type ,f float ,f))
1127
1128 (define-float-format short-float)
1129 (define-float-format single-float)
1130 (define-float-format double-float)
1131 (define-float-format long-float)
1132
1133 (defun numeric-types-intersect (type1 type2)
1134   (declare (type numeric-type type1 type2))
1135   (let* ((class1 (numeric-type-class type1))
1136          (class2 (numeric-type-class type2))
1137          (complexp1 (numeric-type-complexp type1))
1138          (complexp2 (numeric-type-complexp type2))
1139          (format1 (numeric-type-format type1))
1140          (format2 (numeric-type-format type2))
1141          (low1 (numeric-type-low type1))
1142          (high1 (numeric-type-high type1))
1143          (low2 (numeric-type-low type2))
1144          (high2 (numeric-type-high type2)))
1145     ;; If one is complex and the other isn't, then they are disjoint.
1146     (cond ((not (or (eq complexp1 complexp2)
1147                     (null complexp1) (null complexp2)))
1148            nil)
1149           ;; If either type is a float, then the other must either be
1150           ;; specified to be a float or unspecified. Otherwise, they
1151           ;; are disjoint.
1152           ((and (eq class1 'float)
1153                 (not (member class2 '(float nil)))) nil)
1154           ((and (eq class2 'float)
1155                 (not (member class1 '(float nil)))) nil)
1156           ;; If the float formats are specified and different, the
1157           ;; types are disjoint.
1158           ((not (or (eq format1 format2) (null format1) (null format2)))
1159            nil)
1160           (t
1161            ;; Check the bounds. This is a bit odd because we must
1162            ;; always have the outer bound of the interval as the
1163            ;; second arg.
1164            (if (numeric-bound-test high1 high2 <= <)
1165                (or (and (numeric-bound-test low1 low2 >= >)
1166                         (numeric-bound-test* low1 high2 <= <))
1167                    (and (numeric-bound-test low2 low1 >= >)
1168                         (numeric-bound-test* low2 high1 <= <)))
1169                (or (and (numeric-bound-test* low2 high1 <= <)
1170                         (numeric-bound-test low2 low1 >= >))
1171                    (and (numeric-bound-test high2 high1 <= <)
1172                         (numeric-bound-test* high2 low1 >= >))))))))
1173
1174 ;;; Take the numeric bound X and convert it into something that can be
1175 ;;; used as a bound in a numeric type with the specified CLASS and
1176 ;;; FORMAT. If UP-P is true, then we round up as needed, otherwise we
1177 ;;; round down. UP-P true implies that X is a lower bound, i.e. (N) > N.
1178 ;;;
1179 ;;; This is used by NUMERIC-TYPE-INTERSECTION to mash the bound into
1180 ;;; the appropriate type number. X may only be a float when CLASS is
1181 ;;; FLOAT.
1182 ;;;
1183 ;;; ### Note: it is possible for the coercion to a float to overflow
1184 ;;; or underflow. This happens when the bound doesn't fit in the
1185 ;;; specified format. In this case, we should really return the
1186 ;;; appropriate {Most | Least}-{Positive | Negative}-XXX-Float float
1187 ;;; of desired format. But these conditions aren't currently signalled
1188 ;;; in any useful way.
1189 ;;;
1190 ;;; Also, when converting an open rational bound into a float we
1191 ;;; should probably convert it to a closed bound of the closest float
1192 ;;; in the specified format. KLUDGE: In general, open float bounds are
1193 ;;; screwed up. -- (comment from original CMU CL)
1194 (defun round-numeric-bound (x class format up-p)
1195   (if x
1196       (let ((cx (if (consp x) (car x) x)))
1197         (ecase class
1198           ((nil rational) x)
1199           (integer
1200            (if (and (consp x) (integerp cx))
1201                (if up-p (1+ cx) (1- cx))
1202                (if up-p (ceiling cx) (floor cx))))
1203           (float
1204            (let ((res (if format (coerce cx format) (float cx))))
1205              (if (consp x) (list res) res)))))
1206       nil))
1207
1208 ;;; Handle the case of TYPE-INTERSECTION on two numeric types. We use
1209 ;;; TYPES-INTERSECT to throw out the case of types with no
1210 ;;; intersection. If an attribute in TYPE1 is unspecified, then we use
1211 ;;; TYPE2's attribute, which must be at least as restrictive. If the
1212 ;;; types intersect, then the only attributes that can be specified
1213 ;;; and different are the class and the bounds.
1214 ;;;
1215 ;;; When the class differs, we use the more restrictive class. The
1216 ;;; only interesting case is RATIONAL/INTEGER, since RATIONAL includes
1217 ;;; INTEGER.
1218 ;;;
1219 ;;; We make the result lower (upper) bound the maximum (minimum) of
1220 ;;; the argument lower (upper) bounds. We convert the bounds into the
1221 ;;; appropriate numeric type before maximizing. This avoids possible
1222 ;;; confusion due to mixed-type comparisons (but I think the result is
1223 ;;; the same).
1224 (!define-type-method (number :simple-intersection) (type1 type2)
1225   (declare (type numeric-type type1 type2))
1226   (if (numeric-types-intersect type1 type2)
1227       (let* ((class1 (numeric-type-class type1))
1228              (class2 (numeric-type-class type2))
1229              (class (ecase class1
1230                       ((nil) class2)
1231                       ((integer float) class1)
1232                       (rational (if (eq class2 'integer)
1233                                        'integer
1234                                        'rational))))
1235              (format (or (numeric-type-format type1)
1236                          (numeric-type-format type2))))
1237         (values
1238          (make-numeric-type
1239           :class class
1240           :format format
1241           :complexp (or (numeric-type-complexp type1)
1242                         (numeric-type-complexp type2))
1243           :low (numeric-bound-max
1244                 (round-numeric-bound (numeric-type-low type1)
1245                                      class format t)
1246                 (round-numeric-bound (numeric-type-low type2)
1247                                      class format t)
1248                 > >= nil)
1249           :high (numeric-bound-max
1250                  (round-numeric-bound (numeric-type-high type1)
1251                                       class format nil)
1252                  (round-numeric-bound (numeric-type-high type2)
1253                                       class format nil)
1254                  < <= nil))
1255          t))
1256       (values *empty-type* t)))
1257
1258 ;;; Given two float formats, return the one with more precision. If
1259 ;;; either one is null, return NIL.
1260 (defun float-format-max (f1 f2)
1261   (when (and f1 f2)
1262     (dolist (f *float-formats* (error "bad float format: ~S" f1))
1263       (when (or (eq f f1) (eq f f2))
1264         (return f)))))
1265
1266 ;;; Return the result of an operation on TYPE1 and TYPE2 according to
1267 ;;; the rules of numeric contagion. This is always NUMBER, some float
1268 ;;; format (possibly complex) or RATIONAL. Due to rational
1269 ;;; canonicalization, there isn't much we can do here with integers or
1270 ;;; rational complex numbers.
1271 ;;;
1272 ;;; If either argument is not a NUMERIC-TYPE, then return NUMBER. This
1273 ;;; is useful mainly for allowing types that are technically numbers,
1274 ;;; but not a NUMERIC-TYPE.
1275 (defun numeric-contagion (type1 type2)
1276   (if (and (numeric-type-p type1) (numeric-type-p type2))
1277       (let ((class1 (numeric-type-class type1))
1278             (class2 (numeric-type-class type2))
1279             (format1 (numeric-type-format type1))
1280             (format2 (numeric-type-format type2))
1281             (complexp1 (numeric-type-complexp type1))
1282             (complexp2 (numeric-type-complexp type2)))
1283         (cond ((or (null complexp1)
1284                    (null complexp2))
1285                (specifier-type 'number))
1286               ((eq class1 'float)
1287                (make-numeric-type
1288                 :class 'float
1289                 :format (ecase class2
1290                           (float (float-format-max format1 format2))
1291                           ((integer rational) format1)
1292                           ((nil)
1293                            ;; A double-float with any real number is a
1294                            ;; double-float.
1295                            #!-long-float
1296                            (if (eq format1 'double-float)
1297                              'double-float
1298                              nil)
1299                            ;; A long-float with any real number is a
1300                            ;; long-float.
1301                            #!+long-float
1302                            (if (eq format1 'long-float)
1303                              'long-float
1304                              nil)))
1305                 :complexp (if (or (eq complexp1 :complex)
1306                                   (eq complexp2 :complex))
1307                               :complex
1308                               :real)))
1309               ((eq class2 'float) (numeric-contagion type2 type1))
1310               ((and (eq complexp1 :real) (eq complexp2 :real))
1311                (make-numeric-type
1312                 :class (and class1 class2 'rational)
1313                 :complexp :real))
1314               (t
1315                (specifier-type 'number))))
1316       (specifier-type 'number)))
1317 \f
1318 ;;;; array types
1319
1320 (!define-type-class array)
1321
1322 ;;; What this does depends on the setting of the
1323 ;;; *USE-IMPLEMENTATION-TYPES* switch. If true, return the specialized
1324 ;;; element type, otherwise return the original element type.
1325 (defun specialized-element-type-maybe (type)
1326   (declare (type array-type type))
1327   (if *use-implementation-types*
1328       (array-type-specialized-element-type type)
1329       (array-type-element-type type)))
1330
1331 (!define-type-method (array :simple-=) (type1 type2)
1332   (values (and (equal (array-type-dimensions type1)
1333                       (array-type-dimensions type2))
1334                (eq (array-type-complexp type1)
1335                    (array-type-complexp type2))
1336                (type= (specialized-element-type-maybe type1)
1337                       (specialized-element-type-maybe type2)))
1338           t))
1339
1340 (!define-type-method (array :unparse) (type)
1341   (let ((dims (array-type-dimensions type))
1342         (eltype (type-specifier (array-type-element-type type)))
1343         (complexp (array-type-complexp type)))
1344     (cond ((eq dims '*)
1345            (if (eq eltype '*)
1346                (if complexp 'array 'simple-array)
1347                (if complexp `(array ,eltype) `(simple-array ,eltype))))
1348           ((= (length dims) 1)
1349            (if complexp
1350                (if (eq (car dims) '*)
1351                    (case eltype
1352                      (bit 'bit-vector)
1353                      (base-char 'base-string)
1354                      (character 'string)
1355                      (* 'vector)
1356                      (t `(vector ,eltype)))
1357                    (case eltype
1358                      (bit `(bit-vector ,(car dims)))
1359                      (base-char `(base-string ,(car dims)))
1360                      (character `(string ,(car dims)))
1361                      (t `(vector ,eltype ,(car dims)))))
1362                (if (eq (car dims) '*)
1363                    (case eltype
1364                      (bit 'simple-bit-vector)
1365                      (base-char 'simple-base-string)
1366                      (character 'simple-string)
1367                      ((t) 'simple-vector)
1368                      (t `(simple-array ,eltype (*))))
1369                    (case eltype
1370                      (bit `(simple-bit-vector ,(car dims)))
1371                      (base-char `(simple-base-string ,(car dims)))
1372                      (character `(simple-string ,(car dims)))
1373                      ((t) `(simple-vector ,(car dims)))
1374                      (t `(simple-array ,eltype ,dims))))))
1375           (t
1376            (if complexp
1377                `(array ,eltype ,dims)
1378                `(simple-array ,eltype ,dims))))))
1379
1380 (!define-type-method (array :simple-subtypep) (type1 type2)
1381   (let ((dims1 (array-type-dimensions type1))
1382         (dims2 (array-type-dimensions type2))
1383         (complexp2 (array-type-complexp type2)))
1384     (cond (;; not subtypep unless dimensions are compatible
1385            (not (or (eq dims2 '*)
1386                     (and (not (eq dims1 '*))
1387                          ;; (sbcl-0.6.4 has trouble figuring out that
1388                          ;; DIMS1 and DIMS2 must be lists at this
1389                          ;; point, and knowing that is important to
1390                          ;; compiling EVERY efficiently.)
1391                          (= (length (the list dims1))
1392                             (length (the list dims2)))
1393                          (every (lambda (x y)
1394                                   (or (eq y '*) (eql x y)))
1395                                 (the list dims1)
1396                                 (the list dims2)))))
1397            (values nil t))
1398           ;; not subtypep unless complexness is compatible
1399           ((not (or (eq complexp2 :maybe)
1400                     (eq (array-type-complexp type1) complexp2)))
1401            (values nil t))
1402           ;; Since we didn't fail any of the tests above, we win
1403           ;; if the TYPE2 element type is wild.
1404           ((eq (array-type-element-type type2) *wild-type*)
1405            (values t t))
1406           (;; Since we didn't match any of the special cases above, we
1407            ;; can't give a good answer unless both the element types
1408            ;; have been defined.
1409            (or (unknown-type-p (array-type-element-type type1))
1410                (unknown-type-p (array-type-element-type type2)))
1411            (values nil nil))
1412           (;; Otherwise, the subtype relationship holds iff the
1413            ;; types are equal, and they're equal iff the specialized
1414            ;; element types are identical.
1415            t
1416            (values (type= (specialized-element-type-maybe type1)
1417                           (specialized-element-type-maybe type2))
1418                    t)))))
1419
1420 (!define-superclasses array
1421   ((string string)
1422    (vector vector)
1423    (array))
1424   !cold-init-forms)
1425
1426 (defun array-types-intersect (type1 type2)
1427   (declare (type array-type type1 type2))
1428   (let ((dims1 (array-type-dimensions type1))
1429         (dims2 (array-type-dimensions type2))
1430         (complexp1 (array-type-complexp type1))
1431         (complexp2 (array-type-complexp type2)))
1432     ;; See whether dimensions are compatible.
1433     (cond ((not (or (eq dims1 '*) (eq dims2 '*)
1434                     (and (= (length dims1) (length dims2))
1435                          (every #'(lambda (x y)
1436                                     (or (eq x '*) (eq y '*) (= x y)))
1437                                 dims1 dims2))))
1438            (values nil t))
1439           ;; See whether complexpness is compatible.
1440           ((not (or (eq complexp1 :maybe)
1441                     (eq complexp2 :maybe)
1442                     (eq complexp1 complexp2)))
1443            (values nil t))
1444           ;; If either element type is wild, then they intersect.
1445           ;; Otherwise, the types must be identical.
1446           ((or (eq (array-type-element-type type1) *wild-type*)
1447                (eq (array-type-element-type type2) *wild-type*)
1448                (type= (specialized-element-type-maybe type1)
1449                       (specialized-element-type-maybe type2)))
1450
1451            (values t t))
1452           (t
1453            (values nil t)))))
1454
1455 (!define-type-method (array :simple-intersection) (type1 type2)
1456   (declare (type array-type type1 type2))
1457   (if (array-types-intersect type1 type2)
1458       (let ((dims1 (array-type-dimensions type1))
1459             (dims2 (array-type-dimensions type2))
1460             (complexp1 (array-type-complexp type1))
1461             (complexp2 (array-type-complexp type2))
1462             (eltype1 (array-type-element-type type1))
1463             (eltype2 (array-type-element-type type2)))
1464         (values
1465          (specialize-array-type
1466           (make-array-type
1467            :dimensions (cond ((eq dims1 '*) dims2)
1468                              ((eq dims2 '*) dims1)
1469                              (t
1470                               (mapcar (lambda (x y) (if (eq x '*) y x))
1471                                       dims1 dims2)))
1472            :complexp (if (eq complexp1 :maybe) complexp2 complexp1)
1473            :element-type (if (eq eltype1 *wild-type*) eltype2 eltype1)))
1474          t))
1475       (values *empty-type* t)))
1476
1477 ;;; Check a supplied dimension list to determine whether it is legal,
1478 ;;; and return it in canonical form (as either '* or a list).
1479 (defun canonical-array-dimensions (dims)
1480   (typecase dims
1481     ((member *) dims)
1482     (integer
1483      (when (minusp dims)
1484        (error "Arrays can't have a negative number of dimensions: ~S" dims))
1485      (when (>= dims sb!xc:array-rank-limit)
1486        (error "array type with too many dimensions: ~S" dims))
1487      (make-list dims :initial-element '*))
1488     (list
1489      (when (>= (length dims) sb!xc:array-rank-limit)
1490        (error "array type with too many dimensions: ~S" dims))
1491      (dolist (dim dims)
1492        (unless (eq dim '*)
1493          (unless (and (integerp dim)
1494                       (>= dim 0)
1495                       (< dim sb!xc:array-dimension-limit))
1496            (error "bad dimension in array type: ~S" dim))))
1497      dims)
1498     (t
1499      (error "Array dimensions is not a list, integer or *:~%  ~S" dims))))
1500 \f
1501 ;;;; MEMBER types
1502
1503 (!define-type-class member)
1504
1505 (!define-type-method (member :unparse) (type)
1506   (let ((members (member-type-members type)))
1507     (if (equal members '(nil))
1508         'null
1509         `(member ,@members))))
1510
1511 (!define-type-method (member :simple-subtypep) (type1 type2)
1512   (values (subsetp (member-type-members type1) (member-type-members type2))
1513           t))
1514
1515 (!define-type-method (member :complex-subtypep-arg1) (type1 type2)
1516   (every/type (swapped-args-fun #'ctypep)
1517               type2
1518               (member-type-members type1)))
1519
1520 ;;; We punt if the odd type is enumerable and intersects with the
1521 ;;; MEMBER type. If not enumerable, then it is definitely not a
1522 ;;; subtype of the MEMBER type.
1523 (!define-type-method (member :complex-subtypep-arg2) (type1 type2)
1524   (cond ((not (type-enumerable type1)) (values nil t))
1525         ((types-intersect type1 type2) (values nil nil))
1526         (t
1527          (values nil t))))
1528
1529 (!define-type-method (member :simple-intersection) (type1 type2)
1530   (let ((mem1 (member-type-members type1))
1531         (mem2 (member-type-members type2)))
1532     (values (cond ((subsetp mem1 mem2) type1)
1533                   ((subsetp mem2 mem1) type2)
1534                   (t
1535                    (let ((res (intersection mem1 mem2)))
1536                      (if res
1537                          (make-member-type :members res)
1538                          *empty-type*))))
1539             t)))
1540
1541 (!define-type-method (member :complex-intersection) (type1 type2)
1542   (block punt
1543     (collect ((members))
1544       (let ((mem2 (member-type-members type2)))
1545         (dolist (member mem2)
1546           (multiple-value-bind (val win) (ctypep member type1)
1547             (unless win
1548               (return-from punt (values type2 nil)))
1549             (when val (members member))))
1550
1551         (values (cond ((subsetp mem2 (members)) type2)
1552                       ((null (members)) *empty-type*)
1553                       (t
1554                        (make-member-type :members (members))))
1555                 t)))))
1556
1557 ;;; We don't need a :COMPLEX-UNION, since the only interesting case is
1558 ;;; a union type, and the member/union interaction is handled by the
1559 ;;; union type method.
1560 (!define-type-method (member :simple-union) (type1 type2)
1561   (let ((mem1 (member-type-members type1))
1562         (mem2 (member-type-members type2)))
1563     (cond ((subsetp mem1 mem2) type2)
1564           ((subsetp mem2 mem1) type1)
1565           (t
1566            (make-member-type :members (union mem1 mem2))))))
1567
1568 (!define-type-method (member :simple-=) (type1 type2)
1569   (let ((mem1 (member-type-members type1))
1570         (mem2 (member-type-members type2)))
1571     (values (and (subsetp mem1 mem2)
1572                  (subsetp mem2 mem1))
1573             t)))
1574
1575 (!define-type-method (member :complex-=) (type1 type2)
1576   (if (type-enumerable type1)
1577       (multiple-value-bind (val win) (csubtypep type2 type1)
1578         (if (or val (not win))
1579             (values nil nil)
1580             (values nil t)))
1581       (values nil t)))
1582
1583 (!def-type-translator member (&rest members)
1584   (if members
1585     (make-member-type :members (remove-duplicates members))
1586     *empty-type*))
1587 \f
1588 ;;;; intersection types
1589 ;;;;
1590 ;;;; Until version 0.6.10.6, SBCL followed the original CMU CL approach
1591 ;;;; of punting on all AND types, not just the unreasonably complicated
1592 ;;;; ones. The change was motivated by trying to get the KEYWORD type
1593 ;;;; to behave sensibly:
1594 ;;;;    ;; reasonable definition
1595 ;;;;    (DEFTYPE KEYWORD () '(AND SYMBOL (SATISFIES KEYWORDP)))
1596 ;;;;    ;; reasonable behavior
1597 ;;;;    (ASSERT (SUBTYPEP 'KEYWORD 'SYMBOL))
1598 ;;;; Without understanding a little about the semantics of AND, we'd
1599 ;;;; get (SUBTYPEP 'KEYWORD 'SYMBOL)=>NIL,NIL and, for entirely
1600 ;;;; parallel reasons, (SUBTYPEP 'RATIO 'NUMBER)=>NIL,NIL. That's
1601 ;;;; not so good..)
1602 ;;;;
1603 ;;;; We still follow the example of CMU CL to some extent, by punting
1604 ;;;; (to the opaque HAIRY-TYPE) on sufficiently complicated types
1605 ;;;; involving AND.
1606
1607 ;;; In general, make an INTERSECTION-TYPE object from the specifier
1608 ;;; types. But in various special cases, dodge instead, representing
1609 ;;; the intersection type in some other way.
1610 (defun make-intersection-type-or-something (types)
1611   (declare (list types))
1612   (/show0 "entering MAKE-INTERSECTION-TYPE-OR-SOMETHING")
1613   (cond ((null types)
1614          *universal-type*)
1615         ((null (cdr types))
1616          (first types))
1617         (;; if potentially too hairy
1618          (some (lambda (type)
1619                  (or (union-type-p type)
1620                      (hairy-type-p type)))
1621                types)
1622          ;; (CMU CL punted to HAIRY-TYPE like this for all AND-based
1623          ;; types. We don't want to do that for simple intersection
1624          ;; types like the definition of KEYWORD, hence the guard
1625          ;; clause above. But we do want to punt for any really
1626          ;; unreasonable cases which might have motivated them to punt
1627          ;; in all cases, hence the punt-to-HAIRY-TYPE code below.)
1628          (make-hairy-type :specifier `(and ,@(mapcar #'type-specifier types))))
1629         (t
1630          (%make-intersection-type (some #'type-enumerable types) types))))
1631
1632 (!define-type-class intersection)
1633
1634 ;;; A few intersection types have special names. The others just get
1635 ;;; mechanically unparsed.
1636 (!define-type-method (intersection :unparse) (type)
1637   (declare (type ctype type))
1638   (/show0 "entering INTERSECTION :UNPARSE")
1639   (or (find type '(ratio bignum keyword) :key #'specifier-type :test #'type=)
1640       `(and ,@(mapcar #'type-specifier (intersection-type-types type)))))
1641
1642 ;;; shared machinery for type equality: true if every type in the set
1643 ;;; TYPES1 matches a type in the set TYPES2 and vice versa
1644 (defun type=-set (types1 types2)
1645   (/show0 "entering TYPE=-SET")
1646   (flet (;; true if every type in the set X matches a type in the set Y
1647          (type<=-set (x y)
1648            (declare (type list x y))
1649            (every (lambda (xelement)
1650                     (position xelement y :test #'type=))
1651                   x)))
1652     (values (and (type<=-set types1 types2)
1653                  (type<=-set types2 types1))
1654             t)))
1655
1656 ;;; Two intersection types are equal if their subtypes are equal sets.
1657 ;;;
1658 ;;; FIXME: Might it be better to use
1659 ;;;   (AND (SUBTYPEP X Y) (SUBTYPEP Y X))
1660 ;;; instead, since SUBTYPEP is the usual relationship that we care
1661 ;;; most about, so it would be good to leverage any ingenuity there
1662 ;;; in this more obscure method?
1663 (!define-type-method (intersection :simple-=) (type1 type2)
1664   (/show0 "entering INTERSECTION :SIMPLE-=")
1665   (type=-set (intersection-type-types type1)
1666              (intersection-type-types type2)))
1667
1668 (!define-type-method (intersection :simple-subtypep) (type1 type2)
1669   (declare (type list type1 type2))
1670   (/show0 "entering INTERSECTION :SIMPLE-SUBTYPEP")
1671   (let ((certain? t))
1672     (dolist (t1 (intersection-type-types type1) (values nil certain?))
1673       (multiple-value-bind (subtypep validp)
1674           (intersection-complex-subtypep-arg2 t1 type2)
1675         (cond ((not validp)
1676                (setf certain? nil))
1677               (subtypep
1678                (return (values t t))))))))
1679
1680 (!define-type-method (intersection :complex-subtypep-arg1) (type1 type2)
1681   (/show0 "entering INTERSECTION :COMPLEX-SUBTYPEP-ARG1")
1682   (any/type (swapped-args-fun #'csubtypep)
1683             type2
1684             (intersection-type-types type1)))
1685
1686 (defun intersection-complex-subtypep-arg2 (type1 type2)
1687   (every/type #'csubtypep type1 (intersection-type-types type2)))
1688 (!define-type-method (intersection :complex-subtypep-arg2) (type1 type2)
1689   (/show0 "entering INTERSECTION :COMPLEX-SUBTYPEP-ARG2")
1690   (intersection-complex-subtypep-arg2 type1 type2))
1691
1692 ;;; shared logic for unions and intersections: Return a new type list
1693 ;;; where pairs of types which can be simplified by SIMPLIFY2-FUN have
1694 ;;; been replaced by their simplified forms.
1695 (defun simplify-types (types simplify2-fun)
1696   (declare (type function simplify2-fun))
1697   (let (;; our result, accumulated as a vector
1698         (a (make-array (length types) :fill-pointer 0)))
1699     (dolist (%type types (coerce a 'list))
1700       ;; Merge TYPE into RESULT.
1701       (iterate again ((type %type))
1702         (dotimes (i (length a) (vector-push-extend type a))
1703           (let ((ai (aref a i)))
1704             (multiple-value-bind (simplified win?)
1705                 (funcall simplify2-fun type ai)
1706               (when win?
1707                 (setf (aref a i) (vector-pop a))
1708                 ;; Give the new SIMPLIFIED its own chance to be
1709                 ;; pairwise simplified w.r.t. elements of A.
1710                 (return (again simplified))))))))))
1711
1712 ;;; FIXME: See FIXME note for DEFUN SIMPLIFY2-UNION.
1713 (defun simplify2-intersection (x y)
1714   (let ((intersection (type-intersection x y)))
1715     (if (and (or (intersection-type-p intersection)
1716                  (hairy-type-p intersection))
1717              (not (intersection-type-p x))
1718              (not (intersection-type-p y)))
1719         (values nil nil)
1720         (values intersection t))))
1721
1722 (!define-type-method (intersection :simple-intersection :complex-intersection)
1723                      (type1 type2)
1724   (/show0 "entering INTERSECTION :SIMPLE-INTERSECTION :COMPLEX-INTERSECTION")
1725   (let ((type1types (intersection-type-types type1))
1726         (type2types (if (intersection-type-p type2)
1727                         (intersection-type-types type2)
1728                         (list type2))))
1729     (make-intersection-type-or-something
1730      (simplify-intersection-type-types
1731       (append type1types type2types)))))
1732
1733 #|
1734 (!def-type-translator and (&rest type-specifiers)
1735   ;; Note: Between the behavior of SIMPLIFY-INTERSECTION-TYPE (which
1736   ;; will reduce to a 1-element list any list of types which CMU CL
1737   ;; could've represented) and MAKE-INTERSECTION-TYPE-OR-SOMETHING
1738   ;; (which knows to treat a 1-element intersection as the element
1739   ;; itself) we should recover CMU CL's behavior for anything which it
1740   ;; could handle usefully (i.e. could without punting to HAIRY-TYPE).
1741   (/show0 "entering type translator for AND")
1742   (make-intersection-type-or-something
1743    (simplify-types (mapcar #'specifier-type type-specifiers)
1744                    #'simplify2-intersection)))
1745 |#
1746 ;;; (REMOVEME once INTERSECTION-TYPE works.)
1747 (!def-type-translator and (&whole spec &rest types)
1748   (let ((res *wild-type*))
1749     (dolist (type types res)
1750       (let ((ctype (specifier-type type)))
1751         (multiple-value-bind (int win) (type-intersection res ctype)
1752           (unless win
1753             (return (make-hairy-type :specifier spec)))
1754           (setq res int))))))
1755 \f
1756 ;;;; union types
1757
1758 ;;; Make a union type from the specifier types, setting ENUMERABLE in
1759 ;;; the result if all are enumerable; or take the easy way out if we
1760 ;;; recognize a special case which can be represented more simply.
1761 (defun make-union-type-or-something (types)
1762   (declare (list types))
1763   (/show0 "entering MAKE-UNION-TYPE-OR-SOMETHING")
1764   (cond ((null types)
1765          *empty-type*)
1766         ((null (cdr types))
1767          (first types))
1768         (t
1769          (%make-union-type (every #'type-enumerable types) types))))
1770
1771 (!define-type-class union)
1772
1773 ;;; The LIST type has a special name. Other union types
1774 ;;; just get mechanically unparsed.
1775 (!define-type-method (union :unparse) (type)
1776   (declare (type ctype type))
1777   (if (type= type (specifier-type 'list))
1778       'list
1779       `(or ,@(mapcar #'type-specifier (union-type-types type)))))
1780
1781 ;;; Two union types are equal if their subtypes are equal sets.
1782 (!define-type-method (union :simple-=) (type1 type2)
1783   (type=-set (union-type-types type1)
1784              (union-type-types type2)))
1785
1786 ;;; Similarly, a union type is a subtype of another if every element
1787 ;;; of TYPE1 is a subtype of some element of TYPE2.
1788 ;;;
1789 ;;; KLUDGE: This definition seems redundant, here in UNION-TYPE and
1790 ;;; similarly in INTERSECTION-TYPE, with the logic in the
1791 ;;; corresponding :COMPLEX-SUBTYPEP-ARG1 and :COMPLEX-SUBTYPEP-ARG2
1792 ;;; methods. Ideally there's probably some way to make the
1793 ;;; :SIMPLE-SUBTYPEP method default to the :COMPLEX-SUBTYPEP-FOO
1794 ;;; methods in such a way that this definition could go away, but I
1795 ;;; don't grok the system well enough to tell whether it's simple to
1796 ;;; arrange this. -- WHN 2000-02-03
1797 (!define-type-method (union :simple-subtypep) (type1 type2)
1798   (dolist (t1 (union-type-types type1) (values t t))
1799     (multiple-value-bind (subtypep validp)
1800         (union-complex-subtypep-arg2 t1 type2)
1801       (cond ((not validp)
1802              (return (values nil nil)))
1803             ((not subtypep)
1804              (return (values nil t)))))))
1805
1806 (!define-type-method (union :complex-subtypep-arg1) (type1 type2)
1807   (every/type (swapped-args-fun #'csubtypep)
1808               type2
1809               (union-type-types type1)))
1810
1811 (defun union-complex-subtypep-arg2 (type1 type2)
1812   (any/type #'csubtypep type1 (union-type-types type2)))
1813 (!define-type-method (union :complex-subtypep-arg2) (type1 type2)
1814   (union-complex-subtypep-arg2 type1 type2))
1815
1816 (!define-type-method (union :complex-union) (type1 type2)
1817   (let ((class1 (type-class-info type1)))
1818     (collect ((res))
1819       (let ((this-type type1))
1820         (dolist (type (union-type-types type2)
1821                       (if (res)
1822                           (make-union-type-or-something (cons this-type (res)))
1823                           this-type))
1824           (cond ((eq (type-class-info type) class1)
1825                  (let ((union (funcall (type-class-simple-union class1)
1826                                        this-type type)))
1827                    (if union
1828                        (setq this-type union)
1829                        (res type))))
1830                 ((csubtypep type this-type))
1831                 ((csubtypep type1 type) (return type2))
1832                 (t
1833                  (res type))))))))
1834
1835 ;;; For the union of union types, we let the :COMPLEX-UNION method do
1836 ;;; the work.
1837 (!define-type-method (union :simple-union) (type1 type2)
1838   (let ((res type1))
1839     (dolist (t2 (union-type-types type2) res)
1840       (setq res (type-union res t2)))))
1841
1842 (!define-type-method (union :simple-intersection :complex-intersection)
1843                      (type1 type2)
1844   (let ((res *empty-type*)
1845         (win t))
1846     (dolist (type (union-type-types type2) (values res win))
1847       (multiple-value-bind (int w) (type-intersection type1 type)
1848         (setq res (type-union res int))
1849         (unless w (setq win nil))))))
1850
1851 ;;; FIXME: Obviously, this could be implemented more efficiently if it
1852 ;;; were a primitive. (Making it construct the entire result before
1853 ;;; discarding it because it turns out to be insufficiently simple is
1854 ;;; less than optimum.) A little less obviously, if it were a
1855 ;;; primitive, we could use it a lot more -- basically everywhere we
1856 ;;; do MAKE-UNION-TYPE-OR-SOMETHING. So perhaps this should become
1857 ;;; a primitive; and SIMPLIFY2-INTERSECTION, too, for the same reason.
1858 (defun simplify2-union (x y)
1859   (let ((union (type-union x y)))
1860     (if (and (or (union-type-p union)
1861                  (hairy-type-p union))
1862              (not (union-type-p x))
1863              (not (union-type-p y)))
1864         (values nil nil)
1865         (values union t))))
1866
1867 (!def-type-translator or (&rest type-specifiers)
1868   ;; FIXME: new code -- doesn't work?
1869   #|
1870   (make-union-type-or-something
1871    (simplify-types (mapcar #'specifier-type type-specifiers)
1872                    #'simplify2-union))
1873   |#
1874   ;; old code
1875   (reduce #'type-union
1876           (mapcar #'specifier-type type-specifiers)
1877           :initial-value *empty-type*))
1878 \f
1879 ;;;; CONS types
1880
1881 (!define-type-class cons)
1882
1883 (!def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*))
1884   (make-cons-type (specifier-type car-type-spec)
1885                   (specifier-type cdr-type-spec)))
1886
1887 (!define-type-method (cons :unparse) (type)
1888   (let ((car-eltype (type-specifier (cons-type-car-type type)))
1889         (cdr-eltype (type-specifier (cons-type-cdr-type type))))
1890     (if (and (member car-eltype '(t *))
1891              (member cdr-eltype '(t *)))
1892         'cons
1893         `(cons ,car-eltype ,cdr-eltype))))
1894
1895 (!define-type-method (cons :simple-=) (type1 type2)
1896   (declare (type cons-type type1 type2))
1897   (and (type= (cons-type-car-type type1) (cons-type-car-type type2))
1898        (type= (cons-type-cdr-type type1) (cons-type-cdr-type type2))))
1899
1900 (!define-type-method (cons :simple-subtypep) (type1 type2)
1901   (declare (type cons-type type1 type2))
1902   (multiple-value-bind (val-car win-car)
1903       (csubtypep (cons-type-car-type type1) (cons-type-car-type type2))
1904     (multiple-value-bind (val-cdr win-cdr)
1905         (csubtypep (cons-type-cdr-type type1) (cons-type-cdr-type type2))
1906       (if (and val-car val-cdr)
1907           (values t (and win-car win-cdr))
1908           (values nil (or win-car win-cdr))))))
1909
1910 ;;; Give up if a precise type is not possible, to avoid returning
1911 ;;; overly general types.
1912 (!define-type-method (cons :simple-union) (type1 type2)
1913   (declare (type cons-type type1 type2))
1914   (let ((car-type1 (cons-type-car-type type1))
1915         (car-type2 (cons-type-car-type type2))
1916         (cdr-type1 (cons-type-cdr-type type1))
1917         (cdr-type2 (cons-type-cdr-type type2)))
1918     (cond ((type= car-type1 car-type2)
1919            (make-cons-type car-type1
1920                            (type-union cdr-type1 cdr-type2)))
1921           ((type= cdr-type1 cdr-type2)
1922            (make-cons-type (type-union cdr-type1 cdr-type2)
1923                            cdr-type1)))))
1924
1925 (!define-type-method (cons :simple-intersection) (type1 type2)
1926   (declare (type cons-type type1 type2))
1927   (multiple-value-bind (int-car win-car)
1928       (type-intersection (cons-type-car-type type1)
1929                          (cons-type-car-type type2))
1930     (multiple-value-bind (int-cdr win-cdr)
1931         (type-intersection (cons-type-cdr-type type1)
1932                            (cons-type-cdr-type type2))
1933       (values (make-cons-type int-car int-cdr)
1934               (and win-car win-cdr)))))
1935 \f
1936 ;;; Return the type that describes all objects that are in X but not
1937 ;;; in Y. If we can't determine this type, then return NIL.
1938 ;;;
1939 ;;; For now, we only are clever dealing with union and member types.
1940 ;;; If either type is not a union type, then we pretend that it is a
1941 ;;; union of just one type. What we do is remove from X all the types
1942 ;;; that are a subtype any type in Y. If any type in X intersects with
1943 ;;; a type in Y but is not a subtype, then we give up.
1944 ;;;
1945 ;;; We must also special-case any member type that appears in the
1946 ;;; union. We remove from X's members all objects that are TYPEP to Y.
1947 ;;; If Y has any members, we must be careful that none of those
1948 ;;; members are CTYPEP to any of Y's non-member types. We give up in
1949 ;;; this case, since to compute that difference we would have to break
1950 ;;; the type from X into some collection of types that represents the
1951 ;;; type without that particular element. This seems too hairy to be
1952 ;;; worthwhile, given its low utility.
1953 (defun type-difference (x y)
1954   (let ((x-types (if (union-type-p x) (union-type-types x) (list x)))
1955         (y-types (if (union-type-p y) (union-type-types y) (list y))))
1956     (collect ((res))
1957       (dolist (x-type x-types)
1958         (if (member-type-p x-type)
1959             (collect ((members))
1960               (dolist (mem (member-type-members x-type))
1961                 (multiple-value-bind (val win) (ctypep mem y)
1962                   (unless win (return-from type-difference nil))
1963                   (unless val
1964                     (members mem))))
1965               (when (members)
1966                 (res (make-member-type :members (members)))))
1967             (dolist (y-type y-types (res x-type))
1968               (multiple-value-bind (val win) (csubtypep x-type y-type)
1969                 (unless win (return-from type-difference nil))
1970                 (when val (return))
1971                 (when (types-intersect x-type y-type)
1972                   (return-from type-difference nil))))))
1973
1974       (let ((y-mem (find-if #'member-type-p y-types)))
1975         (when y-mem
1976           (let ((members (member-type-members y-mem)))
1977             (dolist (x-type x-types)
1978               (unless (member-type-p x-type)
1979                 (dolist (member members)
1980                   (multiple-value-bind (val win) (ctypep member x-type)
1981                     (when (or (not win) val)
1982                       (return-from type-difference nil)))))))))
1983
1984       (cond ((null (res)) *empty-type*)
1985             ((null (rest (res))) (first (res)))
1986             (t
1987              (make-union-type-or-something (res)))))))
1988 \f
1989 (!def-type-translator array (&optional (element-type '*)
1990                                       (dimensions '*))
1991   (specialize-array-type
1992    (make-array-type :dimensions (canonical-array-dimensions dimensions)
1993                     :element-type (specifier-type element-type))))
1994
1995 (!def-type-translator simple-array (&optional (element-type '*)
1996                                              (dimensions '*))
1997   (specialize-array-type
1998    (make-array-type :dimensions (canonical-array-dimensions dimensions)
1999                     :element-type (specifier-type element-type)
2000                     :complexp nil)))
2001 \f
2002 (!defun-from-collected-cold-init-forms !late-type-cold-init)