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