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 (locally
  15   (declare (notinline mapcar))
  16   (mapcar (lambda (args)
  17             (destructuring-bind (obj type-spec result) args
  18               (flet ((matches-result? (x)
  19                        (eq (if x t nil) result)))
  20                 (assert (matches-result? (typep obj type-spec)))
  21                 (assert (matches-result? (sb-kernel:ctypep
  22                                           obj
  23                                           (sb-kernel:specifier-type
  24                                            type-spec)))))))
  25           '((nil (or null vector)              t)
  26             (nil (or number vector)            nil)
  27             (12  (or null vector)              nil)
  28             (12  (and (or number vector) real) t))))
  29
  30
  31 ;;; This test is motivated by bug #195, which previously had (THE REAL
  32 ;;; #(1 2 3)) give an error which prints as "This is not a (OR
  33 ;;; SINGLE-FLOAT DOUBLE-FLOAT RATIONAL)".  We ideally want all of the
  34 ;;; defined-by-ANSI types to unparse as themselves or at least
  35 ;;; something similar (e.g. CHARACTER can unparse to BASE-CHAR, since
  36 ;;; the types are equivalent in current SBCL, and EXTENDED-CHAR can
  37 ;;; unparse to NIL, since there are no EXTENDED-CHARs currently).
  38 (let ((standard-types '(;; from table 4-2 in section 4.2.3 in the
  39                         ;; CLHS.
  40                         arithmetic-error
  41                         function
  42                         simple-condition
  43                         array
  44                         generic-function
  45                         simple-error
  46                         atom
  47                         hash-table
  48                         simple-string
  49                         base-char
  50                         integer
  51                         simple-type-error
  52                         base-string
  53                         keyword
  54                         simple-vector
  55                         bignum
  56                         list
  57                         simple-warning
  58                         bit
  59                         logical-pathname
  60                         single-float
  61                         bit-vector
  62                         long-float
  63                         standard-char
  64                         broadcast-stream
  65                         method
  66                         standard-class
  67                         built-in-class
  68                         method-combination
  69                         standard-generic-function
  70                         cell-error
  71                         nil
  72                         standard-method
  73                         character
  74                         null
  75                         standard-object
  76                         class
  77                         number
  78                         storage-condition
  79                         compiled-function
  80                         package
  81                         stream
  82                         complex
  83                         package-error
  84                         stream-error
  85                         concatenated-stream
  86                         parse-error
  87                         string
  88                         condition
  89                         pathname
  90                         string-stream
  91                         cons
  92                         print-not-readable
  93                         structure-class
  94                         control-error
  95                         program-error
  96                         structure-object
  97                         division-by-zero
  98                         random-state
  99                         style-warning
 100                         double-float
 101                         ratio
 102                         symbol
 103                         echo-stream
 104                         rational
 105                         synonym-stream
 106                         end-of-file
 107                         reader-error
 108                         t
 109                         error
 110                         readtable
 111                         two-way-stream
 112                         extended-char
 113                         real
 114                         type-error
 115                         file-error
 116                         restart
 117                         unbound-slot
 118                         file-stream
 119                         sequence
 120                         unbound-variable
 121                         fixnum
 122                         serious-condition
 123                         undefined-function
 124                         float
 125                         short-float
 126                         unsigned-byte
 127                         floating-point-inexact
 128                         signed-byte
 129                         vector
 130                         floating-point-invalid-operation
 131                         simple-array
 132                         warning
 133                         floating-point-overflow
 134                         simple-base-string
 135                         floating-point-underflow
 136                         simple-bit-vector)))
 137   (dolist (type standard-types)
 138     (format t "~&~S~%" type)
 139     (assert (not (sb-kernel:unknown-type-p (sb-kernel:specifier-type type))))
 140     (assert (atom (sb-kernel:type-specifier (sb-kernel:specifier-type type))))))
 141
 142 ;;; a bug underlying the reported bug #221: The SB-KERNEL type code
 143 ;;; signalled an error on this expression.
 144 (subtypep '(function (fixnum) (values package boolean))
 145           '(function (t) (values package boolean)))
 146
 147 ;;; bug reported by Valtteri Vuorik
 148 (compile nil '(lambda () (member (char "foo" 0) '(#\. #\/) :test #'char=)))
 149 (assert (not (equal (multiple-value-list
 150                      (subtypep '(function ()) '(function (&rest t))))
 151                     '(nil t))))
 152
 153 (assert (not (equal (multiple-value-list
 154                      (subtypep '(function (&rest t)) '(function ())))
 155                     '(t t))))
 156
 157 (assert (subtypep '(function)
 158                   '(function (&optional * &rest t))))
 159 (assert (equal (multiple-value-list
 160                 (subtypep '(function)
 161                           '(function (t &rest t))))
 162                '(nil t)))
 163 (assert (and (subtypep 'function '(function))
 164              (subtypep '(function) 'function)))
 165
 166 ;;; Absent any exciting generalizations of |R, the type RATIONAL is
 167 ;;; partitioned by RATIO and INTEGER.  Ensure that the type system
 168 ;;; knows about this.  [ the type system is permitted to return NIL,
 169 ;;; NIL for these, so if future maintenance breaks these tests that
 170 ;;; way, that's fine.  What the SUBTYPEP calls are _not_ allowed to
 171 ;;; return is NIL, T, because that's completely wrong. ]
 172 (assert (subtypep '(or integer ratio) 'rational))
 173 (assert (subtypep 'rational '(or integer ratio)))
 174 ;;; Likewise, these are allowed to return NIL, NIL, but shouldn't
 175 ;;; return NIL, T:
 176 (assert (subtypep t '(or real (not real))))
 177 (assert (subtypep t '(or keyword (not keyword))))
 178 (assert (subtypep '(and cons (not (cons symbol integer)))
 179                   '(or (cons (not symbol) *) (cons * (not integer)))))
 180 (assert (subtypep '(or (cons (not symbol) *) (cons * (not integer)))
 181                   '(and cons (not (cons symbol integer)))))
 182 (assert (subtypep '(or (eql 0) (rational (0) 10))
 183                   '(rational 0 10)))
 184 (assert (subtypep '(rational 0 10)
 185                   '(or (eql 0) (rational (0) 10))))
 186 ;;; Until sbcl-0.7.13.7, union of CONS types when the CDRs were the
 187 ;;; same type gave exceedingly wrong results
 188 (assert (null (subtypep '(or (cons fixnum single-float)
 189                              (cons bignum single-float))
 190                         '(cons single-float single-float))))
 191 (assert (subtypep '(cons integer single-float)
 192                   '(or (cons fixnum single-float) (cons bignum single-float))))
 193
 194 (assert (not (nth-value 1 (subtypep '(and null some-unknown-type)
 195                                     'another-unknown-type))))
 196
 197 ;;; bug 46c
 198 (dolist (fun '(and if))
 199   (assert (raises-error? (coerce fun 'function) type-error)))
 200
 201 (dotimes (i 100)
 202   (let ((x (make-array 0 :element-type `(unsigned-byte ,(1+ i)))))
 203     (eval `(typep ,x (class-of ,x)))))
 204
 205 (assert (not (typep #c(1 2) '(member #c(2 1)))))
 206 (assert (typep #c(1 2) '(member #c(1 2))))
 207 (assert (subtypep 'nil '(complex nil)))
 208 (assert (subtypep '(complex nil) 'nil))
 209 (assert (subtypep 'nil '(complex (eql 0))))
 210 (assert (subtypep '(complex (eql 0)) 'nil))
 211 (assert (subtypep 'nil '(complex (integer 0 0))))
 212 (assert (subtypep '(complex (integer 0 0)) 'nil))
 213 (assert (subtypep 'nil '(complex (rational 0 0))))
 214 (assert (subtypep '(complex (rational 0 0)) 'nil))
 215 (assert (subtypep 'complex '(complex real)))
 216 (assert (subtypep '(complex real) 'complex))
 217 (assert (subtypep '(complex (eql 1)) '(complex (member 1 2))))
 218 (assert (subtypep '(complex ratio) '(complex rational)))
 219 (assert (subtypep '(complex ratio) 'complex))
 220 (assert (equal (multiple-value-list
 221                 (subtypep '(complex (integer 1 2))
 222                           '(member #c(1 1) #c(1 2) #c(2 1) #c(2 2))))
 223                '(nil t)))
 224
 225 (assert (typep 0 '(real #.(ash -1 10000) #.(ash 1 10000))))
 226 (assert (subtypep '(real #.(ash -1 1000) #.(ash 1 1000))
 227                   '(real #.(ash -1 10000) #.(ash 1 10000))))
 228 (assert (subtypep '(real (#.(ash -1 1000)) (#.(ash 1 1000)))
 229                   '(real #.(ash -1 1000) #.(ash 1 1000))))
 230
 231 ;;; Bug, found by Paul F. Dietz
 232 (let* ((x (eval #c(-1 1/2)))
 233        (type (type-of x)))
 234   (assert (subtypep type '(complex rational)))
 235   (assert (typep x type)))
 236
 237 ;;; Test derivation of LOG{AND,IOR,XOR} bounds for unsigned arguments.
 238 ;;;
 239 ;;; Fear the Loop of Doom!
 240 ;;;
 241 ;;; (In fact, this is such a fearsome loop that executing it with the
 242 ;;; evaluator would take ages... Disable it under those circumstances.)
 243 #+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
 244 (with-test (:name (:type-derivation :logical-operations :correctness))
 245   (let* ((n-bits 5)
 246          (size (ash 1 n-bits)))
 247     (labels ((brute-force (a b c d op)
 248                (loop with min = (ash 1 n-bits)
 249                      with max = 0
 250                      for i from a upto b do
 251                      (loop for j from c upto d do
 252                            (let ((x (funcall op i j)))
 253                              (setf min (min min x)
 254                                    max (max max x))))
 255                      finally (return (values min max))))
 256              (test (a b c d op deriver)
 257                (multiple-value-bind (brute-low brute-high)
 258                    (brute-force a b c d op)
 259                  (multiple-value-bind (test-low test-high)
 260                      (funcall deriver
 261                               (sb-c::specifier-type `(integer ,a ,b))
 262                               (sb-c::specifier-type `(integer ,c ,d)))
 263                    (unless (and (= brute-low test-low)
 264                                 (= brute-high test-high))
 265                      (format t "FAIL: ~A [~D, ~D] [~D, ~D]~%EXPECTED [~D, ~D] GOT [~D, ~D]~%"
 266                              op a b c d
 267                              brute-low brute-high test-low test-high)
 268                      (assert (and (= brute-low test-low)
 269                                   (= brute-high test-high))))))))
 270       (dolist (op '(logand logior logxor))
 271         (let ((deriver (intern (format nil "~A-DERIVE-UNSIGNED-BOUNDS" op)
 272                                (find-package :sb-c))))
 273           (format t "testing type derivation: ~A~%" deriver)
 274           (loop for a from 0 below size do
 275                 (loop for b from a below size do
 276                       (loop for c from 0 below size do
 277                             (loop for d from c below size do
 278                                   (test a b c d op deriver))))))))))
 279
 280 (with-test (:name (:type-derivation :logical-operations :scaling))
 281   (let ((type-x1 (sb-c::specifier-type `(integer ,(expt 2 10000)
 282                                                  ,(expt 2 10000))))
 283         (type-x2 (sb-c::specifier-type `(integer ,(expt 2 100000)
 284                                                  ,(expt 2 100000))))
 285         (type-y (sb-c::specifier-type '(integer 0 1))))
 286     (dolist (op '(logand logior logxor))
 287       (let* ((deriver (intern (format nil "~A-DERIVE-TYPE-AUX" op)
 288                               (find-package :sb-c)))
 289              (scale (/ (runtime (funcall deriver type-x2 type-y))
 290                        (runtime (funcall deriver type-x1 type-y)))))
 291         ;; Linear scaling is good, quadratical bad. Draw the line
 292         ;; near the geometric mean of the corresponding SCALEs.
 293         (when (> scale 32)
 294           (error "Bad scaling of ~a: input 10 times but runtime ~a times as large."
 295                  deriver scale))))))
 296
 297 ;;; subtypep on CONS types wasn't taking account of the fact that a
 298 ;;; CONS type could be the empty type (but no other non-CONS type) in
 299 ;;; disguise.
 300 (multiple-value-bind (yes win)
 301     (subtypep '(and function stream) 'nil)
 302   (multiple-value-bind (cyes cwin)
 303       (subtypep '(cons (and function stream) t)
 304                 '(cons nil t))
 305     (assert (eq yes cyes))
 306     (assert (eq win cwin))))
 307
 308 ;;; CONS type subtypep could be too enthusiastic about thinking it was
 309 ;;; certain
 310 (multiple-value-bind (yes win)
 311     (subtypep '(satisfies foo) '(satisfies bar))
 312   (assert (null yes))
 313   (assert (null win))
 314   (multiple-value-bind (cyes cwin)
 315       (subtypep '(cons (satisfies foo) t)
 316                 '(cons (satisfies bar) t))
 317     (assert (null cyes))
 318     (assert (null cwin))))
 319
 320 (multiple-value-bind (yes win)
 321     (subtypep 'generic-function 'function)
 322   (assert yes)
 323   (assert win))
 324 ;;; this would be in some internal test suite like type.before-xc.lisp
 325 ;;; except that generic functions don't exist at that stage.
 326 (multiple-value-bind (yes win)
 327     (subtypep 'generic-function 'sb-kernel:funcallable-instance)
 328   (assert yes)
 329   (assert win))
 330
 331 ;;; all sorts of answers are right for this one, but it used to
 332 ;;; trigger an AVER instead.
 333 (subtypep '(function ()) '(and (function ()) (satisfies identity)))
 334
 335 (assert (sb-kernel:unknown-type-p (sb-kernel:specifier-type 'an-unkown-type)))
 336
 337 (assert
 338  (sb-kernel:type=
 339   (sb-kernel:specifier-type '(or (simple-array an-unkown-type (*))
 340                               (simple-array an-unkown-type)))
 341   (sb-kernel:specifier-type '(or (simple-array an-unkown-type (*))
 342                               (simple-array an-unkown-type)))))
 343
 344 (assert
 345  (sb-kernel:type=
 346   (sb-kernel:specifier-type '(simple-array an-unkown-type (*)))
 347   (sb-kernel:specifier-type '(simple-array an-unkown-type (*)))))
 348
 349 (assert
 350  (not
 351   (sb-kernel:type=
 352    (sb-kernel:specifier-type '(simple-array an-unkown-type (*)))
 353    (sb-kernel:specifier-type '(array an-unkown-type (*))))))
 354
 355 (assert
 356  (not
 357   (sb-kernel:type=
 358    (sb-kernel:specifier-type '(simple-array an-unkown-type (7)))
 359    (sb-kernel:specifier-type '(simple-array an-unkown-type (8))))))
 360
 361 (assert
 362  (sb-kernel:type/= (sb-kernel:specifier-type 'cons)
 363                    (sb-kernel:specifier-type '(cons single-float single-float))))
 364
 365 (multiple-value-bind (match win)
 366     (sb-kernel:type= (sb-kernel:specifier-type '(cons integer))
 367                      (sb-kernel:specifier-type '(cons)))
 368   (assert (and (not match) win)))
 369
 370 (assert (typep #p"" 'sb-kernel:instance))
 371 (assert (subtypep '(member #p"") 'sb-kernel:instance))
 372
 373 (with-test (:name (:typep :character-set :negation))
 374   (flet ((generate-chars ()
 375            (loop repeat 100
 376                  collect (code-char (random char-code-limit)))))
 377     (dotimes (i 1000)
 378       (let* ((chars (generate-chars))
 379              (type `(member ,@chars))
 380              (not-type `(not ,type)))
 381         (dolist (char chars)
 382           (assert (typep char type))
 383           (assert (not (typep char not-type))))
 384         (let ((other-chars (generate-chars)))
 385           (dolist (char other-chars)
 386             (unless (member char chars)
 387               (assert (not (typep char type)))
 388               (assert (typep char not-type)))))))))
 389
 390 (with-test (:name (:check-type :store-value :complex-place))
 391   (let ((a (cons 0.0 2))
 392         (handler-invoked nil))
 393     (handler-bind ((error
 394                     (lambda (c)
 395                       (declare (ignore c))
 396                       (assert (not handler-invoked))
 397                       (setf handler-invoked t)
 398                       (invoke-restart 'store-value 1))))
 399       (check-type (car a) integer))
 400     (assert (eql (car a) 1))))
 401
 402 ;;; The VOP FIXNUMP/UNSIGNED-BYTE-64 was broken on x86-64, failing
 403 ;;; the first ASSERT below. The second ASSERT takes care that the fix
 404 ;;; doesn't overshoot the mark.
 405 (with-test (:name (:typep :fixnum-if-unsigned-byte))
 406   (let ((f (compile nil
 407                     (lambda (x)
 408                       (declare (type (unsigned-byte #.sb-vm:n-word-bits) x))
 409                       (typep x (quote fixnum))))))
 410     (assert (not (funcall f (1+ most-positive-fixnum))))
 411     (assert (funcall f most-positive-fixnum))))
 412
 413 (with-test (:name (:typep :member-uses-eql))
 414   (assert (eval '(typep 1/3 '(member 1/3 nil))))
 415   (assert (eval '(typep 1.0 '(member 1.0 t))))
 416   (assert (eval '(typep #c(1.1 1.2) '(member #c(1.1 1.2)))))
 417   (assert (eval '(typep #c(1 1) '(member #c(1 1)))))
 418   (let ((bignum1 (+ 12 most-positive-fixnum))
 419         (bignum2 (- (+ 15 most-positive-fixnum) 3)))
 420     (assert (eval `(typep ,bignum1 '(member ,bignum2))))))
 421
 422 (with-test (:name :opt+rest+key-canonicalization)
 423   (let ((type '(function (&optional t &rest t &key (:x t) (:y t)) *)))
 424     (assert (equal type (sb-kernel:type-specifier (sb-kernel:specifier-type type))))))
 425
 426 (with-test (:name :bug-369)
 427   (let ((types (mapcar #'sb-c::values-specifier-type
 428                        '((values (vector package) &optional)
 429                          (values (vector package) &rest t)
 430                          (values (vector hash-table) &rest t)
 431                          (values (vector hash-table) &optional)
 432                          (values t &optional)
 433                          (values t &rest t)
 434                          (values nil &optional)
 435                          (values nil &rest t)
 436                          (values sequence &optional)
 437                          (values sequence &rest t)
 438                          (values list &optional)
 439                          (values list &rest t)))))
 440     (dolist (x types)
 441       (dolist (y types)
 442         (let ((i (sb-c::values-type-intersection x y)))
 443           (assert (sb-c::type= i (sb-c::values-type-intersection i x)))
 444           (assert (sb-c::type= i (sb-c::values-type-intersection i y))))))))
 445
 446 (with-test (:name :bug-485972)
 447   (assert (equal (multiple-value-list (subtypep 'symbol 'keyword)) '(nil t)))
 448   (assert (equal (multiple-value-list (subtypep 'keyword 'symbol)) '(t t))))
 449
 450 ;; WARNING: this test case would fail by recursing into the stack's guard page.
 451 (with-test (:name :bug-883498)
 452   (sb-kernel:specifier-type
 453    `(or (INTEGER -2 -2)
 454         (AND (SATISFIES FOO) (RATIONAL -3/2 -3/2)))))
 455
 456 ;; The infinite recursion mentioned in the previous test was caused by an
 457 ;; attempt to get the following right.
 458 (with-test (:name :quirky-integer-rational-union)
 459   (assert (subtypep `(or (integer * -1)
 460                          (and (rational * -1/2) (not integer)))
 461                     `(rational * -1/2)))
 462   (assert (subtypep `(rational * -1/2)
 463                     `(or (integer * -1)
 464                          (and (rational * -1/2) (not integer))))))
 465
 466 ;; for the longest time (at least 05525d3a), single-value-type would
 467 ;; return CHARACTER on this.
 468 (with-test (:name :single-value-&optional-type)
 469   (assert (sb-c::type= (sb-c::single-value-type
 470                         (sb-c::values-specifier-type '(values &optional character)))
 471                        (sb-c::specifier-type '(or null character)))))