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 \f
  13 ;;;; Utilities
  14
  15 (defun ctype= (left right)
  16   (sb-kernel:type= (sb-kernel:specifier-type left)
  17                    (sb-kernel:specifier-type right)))
  18
  19 (defmacro assert-tri-eq (expected-result expected-certainp form)
  20   (sb-int:with-unique-names (result certainp)
  21     `(multiple-value-bind (,result ,certainp) ,form
  22        (assert (eq ,expected-result ,result))
  23        (assert (eq ,expected-certainp ,certainp)))))
  24 \f
  25 ;;;; Tests
  26
  27 (with-test (:name (typexpand-1 typexpand typexpand-all :check-lexenv))
  28   (flet ((try (f) (assert-error (funcall f 'hash-table 3))))
  29     (mapc #'try '(typexpand-1 typexpand typexpand-all))))
  30
  31 (with-test (:name (typep sb-kernel:ctypep))
  32   (locally
  33       (declare (notinline mapcar))
  34     (mapcar (lambda (args)
  35               (destructuring-bind (obj type-spec result) args
  36                 (flet ((matches-result? (x)
  37                          (eq (if x t nil) result)))
  38                   (assert (matches-result? (typep obj type-spec)))
  39                   (assert (matches-result? (sb-kernel:ctypep
  40                                             obj
  41                                             (sb-kernel:specifier-type
  42                                              type-spec)))))))
  43             '((nil (or null vector)              t)
  44               (nil (or number vector)            nil)
  45               (12  (or null vector)              nil)
  46               (12  (and (or number vector) real) t)))))
  47
  48
  49 ;;; This test is motivated by bug #195, which previously had (THE REAL
  50 ;;; #(1 2 3)) give an error which prints as "This is not a (OR
  51 ;;; SINGLE-FLOAT DOUBLE-FLOAT RATIONAL)".  We ideally want all of the
  52 ;;; defined-by-ANSI types to unparse as themselves or at least
  53 ;;; something similar (e.g. CHARACTER can unparse to BASE-CHAR, since
  54 ;;; the types are equivalent in current SBCL, and EXTENDED-CHAR can
  55 ;;; unparse to NIL, since there are no EXTENDED-CHARs currently).
  56 (with-test (:name :standard-types)
  57   (let ((standard-types '(;; from table 4-2 in section 4.2.3 in the
  58                           ;; CLHS.
  59                           arithmetic-error
  60                           function
  61                           simple-condition
  62                           array
  63                           generic-function
  64                           simple-error
  65                           atom
  66                           hash-table
  67                           simple-string
  68                           base-char
  69                           integer
  70                           simple-type-error
  71                           base-string
  72                           keyword
  73                           simple-vector
  74                           bignum
  75                           list
  76                           simple-warning
  77                           bit
  78                           logical-pathname
  79                           single-float
  80                           bit-vector
  81                           long-float
  82                           standard-char
  83                           broadcast-stream
  84                           method
  85                           standard-class
  86                           built-in-class
  87                           method-combination
  88                           standard-generic-function
  89                           cell-error
  90                           nil
  91                           standard-method
  92                           character
  93                           null
  94                           standard-object
  95                           class
  96                           number
  97                           storage-condition
  98                           compiled-function
  99                           package
 100                           stream
 101                           complex
 102                           package-error
 103                           stream-error
 104                           concatenated-stream
 105                           parse-error
 106                           string
 107                           condition
 108                           pathname
 109                           string-stream
 110                           cons
 111                           print-not-readable
 112                           structure-class
 113                           control-error
 114                           program-error
 115                           structure-object
 116                           division-by-zero
 117                           random-state
 118                           style-warning
 119                           double-float
 120                           ratio
 121                           symbol
 122                           echo-stream
 123                           rational
 124                           synonym-stream
 125                           end-of-file
 126                           reader-error
 127                           t
 128                           error
 129                           readtable
 130                           two-way-stream
 131                           extended-char
 132                           real
 133                           type-error
 134                           file-error
 135                           restart
 136                           unbound-slot
 137                           file-stream
 138                           sequence
 139                           unbound-variable
 140                           fixnum
 141                           serious-condition
 142                           undefined-function
 143                           float
 144                           short-float
 145                           unsigned-byte
 146                           floating-point-inexact
 147                           signed-byte
 148                           vector
 149                           floating-point-invalid-operation
 150                           simple-array
 151                           warning
 152                           floating-point-overflow
 153                           simple-base-string
 154                           floating-point-underflow
 155                           simple-bit-vector)))
 156     (dolist (type standard-types)
 157       #+nil (format t "~&~S~%" type)
 158       (assert (not (sb-kernel:unknown-type-p (sb-kernel:specifier-type type))))
 159       (assert (atom (sb-kernel:type-specifier (sb-kernel:specifier-type type)))))))
 160
 161 ;;; a bug underlying the reported bug #221: The SB-KERNEL type code
 162 ;;; signalled an error on this expression.
 163 (with-test (:name (subtypep function values :bug-221))
 164   (subtypep '(function (fixnum) (values package boolean))
 165             '(function (t) (values package boolean))))
 166
 167 ;;; bug reported by Valtteri Vuorik
 168 (with-test (:name (subtypep function &rest))
 169   (checked-compile '(lambda () (member (char "foo" 0) '(#\. #\/) :test #'char=)))
 170   (assert-tri-eq t   t (subtypep '(function ()) '(function (&rest t))))
 171   (assert-tri-eq nil t (subtypep '(function (&rest t)) '(function ())))
 172   (assert-tri-eq t   t (subtypep '(function)
 173                                  '(function (&optional * &rest t))))
 174   (assert-tri-eq nil t (subtypep '(function) '(function (t &rest t))))
 175   (assert-tri-eq t   t (subtypep 'function '(function)))
 176   (assert-tri-eq t   t (subtypep '(function) 'function)))
 177
 178 ;;; Absent any exciting generalizations of |R, the type RATIONAL is
 179 ;;; partitioned by RATIO and INTEGER.  Ensure that the type system
 180 ;;; knows about this.  [ the type system is permitted to return NIL,
 181 ;;; NIL for these, so if future maintenance breaks these tests that
 182 ;;; way, that's fine.  What the SUBTYPEP calls are _not_ allowed to
 183 ;;; return is NIL, T, because that's completely wrong. ]
 184 (with-test (:name (subtypep integer ratio rational))
 185   (assert-tri-eq t t (subtypep '(or integer ratio) 'rational))
 186   (assert-tri-eq t t (subtypep 'rational '(or integer ratio))))
 187
 188 ;;; Likewise, these are allowed to return NIL, NIL, but shouldn't
 189 ;;; return NIL, T:
 190 (with-test (:name (subtypep or and not))
 191   (assert-tri-eq t t (subtypep t '(or real (not real))))
 192   (assert-tri-eq t t (subtypep t '(or keyword (not keyword))))
 193   (assert-tri-eq t t (subtypep '(and cons (not (cons symbol integer)))
 194                                '(or (cons (not symbol) *) (cons * (not integer)))))
 195   (assert-tri-eq t t (subtypep '(or (cons (not symbol) *) (cons * (not integer)))
 196                                '(and cons (not (cons symbol integer)))))
 197   (assert-tri-eq t t (subtypep '(or (eql 0) (rational (0) 10))
 198                                '(rational 0 10)))
 199   (assert-tri-eq t t (subtypep '(rational 0 10)
 200                                '(or (eql 0) (rational (0) 10)))))
 201
 202 ;;; Until sbcl-0.7.13.7, union of CONS types when the CDRs were the
 203 ;;; same type gave exceedingly wrong results
 204 (with-test (:name (subtypep cons :same-cdr))
 205   (let ((a '(or (cons fixnum single-float) (cons bignum single-float)))
 206         (b '(cons single-float single-float))
 207         (c '(cons integer single-float)))
 208     (assert-tri-eq nil t (subtypep a b))
 209     (assert-tri-eq t   t (subtypep c a))))
 210
 211 (with-test (:name (subtypep :unknown-type))
 212   (checked-compile-and-assert (:allow-style-warnings t)
 213       '(lambda ()
 214          (subtypep '(and null some-unknown-type) 'another-unknown-type))
 215     (() (values nil nil) :allow-conditions 'sb-kernel:parse-unknown-type)))
 216
 217 ;;; bug 46c
 218 (with-test (:name (coerce function :on :macro))
 219   (dolist (fun '(and if))
 220     (assert-error (coerce fun 'function))))
 221
 222 (with-test (:name (typep array class-of))
 223   (dotimes (i 100)
 224     (let ((x (make-array 0 :element-type `(unsigned-byte ,(1+ i)))))
 225       (eval `(typep ,x (class-of ,x))))))
 226
 227 (with-test (:name (typep complex member))
 228   (assert (not (typep #c(1 2) '(member #c(2 1)))))
 229   (assert (typep #c(1 2) '(member #c(1 2)))))
 230
 231 (with-test (:name (subtypep complex))
 232   (assert-tri-eq t   t (subtypep 'nil '(complex nil)))
 233   (assert-tri-eq t   t (subtypep '(complex nil) 'nil))
 234   (assert-tri-eq t   t (subtypep 'nil '(complex (eql 0))))
 235   (assert-tri-eq t   t (subtypep '(complex (eql 0)) 'nil))
 236   (assert-tri-eq t   t (subtypep 'nil '(complex (integer 0 0))))
 237   (assert-tri-eq t   t (subtypep '(complex (integer 0 0)) 'nil))
 238   (assert-tri-eq t   t (subtypep 'nil '(complex (rational 0 0))))
 239   (assert-tri-eq t   t (subtypep '(complex (rational 0 0)) 'nil))
 240   (assert-tri-eq t   t (subtypep 'complex '(complex real)))
 241   (assert-tri-eq t   t (subtypep '(complex real) 'complex))
 242   (assert-tri-eq t   t (subtypep '(complex (eql 1)) '(complex (member 1 2))))
 243   (assert-tri-eq t   t (subtypep '(complex ratio) '(complex rational)))
 244   (assert-tri-eq t   t (subtypep '(complex ratio) 'complex))
 245   (assert-tri-eq nil t (subtypep '(complex (integer 1 2))
 246                                  '(member #c(1 1) #c(1 2) #c(2 1) #c(2 2)))))
 247
 248 (with-test (:name (typep real))
 249   (assert (typep 0 '(real #.(ash -1 10000) #.(ash 1 10000)))))
 250
 251 (with-test (:name (subtypep real))
 252   (assert-tri-eq t t (subtypep '(real #.(ash -1 1000) #.(ash 1 1000))
 253                                '(real #.(ash -1 10000) #.(ash 1 10000))))
 254   (assert-tri-eq t t (subtypep '(real (#.(ash -1 1000)) (#.(ash 1 1000)))
 255                                '(real #.(ash -1 1000) #.(ash 1 1000)))))
 256
 257 ;;; Bug, found by Paul F. Dietz
 258 (with-test (:name (typep subtypep complex rational))
 259   (let* ((x (eval #c(-1 1/2)))
 260          (type (type-of x)))
 261     (assert (subtypep type '(complex rational)))
 262     (assert (typep x type))))
 263
 264 ;;; Test derivation of LOG{AND,IOR,XOR} bounds for unsigned arguments.
 265 ;;;
 266 ;;; Fear the Loop of Doom!
 267 ;;;
 268 ;;; (In fact, this is such a fearsome loop that executing it with the
 269 ;;; evaluator would take ages... Disable it under those circumstances.)
 270 #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
 271 (with-test (:name (:type-derivation :logical-operations :correctness))
 272   (let* ((n-bits 5)
 273          (size (ash 1 n-bits)))
 274     (labels ((brute-force (a b c d op)
 275                (loop with min = (ash 1 n-bits)
 276                      with max = 0
 277                      for i from a upto b do
 278                      (loop for j from c upto d do
 279                            (let ((x (funcall op i j)))
 280                              (setf min (min min x)
 281                                    max (max max x))))
 282                      finally (return (values min max))))
 283              (test (a b c d op deriver)
 284                (multiple-value-bind (brute-low brute-high)
 285                    (brute-force a b c d op)
 286                  (multiple-value-bind (test-low test-high)
 287                      (funcall deriver
 288                               (sb-c::specifier-type `(integer ,a ,b))
 289                               (sb-c::specifier-type `(integer ,c ,d)))
 290                    (unless (and (= brute-low test-low)
 291                                 (= brute-high test-high))
 292                      (format t "FAIL: ~A [~D, ~D] [~D, ~D]~%EXPECTED [~D, ~D] GOT [~D, ~D]~%"
 293                              op a b c d
 294                              brute-low brute-high test-low test-high)
 295                      (assert (and (= brute-low test-low)
 296                                   (= brute-high test-high))))))))
 297       (dolist (op '(logand logior logxor))
 298         (let ((deriver (intern (format nil "~A-DERIVE-UNSIGNED-BOUNDS" op)
 299                                (find-package :sb-c))))
 300           #+(or) (format t "testing type derivation: ~A~%" deriver)
 301           (loop for a from 0 below size do
 302                 (loop for b from a below size do
 303                       (loop for c from 0 below size do
 304                             (loop for d from c below size do
 305                                   (test a b c d op deriver))))))))))
 306
 307 (with-test (:name (:type-derivation :logical-operations :scaling))
 308   (let ((type-x1 (sb-c::specifier-type `(integer ,(expt 2 10000)
 309                                                  ,(expt 2 10000))))
 310         (type-x2 (sb-c::specifier-type `(integer ,(expt 2 100000)
 311                                                  ,(expt 2 100000))))
 312         (type-y (sb-c::specifier-type '(integer 0 1))))
 313     (dolist (op '(logand logior logxor))
 314       (let* ((deriver (intern (format nil "~A-DERIVE-TYPE-AUX" op)
 315                               (find-package :sb-c)))
 316              (scale (/ (runtime (funcall deriver type-x2 type-y))
 317                        (runtime (funcall deriver type-x1 type-y)))))
 318         ;; Linear scaling is good, quadratical bad. Draw the line
 319         ;; near the geometric mean of the corresponding SCALEs.
 320         (when (> scale 40)
 321           (error "Bad scaling of ~a: input 10 times but runtime ~a times as large."
 322                  deriver scale))))))
 323
 324 ;;; SUBTYPEP on CONS types wasn't taking account of the fact that a
 325 ;;; CONS type could be the empty type (but no other non-CONS type) in
 326 ;;; disguise
 327 (with-test (:name (subtypep cons :empty))
 328   (multiple-value-bind (yes win)
 329       (subtypep '(and function stream) 'nil)
 330     (multiple-value-bind (cyes cwin)
 331         (subtypep '(cons (and function stream) t)
 332                   '(cons nil t))
 333       (assert (eq yes cyes))
 334       (assert (eq win cwin)))))
 335
 336 ;;; CONS type SUBTYPEP could be too enthusiastic about thinking it was
 337 ;;; certain
 338 (with-test (:name (subtypep cons satisfies))
 339   (assert-tri-eq nil nil (subtypep '(satisfies foo) '(satisfies bar)))
 340   (assert-tri-eq nil nil (subtypep '(cons (satisfies foo) t)
 341                                    '(cons (satisfies bar) t))))
 342
 343 (with-test (:name (subtypep generic-function function))
 344   (assert-tri-eq t t (subtypep 'generic-function 'function)))
 345
 346 ;;; this would be in some internal test suite like type.before-xc.lisp
 347 ;;; except that generic functions don't exist at that stage.
 348 (with-test (:name (subtypep generic-function sb-kernel:funcallable-instance))
 349   (assert-tri-eq t t (subtypep 'generic-function
 350                                'sb-kernel:funcallable-instance)))
 351
 352 ;;; all sorts of answers are right for this one, but it used to
 353 ;;; trigger an AVER instead.
 354 (with-test (:name (subtypep function satisfies :smoke))
 355   (subtypep '(function ()) '(and (function ()) (satisfies identity))))
 356
 357 (with-test (:name (sb-kernel:specifier-type :unknown-type))
 358   (assert (sb-kernel:unknown-type-p (sb-kernel:specifier-type 'an-unkown-type))))
 359
 360 (with-test (:name (sb-kernel:type= array))
 361   (assert-tri-eq t   t (ctype= '(or (simple-array an-unkown-type (*))
 362                                     (simple-array an-unkown-type))
 363                                '(or (simple-array an-unkown-type (*))
 364                                     (simple-array an-unkown-type))))
 365   (assert-tri-eq t   t (ctype= '(simple-array an-unkown-type (*))
 366                                '(simple-array an-unkown-type (*))))
 367   (assert-tri-eq nil t (ctype= '(simple-array an-unkown-type (*))
 368                                '(array an-unkown-type (*))))
 369   (assert-tri-eq nil t (ctype= '(simple-array an-unkown-type (7))
 370                                '(simple-array an-unkown-type (8)))))
 371
 372 (with-test (:name (sb-kernel:type= cons))
 373   (assert-tri-eq nil t (ctype= 'cons '(cons single-float single-float)))
 374   (assert-tri-eq nil t (ctype= '(cons integer) '(cons))))
 375
 376 (with-test (:name (typep subtypep sb-kernel:instance))
 377   (assert (typep #p"" 'sb-kernel:instance))
 378   (assert-tri-eq t t (subtypep '(member #p"") 'sb-kernel:instance)))
 379
 380 (with-test (:name (typep :character-set :negation))
 381   (flet ((generate-chars ()
 382            (loop repeat 100
 383                  collect (code-char (random char-code-limit)))))
 384     (dotimes (i 1000)
 385       (let* ((chars (generate-chars))
 386              (type `(member ,@chars))
 387              (not-type `(not ,type)))
 388         (dolist (char chars)
 389           (assert (typep char type))
 390           (assert (not (typep char not-type))))
 391         (let ((other-chars (generate-chars)))
 392           (dolist (char other-chars)
 393             (unless (member char chars)
 394               (assert (not (typep char type)))
 395               (assert (typep char not-type)))))))))
 396
 397 (with-test (:name (check-type :store-value :complex-place))
 398   (let ((a (cons 0.0 2))
 399         (handler-invoked nil))
 400     (handler-bind ((error
 401                     (lambda (c)
 402                       (declare (ignore c))
 403                       (assert (not handler-invoked))
 404                       (setf handler-invoked t)
 405                       (invoke-restart 'store-value 1))))
 406       (check-type (car a) integer))
 407     (assert (eql (car a) 1))))
 408
 409 ;;; The VOP FIXNUMP/UNSIGNED-BYTE-64 was broken on x86-64, failing
 410 ;;; the first ASSERT below. The second ASSERT takes care that the fix
 411 ;;; doesn't overshoot the mark.
 412 (with-test (:name (typep :fixnum-if-unsigned-byte))
 413   (checked-compile-and-assert ()
 414       '(lambda (x)
 415         (declare (type (unsigned-byte #.sb-vm:n-word-bits) x))
 416         (typep x (quote fixnum)))
 417     (((1+ most-positive-fixnum)) nil)
 418     ((most-positive-fixnum)      t)))
 419
 420 (with-test (:name (typep :member :uses eql))
 421   (assert (eval '(typep 1/3 '(member 1/3 nil))))
 422   (assert (eval '(typep 1.0 '(member 1.0 t))))
 423   (assert (eval '(typep #c(1.1 1.2) '(member #c(1.1 1.2)))))
 424   (assert (eval '(typep #c(1 1) '(member #c(1 1)))))
 425   (let ((bignum1 (+ 12 most-positive-fixnum))
 426         (bignum2 (- (+ 15 most-positive-fixnum) 3)))
 427     (assert (eval `(typep ,bignum1 '(member ,bignum2))))))
 428
 429 (with-test (:name :opt+rest+key-canonicalization)
 430   (let ((type '(function (&optional t &rest t &key (:x t) (:y t)) *)))
 431     (assert (equal type (sb-kernel:type-specifier (sb-kernel:specifier-type type))))))
 432
 433 (with-test (:name :bug-369)
 434   (let ((types (mapcar #'sb-c::values-specifier-type
 435                        '((values (vector package) &optional)
 436                          (values (vector package) &rest t)
 437                          (values (vector hash-table) &rest t)
 438                          (values (vector hash-table) &optional)
 439                          (values t &optional)
 440                          (values t &rest t)
 441                          (values nil &optional)
 442                          (values nil &rest t)
 443                          (values sequence &optional)
 444                          (values sequence &rest t)
 445                          (values list &optional)
 446                          (values list &rest t)))))
 447     (dolist (x types)
 448       (dolist (y types)
 449         (let ((i (sb-c::values-type-intersection x y)))
 450           (assert (sb-c::type= i (sb-c::values-type-intersection i x)))
 451           (assert (sb-c::type= i (sb-c::values-type-intersection i y))))))))
 452
 453 (with-test (:name (subtypep keyword symbol :bug-485972))
 454   (assert-tri-eq nil t (subtypep 'symbol 'keyword))
 455   (assert-tri-eq t   t (subtypep 'keyword 'symbol)))
 456
 457 ;; WARNING: this test case would fail by recursing into the stack's guard page.
 458 (with-test (:name (sb-kernel:specifier-type or and satisfies :bug-883498))
 459   (sb-kernel:specifier-type
 460    '(or (integer -2 -2)
 461         (and (satisfies foo) (rational -3/2 -3/2)))))
 462
 463 ;; The infinite recursion mentioned in the previous test was caused by an
 464 ;; attempt to get the following right.
 465 (with-test (:name :quirky-integer-rational-union)
 466   (assert-tri-eq t t (subtypep '(or (integer * -1)
 467                                     (and (rational * -1/2) (not integer)))
 468                                '(rational * -1/2)))
 469   (assert-tri-eq t t (subtypep '(rational * -1/2)
 470                                '(or (integer * -1)
 471                                     (and (rational * -1/2) (not integer))))))
 472
 473 ;; for the longest time (at least 05525d3a), single-value-type would
 474 ;; return CHARACTER on this.
 475 (with-test (:name :single-value-&optional-type)
 476   (assert (sb-c::type= (sb-c::single-value-type
 477                         (sb-c::values-specifier-type '(values &optional character)))
 478                        (sb-c::specifier-type '(or null character)))))
 479
 480 ;; lp#1317308 - TYPE-OF must not return a type specifier
 481 ;; involving AND,EQL,MEMBER,NOT,OR,SATISFIES,or VALUES.
 482 (with-test (:name :ANSIly-report-hairy-array-type)
 483   (let ((simp-t (make-array 9))
 484         (simp-bit (make-array 16 :element-type 'bit)))
 485     ;; TYPE-OF doesn't have an optimization that returns a constant specifier
 486     ;; from a non-constant array of known type. If it did, we'd probably
 487     ;; want to check that these results are all equal:
 488     ;;  - the runtime-determined type
 489     ;;  - the compile-time-determined constant type
 490     ;;  - the compile-time-determined type of an equivalent object
 491     ;;    that is in fact a compile-time constant
 492     (flet ((our-type-of (x) (sb-kernel:type-specifier (sb-kernel:ctype-of x))))
 493       (let ((hairy-t (make-array 3 :displaced-to simp-t)))
 494         (assert (equal (our-type-of hairy-t)
 495                        '(and (vector t 3) (not simple-array))))
 496         (assert (equal (type-of hairy-t) '(vector t 3))))
 497       (let ((hairy-t (make-array '(3 2) :displaced-to simp-t)))
 498         (assert (equal (our-type-of hairy-t)
 499                        '(and (array t (3 2)) (not simple-array))))
 500         (assert (equal (type-of hairy-t) '(array t (3 2)))))
 501       (let ((hairy-bit
 502              (make-array 5 :displaced-to simp-bit :element-type 'bit)))
 503         (assert (equal (our-type-of hairy-bit)
 504                        '(and (bit-vector 5) (not simple-array))))
 505         (assert (equal (type-of hairy-bit) '(bit-vector 5)))))))
 506
 507 (with-test (:name (subtypep array :bug-309098))
 508   (let ((u `(or ,@(map 'list (lambda (x) `(array ,(sb-vm:saetp-specifier x)))
 509                        sb-vm:*specialized-array-element-type-properties*))))
 510     (assert-tri-eq t t (subtypep 'array u))))
 511
 512 (with-test (:name :bug-1258716)
 513   (let ((intersection (sb-kernel:type-intersection
 514                        (sb-kernel:specifier-type 'simple-vector)
 515                        (sb-kernel:specifier-type `(vector #:unknown)))))
 516     (assert (sb-kernel:array-type-p intersection))
 517     ;; and not *wild-type*
 518     (assert (sb-kernel:type= (sb-kernel:array-type-specialized-element-type intersection)
 519                              sb-kernel:*universal-type*))))
 520
 521 (with-test (:name :parse-safely)
 522   (dolist (x '(array integer cons))
 523     (assert (handler-case (sb-kernel:specifier-type `(,x . 0))
 524               (sb-kernel::arg-count-error () t)
 525               (error (c) (print c) nil)))))
 526
 527 (with-test (:name :unparse-safely)
 528   (let* ((intersection (sb-kernel:type-intersection
 529                         (sb-kernel:specifier-type '(vector (or bit character)))
 530                         (sb-kernel:specifier-type `(vector (or bit symbol)))))
 531          (round-trip (sb-kernel:specifier-type
 532                      (sb-kernel:type-specifier intersection))))
 533     (assert (sb-kernel:type= intersection round-trip))
 534     (assert (sb-kernel:array-type-p intersection))
 535     ;; and not *wild-type*
 536     (assert (sb-kernel:type/= (sb-kernel:array-type-specialized-element-type intersection)
 537                               (sb-kernel:specifier-type 'bit)))))
 538
 539 ;; lp#1333731
 540 (with-test (:name (adjust-array :changes type-of))
 541   (let ((a (make-array 10 :adjustable t)))
 542     (assert (equal (type-of a) '(vector t 10)))
 543     (adjust-array a 20)
 544     (assert (equal (type-of a) '(vector t 20)))))
 545
 546 (with-test (:name :unknown-type-strongly-uncacheable)
 547   ;; VALUES-SPECIFIER-TYPE should not cache a specifier any part of which
 548   ;; is unknown. This leads to consistent results when parsing unknown
 549   ;; types. Previously it was indeterminate whether a condition would
 550   ;; be signaled for (OR UNKNOWN KNOWN) depending on whether that expression
 551   ;; had ever been parsed and whether it had been evicted from the cache.
 552   (assert-signal (progn (sb-kernel:specifier-type '(or weeble ratio))
 553                         (sb-kernel:specifier-type '(or weeble ratio)))
 554                  sb-kernel:parse-unknown-type 2) ; expect 2 signals
 555   (assert-signal (progn (sb-kernel:specifier-type '(and potrzebie real))
 556                         (sb-kernel:specifier-type '(and potrzebie real)))
 557                  sb-kernel:parse-unknown-type 2) ; expect 2 signals
 558   (assert-signal (progn (sb-kernel:specifier-type '(array strudel))
 559                         (sb-kernel:specifier-type '(array strudel)))
 560                  sb-kernel:parse-unknown-type 2) ; expect 2 signals
 561   (assert-signal (progn (sb-kernel:specifier-type '(not bad))
 562                         (sb-kernel:specifier-type '(not bad)))
 563                  sb-kernel:parse-unknown-type 2)) ; expect 2 signals
 564
 565 (in-package "SB-KERNEL")
 566
 567 (test-util:with-test (:name :partition-array-into-simple/hairy)
 568   ;; Some tests that (simple-array | hairy-array) = array
 569   ;; At present this works only for wild element-type.
 570   (cl-user::assert-tri-eq
 571    t t (type= (specifier-type '(not (and array (not simple-array))))
 572               (specifier-type '(or (not array) simple-array))))
 573
 574   ;; if X is neither simple-array nor hairy-array, it is not an array
 575   (assert (type= (specifier-type '(and (not simple-array)
 576                                        (not (and array (not simple-array)))))
 577                  (specifier-type '(not array))))
 578
 579   ;; (simple-array * (*)) = (AND (NOT <hairy-array>) VECTOR) etc
 580   (flet ((try (unrestricted simple)
 581            (assert (type= (specifier-type simple)
 582                           (type-intersection
 583                            (specifier-type
 584                             '(not (and array (not simple-array))))
 585                            (specifier-type unrestricted))))))
 586     (try 'vector '(simple-array * (*)))
 587     (try '(vector t) 'simple-vector)
 588     (try 'bit-vector 'simple-bit-vector)
 589     (try 'string 'simple-string)
 590     #+sb-unicode(try 'character-string 'simple-character-string)
 591     (try 'base-string 'simple-base-string))
 592
 593   ;; if X is a known string and not an array-header
 594   ;; it must be a SIMPLE-STRING
 595   (assert (type= (type-intersection
 596                   (specifier-type 'string)
 597                   (specifier-type
 598                    '(not (or (and simple-array (not vector))
 599                              (and array (not simple-array))))))
 600                  (specifier-type 'simple-string))))
 601
 602 (test-util:with-test (:name :classoids-as-type-specifiers)
 603   (dolist (classoid (list (find-classoid 'integer)
 604                           (find-class 'integer)))
 605     ;; Classoids and classes should work as type specifiers
 606     ;; in the atom form, not as lists.
 607     ;; Their legality or lack thereof is equivalent in all cases.
 608     (test-util:checked-compile `(lambda (x) (declare (,classoid x)) x))
 609     (test-util:checked-compile `(lambda (x) (declare (type ,classoid x)) x))
 610     ;; Negative tests come in two flavors:
 611     ;; In the case of (DECLARE (TYPE ...)), parsing the following thing
 612     ;; as a type should fail. But when 'TYPE is implied, "canonization"
 613     ;; should do nothing, because the following form is not a type,
 614     ;; so we get an error about an unrecognized declaration instead.
 615     (flet ((expect-lose (type)
 616              (assert (nth-value 1 (test-util:checked-compile
 617                                    `(lambda (x) (declare (,type x)) x)
 618                                    :allow-warnings t)))
 619              (assert (nth-value 1 (test-util:checked-compile
 620                                    `(lambda (x) (declare (,type x)) x)
 621                                    :allow-warnings t)))))
 622       (expect-lose `(,classoid))
 623       (expect-lose `(,classoid 1 100)))))
 624
 625 (test-util:with-test (:name :classoid-type-kind)
 626   (do-all-symbols (s)
 627     (let ((c (sb-kernel:find-classoid s nil)))
 628       ;; No classoid can have a :TYPE :KIND that is :DEFINED.
 629       (when c
 630         (if (typep c 'sb-kernel:built-in-classoid)
 631             (assert (eq (sb-int:info :type :kind s) :primitive))
 632             (assert (eq (sb-int:info :type :kind s) :instance)))))))
 633
 634 (test-util:with-test (:name :make-numeric-type)
 635   (assert (eq (make-numeric-type :class 'integer :low '(4) :high '(5))
 636               *empty-type*)))
 637
 638 (test-util:with-test (:name :unparse-string)
 639   (assert (equal (type-specifier (specifier-type '(string 10)))
 640                  '(string 10)))
 641   (assert (equal (type-specifier (specifier-type '(simple-string 10)))
 642                  '(simple-string 10))))
 643
 644 (in-package "CL-USER")
 645
 646 (with-test (:name (typep :complex-integer))
 647   (assert (not (eval '(typep #c(0 1/2) '(complex integer))))))