tests/type.pure.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; While most of SBCL is derived from the CMU CL system, the test
   5 ;;;; files (like this one) were written from scratch after the fork
   6 ;;;; from CMU CL.
   7 ;;;;
   8 ;;;; This software is in the public domain and is provided with
   9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  10 ;;;; more information.
  11
  12 (enable-test-parallelism)
  13
  14 (assert (not (sb-kernel:member-type-p (sb-kernel:make-eql-type #\z))))
  15 (assert (not (sb-kernel:member-type-p (sb-kernel:make-eql-type 1.0))))
  16 (assert (sb-kernel:member-type-p (sb-kernel:make-eql-type -0.0s0)))
  17
  18 (with-test (:name (typexpand-1 typexpand typexpand-all :check-lexenv))
  19   (flet ((try (f) (assert-error (funcall f 'hash-table 3))))
  20     (mapc #'try '(typexpand-1 typexpand typexpand-all))))
  21
  22 (with-test (:name :no-*-as-t) ; lp#1860919
  23   (assert-signal (sb-kernel:specifier-type '(function (*) t)) warning)
  24   (dolist (f '((lambda (x) (the * x))
  25                (lambda (x) (declare (* x)) x)
  26                (lambda (x) (declare (type * x)) x)))
  27     (multiple-value-bind (f warn err)
  28         (let ((*error-output* (make-broadcast-stream))) (compile nil f))
  29       (declare (ignore f))
  30       (assert (and warn err)))))
  31
  32 (with-test (:name (typep sb-kernel:ctypep))
  33   (locally
  34       (declare (notinline mapcar))
  35     (mapcar (lambda (args)
  36               (destructuring-bind (obj type-spec result) args
  37                 (flet ((matches-result? (x)
  38                          (eq (if x t nil) result)))
  39                   (assert (matches-result? (typep obj type-spec)))
  40                   (assert (matches-result? (sb-kernel:ctypep
  41                                             obj
  42                                             (sb-kernel:specifier-type
  43                                              type-spec)))))))
  44             '((nil (or null vector)              t)
  45               (nil (or number vector)            nil)
  46               (12  (or null vector)              nil)
  47               (12  (and (or number vector) real) t)))))
  48
  49
  50 ;;; This test is motivated by bug #195, which previously had (THE REAL
  51 ;;; #(1 2 3)) give an error which prints as "This is not a (OR
  52 ;;; SINGLE-FLOAT DOUBLE-FLOAT RATIONAL)".  We ideally want all of the
  53 ;;; defined-by-ANSI types to unparse as themselves or at least
  54 ;;; something similar (e.g. CHARACTER can unparse to BASE-CHAR, since
  55 ;;; the types are equivalent in current SBCL, and EXTENDED-CHAR can
  56 ;;; unparse to NIL, since there are no EXTENDED-CHARs currently).
  57 (with-test (:name :standard-types)
  58   (let ((standard-types '(;; from table 4-2 in section 4.2.3 in the
  59                           ;; CLHS.
  60                           arithmetic-error
  61                           function
  62                           simple-condition
  63                           array
  64                           generic-function
  65                           simple-error
  66                           atom
  67                           hash-table
  68                           simple-string
  69                           base-char
  70                           integer
  71                           simple-type-error
  72                           base-string
  73                           keyword
  74                           simple-vector
  75                           bignum
  76                           list
  77                           simple-warning
  78                           bit
  79                           logical-pathname
  80                           single-float
  81                           bit-vector
  82                           long-float
  83                           standard-char
  84                           broadcast-stream
  85                           method
  86                           standard-class
  87                           built-in-class
  88                           method-combination
  89                           standard-generic-function
  90                           cell-error
  91                           nil
  92                           standard-method
  93                           character
  94                           null
  95                           standard-object
  96                           class
  97                           number
  98                           storage-condition
  99                           compiled-function
 100                           package
 101                           stream
 102                           complex
 103                           package-error
 104                           stream-error
 105                           concatenated-stream
 106                           parse-error
 107                           string
 108                           condition
 109                           pathname
 110                           string-stream
 111                           cons
 112                           print-not-readable
 113                           structure-class
 114                           control-error
 115                           program-error
 116                           structure-object
 117                           division-by-zero
 118                           random-state
 119                           style-warning
 120                           double-float
 121                           ratio
 122                           symbol
 123                           echo-stream
 124                           rational
 125                           synonym-stream
 126                           end-of-file
 127                           reader-error
 128                           t
 129                           error
 130                           readtable
 131                           two-way-stream
 132                           extended-char
 133                           real
 134                           type-error
 135                           file-error
 136                           restart
 137                           unbound-slot
 138                           file-stream
 139                           sequence
 140                           unbound-variable
 141                           fixnum
 142                           serious-condition
 143                           undefined-function
 144                           float
 145                           short-float
 146                           unsigned-byte
 147                           floating-point-inexact
 148                           signed-byte
 149                           vector
 150                           floating-point-invalid-operation
 151                           simple-array
 152                           warning
 153                           floating-point-overflow
 154                           simple-base-string
 155                           floating-point-underflow
 156                           simple-bit-vector)))
 157     (dolist (type standard-types)
 158       #+nil (format t "~&~S~%" type)
 159       (assert (not (sb-kernel:unknown-type-p (sb-kernel:specifier-type type))))
 160       (assert (atom (sb-kernel:type-specifier (sb-kernel:specifier-type type)))))))
 161
 162 ;;; a bug underlying the reported bug #221: The SB-KERNEL type code
 163 ;;; signalled an error on this expression.
 164 (with-test (:name (subtypep function values :bug-221))
 165   (subtypep '(function (fixnum) (values package boolean))
 166             '(function (t) (values package boolean))))
 167
 168 ;;; bug reported by Valtteri Vuorik
 169 (with-test (:name (subtypep function &rest))
 170   (checked-compile '(lambda () (member (char "foo" 0) '(#\. #\/) :test #'char=)))
 171   (assert-tri-eq t   t (subtypep '(function ()) '(function (&rest t))))
 172   (assert-tri-eq nil t (subtypep '(function (&rest t)) '(function ())))
 173   (assert-tri-eq t   t (subtypep '(function)
 174                                  '(function (&optional t &rest t))))
 175   (assert-tri-eq nil t (subtypep '(function) '(function (t &rest t))))
 176   (assert-tri-eq t   t (subtypep 'function '(function)))
 177   (assert-tri-eq t   t (subtypep '(function) 'function)))
 178
 179 ;;; Absent any exciting generalizations of |R, the type RATIONAL is
 180 ;;; partitioned by RATIO and INTEGER.  Ensure that the type system
 181 ;;; knows about this.  [ the type system is permitted to return NIL,
 182 ;;; NIL for these, so if future maintenance breaks these tests that
 183 ;;; way, that's fine.  What the SUBTYPEP calls are _not_ allowed to
 184 ;;; return is NIL, T, because that's completely wrong. ]
 185 (with-test (:name (subtypep integer ratio rational))
 186   (assert-tri-eq t t (subtypep '(or integer ratio) 'rational))
 187   (assert-tri-eq t t (subtypep 'rational '(or integer ratio))))
 188
 189 ;;; Likewise, these are allowed to return NIL, NIL, but shouldn't
 190 ;;; return NIL, T:
 191 (with-test (:name (subtypep or and not))
 192   (assert-tri-eq t t (subtypep t '(or real (not real))))
 193   (assert-tri-eq t t (subtypep t '(or keyword (not keyword))))
 194   (assert-tri-eq t t (subtypep '(and cons (not (cons symbol integer)))
 195                                '(or (cons (not symbol) *) (cons * (not integer)))))
 196   (assert-tri-eq t t (subtypep '(or (cons (not symbol) *) (cons * (not integer)))
 197                                '(and cons (not (cons symbol integer)))))
 198   (assert-tri-eq t t (subtypep '(or (eql 0) (rational (0) 10))
 199                                '(rational 0 10)))
 200   (assert-tri-eq t t (subtypep '(rational 0 10)
 201                                '(or (eql 0) (rational (0) 10)))))
 202
 203 ;;; Until sbcl-0.7.13.7, union of CONS types when the CDRs were the
 204 ;;; same type gave exceedingly wrong results
 205 (with-test (:name (subtypep cons :same-cdr))
 206   (let ((a '(or (cons fixnum single-float) (cons bignum single-float)))
 207         (b '(cons single-float single-float))
 208         (c '(cons integer single-float)))
 209     (assert-tri-eq nil t (subtypep a b))
 210     (assert-tri-eq t   t (subtypep c a))))
 211
 212 (with-test (:name (subtypep :unknown-type))
 213   (checked-compile-and-assert (:allow-style-warnings t)
 214       '(lambda ()
 215          (subtypep '(and null some-unknown-type) 'another-unknown-type))
 216     (() (values nil nil) :allow-conditions 'sb-kernel:parse-unknown-type)))
 217
 218 ;;; bug 46c
 219 (with-test (:name (coerce function :on :macro))
 220   (dolist (fun '(and if))
 221     (assert-error (coerce fun 'function))))
 222
 223 (with-test (:name (typep array class-of))
 224   (dotimes (i 100)
 225     (let ((x (make-array 0 :element-type `(unsigned-byte ,(1+ i)))))
 226       (eval `(typep ,x (class-of ,x))))))
 227
 228 (with-test (:name (typep complex member))
 229   (assert (not (typep #c(1 2) '(member #c(2 1)))))
 230   (assert (typep #c(1 2) '(member #c(1 2)))))
 231
 232 (with-test (:name (subtypep complex))
 233   (assert-tri-eq t   t (subtypep 'nil '(complex nil)))
 234   (assert-tri-eq t   t (subtypep '(complex nil) 'nil))
 235   (assert-tri-eq t   t (subtypep 'nil '(complex (eql 0))))
 236   (assert-tri-eq t   t (subtypep '(complex (eql 0)) 'nil))
 237   (assert-tri-eq t   t (subtypep 'nil '(complex (integer 0 0))))
 238   (assert-tri-eq t   t (subtypep '(complex (integer 0 0)) 'nil))
 239   (assert-tri-eq t   t (subtypep 'nil '(complex (rational 0 0))))
 240   (assert-tri-eq t   t (subtypep '(complex (rational 0 0)) 'nil))
 241   (assert-tri-eq t   t (subtypep 'complex '(complex real)))
 242   (assert-tri-eq t   t (subtypep '(complex real) 'complex))
 243   (assert-tri-eq t   t (subtypep '(complex (eql 1)) '(complex (member 1 2))))
 244   (assert-tri-eq t   t (subtypep '(complex ratio) '(complex rational)))
 245   (assert-tri-eq t   t (subtypep '(complex ratio) 'complex))
 246   (assert-tri-eq nil t (subtypep '(complex (integer 1 2))
 247                                  '(member #c(1 1) #c(1 2) #c(2 1) #c(2 2)))))
 248
 249 (with-test (:name (typep real))
 250   (assert (typep 0 `(real ,(ash -1 10000) ,(ash 1 10000)))))
 251
 252 (with-test (:name (subtypep real))
 253   (assert-tri-eq t t (subtypep `(real ,(ash -1 1000) ,(ash 1 1000))
 254                                `(real ,(ash -1 10000) ,(ash 1 10000))))
 255   (assert-tri-eq t t (subtypep `(real (,(ash -1 1000)) (,(ash 1 1000)))
 256                                `(real ,(ash -1 1000) ,(ash 1 1000)))))
 257
 258 ;;; Bug, found by Paul F. Dietz
 259 (with-test (:name (typep subtypep complex rational))
 260   (let* ((x (eval #c(-1 1/2)))
 261          (type (type-of x)))
 262     (assert (subtypep type '(complex rational)))
 263     (assert (typep x type))))
 264
 265 ;;; Test derivation of LOG{AND,IOR,XOR} bounds for unsigned arguments.
 266 ;;;
 267 ;;; Fear the Loop of Doom!
 268 ;;;
 269 ;;; (In fact, this is such a fearsome loop that executing it with the
 270 ;;; evaluator would take ages... Disable it under those circumstances.)
 271 #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
 272 (with-test (:name (:type-derivation :logical-operations :correctness) :slow t)
 273   (let* ((n-bits 5)
 274          (size (ash 1 n-bits)))
 275     (labels ((brute-force (a b c d op)
 276                (loop with min = (ash 1 n-bits)
 277                      with max = 0
 278                      for i from a upto b do
 279                      (loop for j from c upto d do
 280                            (let ((x (funcall op i j)))
 281                              (setf min (min min x)
 282                                    max (max max x))))
 283                      finally (return (values min max))))
 284              (test (a b c d op deriver)
 285                (multiple-value-bind (brute-low brute-high)
 286                    (brute-force a b c d op)
 287                  (multiple-value-bind (test-low test-high)
 288                      (funcall deriver
 289                               (sb-c::specifier-type `(integer ,a ,b))
 290                               (sb-c::specifier-type `(integer ,c ,d)))
 291                    (unless (and (= brute-low test-low)
 292                                 (= brute-high test-high))
 293                      (format t "FAIL: ~A [~D, ~D] [~D, ~D]~%EXPECTED [~D, ~D] GOT [~D, ~D]~%"
 294                              op a b c d
 295                              brute-low brute-high test-low test-high)
 296                      (assert (and (= brute-low test-low)
 297                                   (= brute-high test-high))))))))
 298       (dolist (op '(logand logior logxor))
 299         (let ((deriver (intern (format nil "~A-DERIVE-UNSIGNED-BOUNDS" op)
 300                                (find-package :sb-c))))
 301           #+(or) (format t "testing type derivation: ~A~%" deriver)
 302           (loop for a from 0 below size do
 303                 (loop for b from a below size do
 304                       (loop for c from 0 below size do
 305                             (loop for d from c below size do
 306                                   (test a b c d op deriver))))))))))
 307
 308 (with-test (:name (:type-derivation :logical-operations :scaling) :slow t)
 309   (let ((type-x1 (sb-c::specifier-type `(integer ,(expt 2 10000)
 310                                                  ,(expt 2 10000))))
 311         (type-x2 (sb-c::specifier-type `(integer ,(expt 2 100000)
 312                                                  ,(expt 2 100000))))
 313         (type-y (sb-c::specifier-type '(integer 0 1))))
 314     (dolist (op '(logand logior logxor))
 315       (let* ((deriver (intern (format nil "~A-DERIVE-TYPE-AUX" op)
 316                               (find-package :sb-c)))
 317              (scale (/ (runtime (funcall deriver type-x2 type-y))
 318                        (runtime (funcall deriver type-x1 type-y)))))
 319         ;; Linear scaling is good, quadratical bad. Draw the line
 320         ;; near the geometric mean of the corresponding SCALEs.
 321         (when (> scale 40)
 322           (error "Bad scaling of ~a: input 10 times but runtime ~a times as large."
 323                  deriver scale))))))
 324
 325 ;;; SUBTYPEP on CONS types wasn't taking account of the fact that a
 326 ;;; CONS type could be the empty type (but no other non-CONS type) in
 327 ;;; disguise
 328 (with-test (:name (subtypep cons :empty))
 329   (multiple-value-bind (yes win)
 330       (subtypep '(and function stream) 'nil)
 331     (multiple-value-bind (cyes cwin)
 332         (subtypep '(cons (and function stream) t)
 333                   '(cons nil t))
 334       (assert (eq yes cyes))
 335       (assert (eq win cwin)))))
 336
 337 (with-test (:name :intelligent-satisfies)
 338   (assert (sb-kernel:type= (sb-kernel:specifier-type '(satisfies realp))
 339                            (sb-kernel:specifier-type 'real)))
 340   ;; Part of an example in https://bugs.launchpad.net/sbcl/+bug/309455
 341   (multiple-value-bind (answer certain)
 342       (subtypep 'complex '(and number (satisfies realp)))
 343     (assert (not answer))
 344     (assert certain)))
 345
 346 ;;; CONS type SUBTYPEP could be too enthusiastic about thinking it was
 347 ;;; certain
 348 (with-test (:name (subtypep cons satisfies))
 349   (assert-tri-eq nil nil (subtypep '(satisfies foo) '(satisfies bar)))
 350   (assert-tri-eq nil nil (subtypep '(cons (satisfies foo) t)
 351                                    '(cons (satisfies bar) t))))
 352
 353 (with-test (:name (subtypep generic-function function))
 354   (assert-tri-eq t t (subtypep 'generic-function 'function)))
 355
 356 ;;; this would be in some internal test suite like type.before-xc.lisp
 357 ;;; except that generic functions don't exist at that stage.
 358 (with-test (:name (subtypep generic-function sb-kernel:funcallable-instance))
 359   (assert-tri-eq t t (subtypep 'generic-function
 360                                'sb-kernel:funcallable-instance)))
 361
 362 ;;; all sorts of answers are right for this one, but it used to
 363 ;;; trigger an AVER instead.
 364 (with-test (:name (subtypep function satisfies :smoke))
 365   (subtypep '(function ()) '(and (function ()) (satisfies identity))))
 366
 367 (with-test (:name (sb-kernel:specifier-type :unknown-type))
 368   (assert (sb-kernel:unknown-type-p (sb-kernel:specifier-type 'an-unkown-type))))
 369
 370 (with-test (:name (sb-kernel:type= array))
 371   (assert-tri-eq t   t (ctype= '(or (simple-array an-unkown-type (*))
 372                                     (simple-array an-unkown-type))
 373                                '(or (simple-array an-unkown-type (*))
 374                                     (simple-array an-unkown-type))))
 375   (assert-tri-eq t   t (ctype= '(simple-array an-unkown-type (*))
 376                                '(simple-array an-unkown-type (*))))
 377   (assert-tri-eq nil t (ctype= '(simple-array an-unkown-type (*))
 378                                '(array an-unkown-type (*))))
 379   (assert-tri-eq nil t (ctype= '(simple-array an-unkown-type (7))
 380                                '(simple-array an-unkown-type (8)))))
 381
 382 (with-test (:name (sb-kernel:type= cons))
 383   (assert-tri-eq nil t (ctype= 'cons '(cons single-float single-float)))
 384   (assert-tri-eq nil t (ctype= '(cons integer) '(cons))))
 385
 386 (with-test (:name (typep subtypep sb-kernel:instance))
 387   (assert (typep #p"" 'sb-kernel:instance))
 388   (assert-tri-eq t t (subtypep '(member #p"") 'sb-kernel:instance)))
 389
 390 (with-test (:name (sb-kernel:type= :simd-pack))
 391   (dolist (x '(single-float double-float))
 392     (let ((spec `(simd-pack ,x)))
 393       (assert (equal (multiple-value-list (ctype= spec spec)) '(t t))))))
 394
 395 (with-test (:name (typep :character-set :negation))
 396   (flet ((generate-chars ()
 397            (loop repeat 100
 398                  collect (code-char (random char-code-limit)))))
 399     (dotimes (i 1000)
 400       (let* ((chars (generate-chars))
 401              (type `(member ,@chars))
 402              (not-type `(not ,type)))
 403         (dolist (char chars)
 404           (assert (typep char type))
 405           (assert (not (typep char not-type))))
 406         (let ((other-chars (generate-chars)))
 407           (dolist (char other-chars)
 408             (unless (member char chars)
 409               (assert (not (typep char type)))
 410               (assert (typep char not-type)))))))))
 411
 412 (with-test (:name (check-type :store-value :complex-place))
 413   (let ((a (cons 0.0 2))
 414         (handler-invoked nil))
 415     (handler-bind ((error
 416                     (lambda (c)
 417                       (declare (ignore c))
 418                       (assert (not handler-invoked))
 419                       (setf handler-invoked t)
 420                       (invoke-restart 'store-value 1))))
 421       (check-type (car a) integer))
 422     (assert (eql (car a) 1))))
 423
 424 ;;; The VOP FIXNUMP/UNSIGNED-BYTE-64 was broken on x86-64, failing
 425 ;;; the first ASSERT below. The second ASSERT takes care that the fix
 426 ;;; doesn't overshoot the mark.
 427 (with-test (:name (typep :fixnum-if-unsigned-byte))
 428   (checked-compile-and-assert ()
 429       '(lambda (x)
 430         (declare (type (unsigned-byte #.sb-vm:n-word-bits) x))
 431         (typep x (quote fixnum)))
 432     (((1+ most-positive-fixnum)) nil)
 433     ((most-positive-fixnum)      t)))
 434
 435 (with-test (:name (typep :member :uses eql))
 436   (assert (eval '(typep 1/3 '(member 1/3 nil))))
 437   (assert (eval '(typep 1.0 '(member 1.0 t))))
 438   (assert (eval '(typep #c(1.1 1.2) '(member #c(1.1 1.2)))))
 439   (assert (eval '(typep #c(1 1) '(member #c(1 1)))))
 440   (let ((bignum1 (+ 12 most-positive-fixnum))
 441         (bignum2 (- (+ 15 most-positive-fixnum) 3)))
 442     (assert (eval `(typep ,bignum1 '(member ,bignum2))))))
 443
 444 (with-test (:name :opt+rest+key-canonicalization)
 445   (let ((type '(function (&optional t &rest t &key (:x t) (:y t)) *)))
 446     (assert (equal type (sb-kernel:type-specifier (sb-kernel:specifier-type type))))))
 447
 448 (with-test (:name :bug-369)
 449   (let ((types (mapcar #'sb-c::values-specifier-type
 450                        '((values (vector package) &optional)
 451                          (values (vector package) &rest t)
 452                          (values (vector hash-table) &rest t)
 453                          (values (vector hash-table) &optional)
 454                          (values t &optional)
 455                          (values t &rest t)
 456                          (values nil &optional)
 457                          (values nil &rest t)
 458                          (values sequence &optional)
 459                          (values sequence &rest t)
 460                          (values list &optional)
 461                          (values list &rest t)))))
 462     (dolist (x types)
 463       (dolist (y types)
 464         (let ((i (sb-c::values-type-intersection x y)))
 465           (assert (sb-c::type= i (sb-c::values-type-intersection i x)))
 466           (assert (sb-c::type= i (sb-c::values-type-intersection i y))))))))
 467
 468 (with-test (:name (subtypep keyword symbol :bug-485972))
 469   (assert-tri-eq nil t (subtypep 'symbol 'keyword))
 470   (assert-tri-eq t   t (subtypep 'keyword 'symbol)))
 471
 472 ;; WARNING: this test case would fail by recursing into the stack's guard page.
 473 (with-test (:name (sb-kernel:specifier-type or and satisfies :bug-883498))
 474   (sb-kernel:specifier-type
 475    '(or (integer -2 -2)
 476         (and (satisfies foo) (rational -3/2 -3/2)))))
 477
 478 ;; The infinite recursion mentioned in the previous test was caused by an
 479 ;; attempt to get the following right.
 480 (with-test (:name :quirky-integer-rational-union)
 481   (assert-tri-eq t t (subtypep '(or (integer * -1)
 482                                     (and (rational * -1/2) (not integer)))
 483                                '(rational * -1/2)))
 484   (assert-tri-eq t t (subtypep '(rational * -1/2)
 485                                '(or (integer * -1)
 486                                     (and (rational * -1/2) (not integer))))))
 487
 488 ;; for the longest time (at least 05525d3a), single-value-type would
 489 ;; return CHARACTER on this.
 490 (with-test (:name :single-value-&optional-type)
 491   (assert (sb-c::type= (sb-c::single-value-type
 492                         (sb-c::values-specifier-type '(values &optional character)))
 493                        (sb-c::specifier-type '(or null character)))))
 494
 495 ;; lp#1317308 - TYPE-OF must not return a type specifier
 496 ;; involving AND,EQL,MEMBER,NOT,OR,SATISFIES,or VALUES.
 497 (with-test (:name :ANSIly-report-hairy-array-type)
 498   (let ((simp-t (make-array 9))
 499         (simp-bit (make-array 16 :element-type 'bit)))
 500     ;; TYPE-OF doesn't have an optimization that returns a constant specifier
 501     ;; from a non-constant array of known type. If it did, we'd probably
 502     ;; want to check that these results are all equal:
 503     ;;  - the runtime-determined type
 504     ;;  - the compile-time-determined constant type
 505     ;;  - the compile-time-determined type of an equivalent object
 506     ;;    that is in fact a compile-time constant
 507     (flet ((our-type-of (x) (sb-kernel:type-specifier (sb-kernel:ctype-of x))))
 508       (let ((hairy-t (make-array 3 :displaced-to simp-t)))
 509         (assert (equal (our-type-of hairy-t)
 510                        '(vector t)))
 511         (assert (equal (type-of hairy-t) '(vector t 3))))
 512       (let ((hairy-t (make-array '(3 2) :displaced-to simp-t)))
 513         (assert (equal (our-type-of hairy-t)
 514                        '(array t (* *))))
 515         (assert (equal (type-of hairy-t) '(array t (3 2)))))
 516       (let ((hairy-bit
 517               (make-array 5 :displaced-to simp-bit :element-type 'bit)))
 518         (assert (equal (our-type-of hairy-bit)
 519                        'bit-vector))
 520         (assert (equal (type-of hairy-bit) '(bit-vector 5)))))))
 521
 522 (with-test (:name (subtypep array :bug-309098))
 523   (let ((u `(or ,@(map 'list (lambda (x) `(array ,(sb-vm:saetp-specifier x)))
 524                        sb-vm:*specialized-array-element-type-properties*))))
 525     (assert-tri-eq t t (subtypep 'array u))))
 526
 527 (with-test (:name :bug-1258716)
 528   (let ((intersection (sb-kernel:type-intersection
 529                        (sb-kernel:specifier-type 'simple-vector)
 530                        (sb-kernel:specifier-type `(vector #:unknown)))))
 531     (assert (sb-kernel:array-type-p intersection))
 532     ;; and not *wild-type*
 533     (assert (sb-kernel:type= (sb-kernel:array-type-specialized-element-type intersection)
 534                              sb-kernel:*universal-type*))))
 535
 536 (with-test (:name :parse-safely)
 537   (dolist (x '(array integer cons))
 538     (assert (handler-case (sb-kernel:specifier-type `(,x . 0))
 539               (sb-kernel::arg-count-error () t)
 540               (error (c) (print c) nil)))))
 541
 542 (with-test (:name :unparse-safely)
 543   (let* ((intersection (sb-kernel:type-intersection
 544                         (sb-kernel:specifier-type '(vector (or bit character)))
 545                         (sb-kernel:specifier-type `(vector (or bit symbol)))))
 546          (round-trip (sb-kernel:specifier-type
 547                      (sb-kernel:type-specifier intersection))))
 548     (assert (sb-kernel:type= intersection round-trip))
 549     (assert (sb-kernel:array-type-p intersection))
 550     ;; and not *wild-type*
 551     (assert (sb-kernel:type/= (sb-kernel:array-type-specialized-element-type intersection)
 552                               (sb-kernel:specifier-type 'bit)))))
 553
 554 ;; lp#1333731
 555 (with-test (:name (adjust-array :changes type-of))
 556   ;; I think adjusting an array to enlarge it must read all the old data,
 557   ;; which would be undefined behavior if you hadn't initialized the array.
 558   (let ((a (make-array 10 :adjustable t :initial-element 0)))
 559     (assert (equal (type-of a) '(vector t 10)))
 560     (adjust-array a 20)
 561     (assert (equal (type-of a) '(vector t 20)))))
 562
 563 (with-test (:name :unknown-type-strongly-uncacheable)
 564   ;; VALUES-SPECIFIER-TYPE should not cache a specifier any part of which
 565   ;; is unknown. This leads to consistent results when parsing unknown
 566   ;; types. Previously it was indeterminate whether a condition would
 567   ;; be signaled for (OR UNKNOWN KNOWN) depending on whether that expression
 568   ;; had ever been parsed and whether it had been evicted from the cache.
 569   (assert-signal (progn (sb-kernel:specifier-type '(or weeble ratio))
 570                         (sb-kernel:specifier-type '(or weeble ratio)))
 571                  sb-kernel:parse-unknown-type 2) ; expect 2 signals
 572   (assert-signal (progn (sb-kernel:specifier-type '(and potrzebie real))
 573                         (sb-kernel:specifier-type '(and potrzebie real)))
 574                  sb-kernel:parse-unknown-type 2) ; expect 2 signals
 575   (assert-signal (progn (sb-kernel:specifier-type '(array strudel))
 576                         (sb-kernel:specifier-type '(array strudel)))
 577                  sb-kernel:parse-unknown-type 2) ; expect 2 signals
 578   (assert-signal (progn (sb-kernel:specifier-type '(not bad))
 579                         (sb-kernel:specifier-type '(not bad)))
 580                  sb-kernel:parse-unknown-type 2)) ; expect 2 signals
 581
 582 (with-test (:name (typep :complex-integer))
 583   (assert (not (eval '(typep #c(0 1/2) '(complex integer))))))
 584
 585 (with-test (:name :typep-satisfies-boolean)
 586   (assert (eq (eval '(typep 1 '(satisfies eval))) t)))
 587
 588 (import '(sb-kernel:specifier-type
 589           sb-kernel:type-specifier
 590           sb-kernel:type-intersection
 591           #+sb-unicode sb-kernel::character-string
 592           sb-kernel:simple-character-string
 593           sb-kernel:type=
 594           sb-kernel:find-classoid
 595           sb-kernel:make-numeric-type
 596           sb-kernel::numeric-types-adjacent
 597           sb-kernel::numeric-types-intersect
 598           sb-kernel:*empty-type*))
 599
 600 (with-test (:name :partition-array-into-simple/hairy)
 601   ;; Some tests that (simple-array | hairy-array) = array
 602   ;; At present this works only for wild element-type.
 603   (assert-tri-eq
 604    t t (type= (specifier-type '(not (and array (not simple-array))))
 605               (specifier-type '(or (not array) simple-array))))
 606
 607   ;; if X is neither simple-array nor hairy-array, it is not an array
 608   (assert (type= (specifier-type '(and (not simple-array)
 609                                        (not (and array (not simple-array)))))
 610                  (specifier-type '(not array))))
 611
 612   ;; (simple-array * (*)) = (AND (NOT <hairy-array>) VECTOR) etc
 613   (flet ((try (unrestricted simple)
 614            (assert (type= (specifier-type simple)
 615                           (type-intersection
 616                            (specifier-type
 617                             '(not (and array (not simple-array))))
 618                            (specifier-type unrestricted))))))
 619     (try 'vector '(simple-array * (*)))
 620     (try '(vector t) 'simple-vector)
 621     (try 'bit-vector 'simple-bit-vector)
 622     (try 'string 'simple-string)
 623     #+sb-unicode(try 'character-string 'simple-character-string)
 624     (try 'base-string 'simple-base-string))
 625
 626   ;; if X is a known string and not an array-header
 627   ;; it must be a SIMPLE-STRING
 628   (assert (type= (type-intersection
 629                   (specifier-type 'string)
 630                   (specifier-type
 631                    '(not (or (and simple-array (not vector))
 632                              (and array (not simple-array))))))
 633                  (specifier-type 'simple-string))))
 634
 635 (with-test (:name :values-*-illegal)
 636   (dolist (x '((values *)
 637                (values *)
 638                (values * bit)
 639                (values bit *)
 640                (values bit &optional *)
 641                (values bit &rest *)
 642                (values bit &rest *)))
 643     (assert-signal (sb-kernel:values-specifier-type x) warning)))
 644
 645 (with-test (:name :classoids-as-type-specifiers)
 646   (dolist (classoid (list (find-classoid 'integer)
 647                           (find-class 'integer)))
 648     ;; Classoids and classes should work as type specifiers
 649     ;; in the atom form, not as lists.
 650     ;; Their legality or lack thereof is equivalent in all cases.
 651     (checked-compile `(lambda (x) (declare (,classoid x)) x))
 652     (checked-compile `(lambda (x) (declare (type ,classoid x)) x))
 653     ;; Negative tests come in two flavors:
 654     ;; In the case of (DECLARE (TYPE ...)), parsing the following thing
 655     ;; as a type should fail. But when 'TYPE is implied, "canonization"
 656     ;; should do nothing, because the following form is not a type,
 657     ;; so we get an error about an unrecognized declaration instead.
 658     (flet ((expect-lose (type)
 659              (assert (nth-value 1 (checked-compile
 660                                    `(lambda (x) (declare (,type x)) x)
 661                                    :allow-warnings t)))
 662              (assert (nth-value 1 (checked-compile
 663                                    `(lambda (x) (declare (,type x)) x)
 664                                    :allow-warnings t)))))
 665       (expect-lose `(,classoid))
 666       (expect-lose `(,classoid 1 100)))))
 667
 668 (with-test (:name :classoid-type-kind)
 669   (do-all-symbols (s)
 670     (let ((c (sb-kernel:find-classoid s nil)))
 671       ;; No classoid can have a :TYPE :KIND that is :DEFINED.
 672       (when c
 673         (if (typep c 'sb-kernel:built-in-classoid)
 674             (assert (eq (sb-int:info :type :kind s) :primitive))
 675             (assert (eq (sb-int:info :type :kind s) :instance)))))))
 676
 677 (with-test (:name (make-numeric-type :smoke))
 678   (assert (eq (make-numeric-type :class 'integer :low '(4) :high '(5))
 679               *empty-type*)))
 680
 681 (with-test (:name (make-numeric-type :union))
 682   (assert (equal (type-specifier (make-numeric-type :low '(-79106810381456307)))
 683                  `(or (rational (-79106810381456307))
 684                       (single-float (-7.910681e16))
 685                       (double-float (-7.91068103814563d16))))))
 686
 687 (with-test (:name (make-numeric-type :infinities))
 688   ;; Without class
 689   (assert (equal (type-specifier
 690                   (make-numeric-type :low sb-ext:single-float-negative-infinity
 691                                      :high sb-ext:single-float-negative-infinity))
 692                  `(or (single-float ,sb-ext:single-float-negative-infinity
 693                                     ,sb-ext:single-float-negative-infinity)
 694                       (double-float ,sb-ext:double-float-negative-infinity
 695                                     ,sb-ext:double-float-negative-infinity))))
 696   (assert (equal (type-specifier
 697                   (make-numeric-type :low sb-ext:single-float-negative-infinity))
 698                  'real))
 699   ;; With FLOAT class
 700   (assert (equal (type-specifier
 701                   (make-numeric-type :class 'float
 702                                      :low sb-ext:single-float-negative-infinity
 703                                      :high sb-ext:single-float-negative-infinity))
 704                  `(or (single-float ,sb-ext:single-float-negative-infinity
 705                                     ,sb-ext:single-float-negative-infinity)
 706                       (double-float ,sb-ext:double-float-negative-infinity
 707                                     ,sb-ext:double-float-negative-infinity))))
 708   (assert (equal (type-specifier
 709                   (make-numeric-type :class 'float
 710                                      :low sb-ext:single-float-negative-infinity))
 711                  `float)))
 712
 713 (with-test (:name :prettier-union-types :skipped-on (not :sb-unicode))
 714   ;; (OR STRING BIGNUM) used to unparse as
 715   ;; (OR (VECTOR CHARACTER) BASE-STRING (INTEGER * -4611686018427387905)
 716   ;;     (INTEGER 4611686018427387904)) etc
 717   (dolist (other '(float real bignum))
 718     (let* ((spec `(or string ,other))
 719            (parse (sb-kernel:specifier-type spec))
 720            (unparse (sb-kernel:type-specifier parse)))
 721       (assert (or (equal unparse `(or string ,other))
 722                   (equal unparse `(or ,other string)))))))
 723
 724 (with-test (:name :unparse-string)
 725   (assert (equal (type-specifier (specifier-type '(string 10)))
 726                  '(#+sb-unicode string #-sb-unicode base-string 10)))
 727   (assert (equal (type-specifier (specifier-type '(simple-string 10)))
 728                  '(#+sb-unicode simple-string #-sb-unicode simple-base-string 10))))
 729
 730 (with-test (:name :numeric-types-adjacent)
 731   (dolist (x '(-0s0 0s0))
 732     (dolist (y '(-0s0 0s0))
 733       (let ((a (specifier-type `(single-float -10s0 ,x)))
 734             (b (specifier-type `(single-float ,y 20s0))))
 735         (assert (numeric-types-intersect a b)))
 736       (let ((a (specifier-type `(single-float -10s0 (,x))))
 737             (b (specifier-type `(single-float ,y 20s0))))
 738         (assert (not (numeric-types-intersect a b)))
 739         (assert (numeric-types-adjacent a b)))
 740       (let ((a (specifier-type `(single-float -10s0 ,x)))
 741             (b (specifier-type `(single-float (,y) 20s0))))
 742         (assert (not (numeric-types-intersect a b)))
 743         (assert (numeric-types-adjacent a b))))))
 744
 745 (with-test (:name :ctypep-function)
 746   (assert (not (sb-kernel:ctypep #'+ (eval '(sb-kernel:specifier-type '(function (list))))))))
 747
 748 (with-test (:name :cons-union-loop)
 749   (checked-compile-and-assert
 750    ()
 751    `(lambda (x)
 752       (typep x '(or (cons (or fixnum vector (member a "b")))
 753                  (cons (or (and (not vector) array) (and (not integer) number)) number))))
 754    ((10) nil)
 755    (((cons 1 2)) t)))
 756
 757 (with-test (:name :pathnamep-flag-bit)
 758   (let ((f (compile nil '(lambda (x) (pathnamep x)))))
 759     (assert (not (ctu:find-code-constants f)))))
 760
 761 (with-test (:name :structure-is-a)
 762   (dolist (what '(sb-int:sset-element sb-c::leaf sb-c::functional
 763                   sb-c::optional-dispatch))
 764     (assert (eval `(sb-c::%structure-is-a ,(sb-kernel:find-layout 'sb-c::optional-dispatch)
 765                                           ,(sb-kernel:find-layout what))))))
 766
 767 (with-test (:name :type-of-empty-instance)
 768   (assert (eq (type-of (test-util::make-funcallable-instance 6))
 769               'sb-kernel:funcallable-instance))
 770   (assert (eq (type-of (eval '(sb-kernel:%make-instance 12)))
 771               'sb-kernel:instance)))
 772
 773 (with-test (:name (:cons-union :lp1912863))
 774   (let ((c (cons 2 4)))
 775     (assert (not (typep c '(or (cons (integer 0 8) (integer 5 15))
 776                             (cons (integer 3 15) (integer 4 14))))))))
 777
 778 (with-test (:name (:rational-union :equivalent-to-t))
 779   (let ((type '(or (integer * -1) (rational -1/2 1/2) (integer 1) (not integer))))
 780     (assert-tri-eq t t (subtypep t type))))
 781
 782 (with-test (:name (:rational-union :wider-equivalent-to-t))
 783   (let ((type '(or (integer * -2) (rational -3/2 3/2) (integer 2) (not integer))))
 784     (assert-tri-eq t t (subtypep t type))))
 785
 786 (with-test (:name (:rational-union :no-integers-in-rational))
 787   (let ((type '(or (integer 1 1) (rational 1/2 1/2))))
 788     (assert-tri-eq t t (subtypep type 'rational))
 789     (assert-tri-eq nil t (subtypep 'rational type))
 790     (assert-tri-eq nil t (subtypep type 'integer))
 791     (assert-tri-eq nil t (subtypep 'integer type))
 792     (assert (typep 1 type))
 793     (assert (typep 1/2 type))
 794     (assert (not (typep 3/4 type)))))
 795
 796 (with-test (:name (:rational-union :open-bounds-closed))
 797   (let ((t1 '(rational -1 1))
 798         (t2 '(or (integer -1 1) (rational (-1) (1)))))
 799     (assert-tri-eq t t (subtypep t1 t2))
 800     (assert-tri-eq t t (subtypep t2 t1))))
 801
 802 (with-test (:name (:rational-union :lp1912863 :bug039))
 803   (flet ((bug039 ()
 804            (let ((t1 'cons)
 805                  (t2 '(or (not (cons t (real -1 1)))
 806                        (not (cons sequence (eql 2))))))
 807              (assert-tri-eq t t (subtypep t1 t2))
 808              (assert-tri-eq t t (subtypep `(not ,t2) `(not ,t1))))))
 809     (bug039)))
 810
 811 (with-test (:name (:rational-union :lp1912863 :bug041))
 812   (flet ((bug041 ()
 813            (let ((t1 '(not (cons t integer)))
 814                  (t2 '(not (cons (array nil) (eql 0))))
 815                  (t3 '(cons simple-array t)))
 816              (assert-tri-eq t t (subtypep t1 t2))
 817              (assert-tri-eq t t (subtypep `(not (or ,t2 ,t3)) `(not ,t1)))
 818              (assert-tri-eq t t (subtypep `(and (not ,t2) (not ,t3)) `(not ,t1))))))
 819     (bug041)))
 820
 821 (with-test (:name (:lp1916040 :answer))
 822   (let* ((t1 '(cons sequence short-float))
 823          (t2 '(or (cons t atom) (cons function t)))
 824          (answer (multiple-value-list (subtypep t1 t2))))
 825     (assert (member answer '((nil nil) (t t)) :test 'equal))))
 826
 827 (with-test (:name (:lp1916233))
 828   (assert-tri-eq t t (subtypep '(cons (or (simple-array ratio) simple-array) nil) nil))
 829   (assert-tri-eq t t (subtypep '(or (array ratio) sequence) t)))
 830
 831 (defun my-widetag-of (x)
 832   (sb-sys:sap-ref-8 (sb-sys:int-sap (sb-kernel:get-lisp-obj-address x))
 833                     (- sb-vm:other-pointer-lowtag)))
 834 ;;; I'll bet that nothing anywhere tests this
 835 (with-test (:name :nil-has-symbol-widetag
 836             :skipped-on (:or :ppc64 :big-endian))
 837   (assert (= (my-widetag-of nil) (my-widetag-of t))))
 838
 839 (with-test (:name :array-rank-deriver-negation)
 840   (assert
 841    (ctype= (caddr
 842             (sb-kernel:%simple-fun-type
 843              (checked-compile
 844               `(lambda (a) (array-rank (the (not (array t)) a))))))
 845            `(values (mod 129) &optional))))
 846
 847 (with-test (:name (:rational-intersection :lp1998008))
 848   (flet ((bug101 ()
 849            (let ((t1 '(or (not (real 1 3)) (eql 2))))
 850              (assert-tri-eq t t (subtypep `(not (not ,t1)) t1))
 851              (assert-tri-eq t t (subtypep t1 `(not (not ,t1)))))))
 852     (bug101)))
 853
 854 (with-test (:name (:rational-intersection :integer-bounds))
 855   (let ((t1 '(and (not integer) (rational 3 5)))
 856         (t2 '(and (not integer) (rational (3) (5)))))
 857     (assert-tri-eq t t (subtypep t1 t2))
 858     (assert-tri-eq t t (subtypep t2 t1))
 859     (assert-tri-eq t t (subtypep `(not ,t1) `(not ,t2)))
 860     (assert-tri-eq t t (subtypep `(not ,t2) `(not ,t1)))))
 861
 862 (with-test (:name (:cons-union :lp1999352))
 863   (let* ((v (list :a))
 864          (type1 `(cons (or atom (eql ,v))))
 865          (type2 `(cons (or (member :a 2) cons) list)))
 866     (let ((bug103 (compile nil
 867                            `(lambda (val)
 868                               (declare (type ,type1 val))
 869                               (the ,type2 val)))))
 870       (assert (equal (funcall bug103 (list v)) '((:a)))))))
 871
 872 (with-test (:name :union-type-checks)
 873   (assert (not (find 'integerp
 874                      (ctu:ir1-named-calls `(lambda (x)
 875                                              (declare ((or list fixnum) x))
 876                                              (typep x 'integer))
 877                                           nil)))))
 878
 879 (with-test (:name :union-intersection-simplification)
 880   (checked-compile-and-assert
 881    ()
 882    `(lambda (a)
 883       (typep a '(or
 884                  (and symbol (not null))
 885                  (and array (not string)))))
 886    ((#()) t)
 887    (("") nil)
 888    ((t) t)
 889    ((nil) nil)))
 890
 891 (with-test (:name :union-integer-complex)
 892   (checked-compile-and-assert
 893    ()
 894    `(lambda (x)
 895       (typep x '(or (integer 36757953510256822604)
 896                  (complex fixnum))))
 897    ((-1) nil)
 898    ((36757953510256822603) nil)
 899    ((36757953510256822604) t)
 900    ((36757953510256822605) t)
 901    ((#C(1d0 1d0)) nil)
 902    ((#C(1 1)) t)
 903    ((#C(1 #.(expt 2 300))) nil)))
 904
 905 #+(or arm64 x86-64)
 906 (with-test (:name :structure-typep-fold)
 907   (assert-type
 908    (lambda (a b)
 909      (declare (character a))
 910        (sb-c::structure-typep a b))
 911    null)
 912   (assert-type
 913    (lambda (a)
 914      (declare (hash-table a))
 915      (sb-c::structure-typep a #.(sb-kernel:find-layout 'condition)))
 916    null)
 917   (assert-type
 918    (lambda (a)
 919      (declare (pathname a))
 920      (sb-c::structure-typep a #.(sb-kernel:find-layout 'pathname)))
 921    (eql t)))
 922
 923 (with-test (:name :typep-vector-folding)
 924   (assert-type
 925    (lambda (p)
 926      (declare (integer p))
 927      (typep p '(vector t 1)))
 928    null))