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