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 (let* ((bits 5)
 245        (size (ash 1 bits)))
 246   (flet ((brute-force (a b c d op minimize)
 247            (loop with extreme = (if minimize (ash 1 bits) 0)
 248                  with collector = (if minimize #'min #'max)
 249                  for i from a upto b do
 250                  (loop for j from c upto d do
 251                        (setf extreme (funcall collector
 252                                               extreme
 253                                               (funcall op i j))))
 254                  finally (return extreme))))
 255     (dolist (op '(logand logior logxor))
 256       (dolist (minimize '(t nil))
 257         (let ((deriver (intern (format nil "~A-DERIVE-UNSIGNED-~:[HIGH~;LOW~]-BOUND"
 258                                        op minimize)
 259                                (find-package :sb-c))))
 260           (format t "testing type derivation: ~A~%" deriver)
 261           (loop for a from 0 below size do
 262                 (loop for b from a below size do
 263                       (loop for c from 0 below size do
 264                             (loop for d from c below size do
 265                                   (let* ((brute (brute-force a b c d op minimize))
 266                                          (x-type (sb-c::specifier-type `(integer ,a ,b)))
 267                                          (y-type (sb-c::specifier-type `(integer ,c ,d)))
 268                                          (derived (funcall deriver x-type y-type)))
 269                                     (unless (= brute derived)
 270                                       (format t "FAIL: ~A [~D,~D] [~D,~D] ~A~%
 271 ACTUAL ~D DERIVED ~D~%"
 272                                               op a b c d minimize brute derived)
 273                                       (assert (= brute derived)))))))))))))
 274
 275 ;;; subtypep on CONS types wasn't taking account of the fact that a
 276 ;;; CONS type could be the empty type (but no other non-CONS type) in
 277 ;;; disguise.
 278 (multiple-value-bind (yes win)
 279     (subtypep '(and function stream) 'nil)
 280   (multiple-value-bind (cyes cwin)
 281       (subtypep '(cons (and function stream) t)
 282                 '(cons nil t))
 283     (assert (eq yes cyes))
 284     (assert (eq win cwin))))
 285
 286 ;;; CONS type subtypep could be too enthusiastic about thinking it was
 287 ;;; certain
 288 (multiple-value-bind (yes win)
 289     (subtypep '(satisfies foo) '(satisfies bar))
 290   (assert (null yes))
 291   (assert (null win))
 292   (multiple-value-bind (cyes cwin)
 293       (subtypep '(cons (satisfies foo) t)
 294                 '(cons (satisfies bar) t))
 295     (assert (null cyes))
 296     (assert (null cwin))))
 297
 298 (multiple-value-bind (yes win)
 299     (subtypep 'generic-function 'function)
 300   (assert yes)
 301   (assert win))
 302 ;;; this would be in some internal test suite like type.before-xc.lisp
 303 ;;; except that generic functions don't exist at that stage.
 304 (multiple-value-bind (yes win)
 305     (subtypep 'generic-function 'sb-kernel:funcallable-instance)
 306   (assert yes)
 307   (assert win))
 308
 309 ;;; all sorts of answers are right for this one, but it used to
 310 ;;; trigger an AVER instead.
 311 (subtypep '(function ()) '(and (function ()) (satisfies identity)))
 312
 313 (assert (sb-kernel:unknown-type-p (sb-kernel:specifier-type 'an-unkown-type)))
 314
 315 (assert
 316  (sb-kernel:type=
 317   (sb-kernel:specifier-type '(or (simple-array an-unkown-type (*))
 318                               (simple-array an-unkown-type)))
 319   (sb-kernel:specifier-type '(or (simple-array an-unkown-type (*))
 320                               (simple-array an-unkown-type)))))
 321
 322 (assert
 323  (sb-kernel:type=
 324   (sb-kernel:specifier-type '(simple-array an-unkown-type (*)))
 325   (sb-kernel:specifier-type '(simple-array an-unkown-type (*)))))
 326
 327 (assert
 328  (not
 329   (sb-kernel:type=
 330    (sb-kernel:specifier-type '(simple-array an-unkown-type (*)))
 331    (sb-kernel:specifier-type '(array an-unkown-type (*))))))
 332
 333 (assert
 334  (not
 335   (sb-kernel:type=
 336    (sb-kernel:specifier-type '(simple-array an-unkown-type (7)))
 337    (sb-kernel:specifier-type '(simple-array an-unkown-type (8))))))
 338
 339 (assert
 340  (sb-kernel:type/= (sb-kernel:specifier-type 'cons)
 341                    (sb-kernel:specifier-type '(cons single-float single-float))))
 342
 343 (multiple-value-bind (match win)
 344     (sb-kernel:type= (sb-kernel:specifier-type '(cons integer))
 345                      (sb-kernel:specifier-type '(cons)))
 346   (assert (and (not match) win)))
 347
 348 (assert (typep #p"" 'sb-kernel:instance))
 349 (assert (subtypep '(member #p"") 'sb-kernel:instance))
 350
 351 (with-test (:name (:typep :character-set :negation))
 352   (flet ((generate-chars ()
 353            (loop repeat 100
 354                  collect (code-char (random char-code-limit)))))
 355     (dotimes (i 1000)
 356       (let* ((chars (generate-chars))
 357              (type `(member ,@chars))
 358              (not-type `(not ,type)))
 359         (dolist (char chars)
 360           (assert (typep char type))
 361           (assert (not (typep char not-type))))
 362         (let ((other-chars (generate-chars)))
 363           (dolist (char other-chars)
 364             (unless (member char chars)
 365               (assert (not (typep char type)))
 366               (assert (typep char not-type)))))))))
 367
 368 (with-test (:name (:check-type :store-value :complex-place))
 369   (let ((a (cons 0.0 2))
 370         (handler-invoked nil))
 371     (handler-bind ((error
 372                     (lambda (c)
 373                       (declare (ignore c))
 374                       (assert (not handler-invoked))
 375                       (setf handler-invoked t)
 376                       (invoke-restart 'store-value 1))))
 377       (check-type (car a) integer))
 378     (assert (eql (car a) 1))))
 379
 380 ;;; The VOP FIXNUMP/UNSIGNED-BYTE-64 was broken on x86-64, failing
 381 ;;; the first ASSERT below. The second ASSERT takes care that the fix
 382 ;;; doesn't overshoot the mark.
 383 (with-test (:name (:typep :fixnum-if-unsigned-byte))
 384   (let ((f (compile nil
 385                     (lambda (x)
 386                       (declare (type (unsigned-byte #.sb-vm:n-word-bits) x))
 387                       (typep x (quote fixnum))))))
 388     (assert (not (funcall f (1+ most-positive-fixnum))))
 389     (assert (funcall f most-positive-fixnum))))
 390
 391 (with-test (:name (:typep :member-uses-eql))
 392   (assert (eval '(typep 1/3 '(member 1/3 nil))))
 393   (assert (eval '(typep 1.0 '(member 1.0 t))))
 394   (assert (eval '(typep #c(1.1 1.2) '(member #c(1.1 1.2)))))
 395   (assert (eval '(typep #c(1 1) '(member #c(1 1)))))
 396   (let ((bignum1 (+ 12 most-positive-fixnum))
 397         (bignum2 (- (+ 15 most-positive-fixnum) 3)))
 398     (assert (eval `(typep ,bignum1 '(member ,bignum2))))))
 399
 400 (with-test (:name :opt+rest+key-canonicalization)
 401   (let ((type '(function (&optional t &rest t &key (:x t) (:y t)) *)))
 402     (assert (equal type (sb-kernel:type-specifier (sb-kernel:specifier-type type))))))
 403
 404 (with-test (:name :bug-369)
 405   (let ((types (mapcar #'sb-c::values-specifier-type
 406                        '((values (vector package) &optional)
 407                          (values (vector package) &rest t)
 408                          (values (vector hash-table) &rest t)
 409                          (values (vector hash-table) &optional)
 410                          (values t &optional)
 411                          (values t &rest t)
 412                          (values nil &optional)
 413                          (values nil &rest t)
 414                          (values sequence &optional)
 415                          (values sequence &rest t)
 416                          (values list &optional)
 417                          (values list &rest t)))))
 418     (dolist (x types)
 419       (dolist (y types)
 420         (let ((i (sb-c::values-type-intersection x y)))
 421           (assert (sb-c::type= i (sb-c::values-type-intersection i x)))
 422           (assert (sb-c::type= i (sb-c::values-type-intersection i y))))))))
 423
 424 (with-test (:name :bug-485972)
 425   (assert (equal (multiple-value-list (subtypep 'symbol 'keyword)) '(nil t)))
 426   (assert (equal (multiple-value-list (subtypep 'keyword 'symbol)) '(t t))))