tests/type.impure.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 (load "assertoid.lisp")
  13 (use-package "ASSERTOID")
  14
  15 (defmacro assert-nil-nil (expr)
  16   `(assert (equal '(nil nil) (multiple-value-list ,expr))))
  17 (defmacro assert-nil-t (expr)
  18   `(assert (equal '(nil t) (multiple-value-list ,expr))))
  19 (defmacro assert-t-t (expr)
  20   `(assert (equal '(t t) (multiple-value-list ,expr))))
  21
  22 (defmacro assert-t-t-or-uncertain (expr)
  23   `(assert (let ((list (multiple-value-list ,expr)))
  24              (or (equal '(nil nil) list)
  25                  (equal '(t t) list)))))
  26
  27 (let ((types '(character
  28                integer fixnum (integer 0 10)
  29                single-float (single-float -1.0 1.0) (single-float 0.1)
  30                (real 4 8) (real -1 7) (real 2 11)
  31                null symbol keyword
  32                (member #\a #\b #\c) (member 1 #\a) (member 3.0 3.3)
  33               (member #\a #\c #\d #\f) (integer -1 1)
  34                unsigned-byte
  35                (rational -1 7) (rational -2 4)
  36                ratio
  37                )))
  38   (dolist (i types)
  39     (format t "type I=~S~%" i)
  40     (dolist (j types)
  41       (format t "  type J=~S~%" j)
  42       (assert (subtypep i `(or ,i ,j)))
  43       (assert (subtypep i `(or ,j ,i)))
  44       (assert (subtypep i `(or ,i ,i ,j)))
  45       (assert (subtypep i `(or ,j ,i)))
  46       (dolist (k types)
  47         (format t "    type K=~S~%" k)
  48         (assert (subtypep `(or ,i ,j) `(or ,i ,j ,k)))
  49         (assert (subtypep `(or ,i ,j) `(or ,k ,j ,i)))))))
  50
  51 ;;; gotchas that can come up in handling subtypeness as "X is a
  52 ;;; subtype of Y if each of the elements of X is a subtype of Y"
  53 (let ((subtypep-values (multiple-value-list
  54                         (subtypep '(single-float -1.0 1.0)
  55                                   '(or (real -100.0 0.0)
  56                                        (single-float 0.0 100.0))))))
  57   (assert (member subtypep-values
  58                   '(;; The system isn't expected to
  59                     ;; understand the subtype relationship.
  60                     (nil nil)
  61                     ;; But if it does, that'd be neat.
  62                     (t t)
  63                     ;; (And any other return would be wrong.)
  64                     )
  65                   :test #'equal)))
  66
  67 (defun type-evidently-= (x y)
  68   (and (subtypep x y)
  69        (subtypep y x)))
  70
  71 (assert (subtypep 'single-float 'float))
  72
  73 (assert (type-evidently-= '(integer 0 10) '(or (integer 0 5) (integer 4 10))))
  74
  75 ;;; Bug 50(c,d): numeric types with empty ranges should be NIL
  76 (assert (type-evidently-= 'nil '(integer (0) (0))))
  77 (assert (type-evidently-= 'nil '(rational (0) (0))))
  78 (assert (type-evidently-= 'nil '(float (0.0) (0.0))))
  79
  80 ;;; sbcl-0.6.10 did (UPGRADED-ARRAY-ELEMENT-TYPE 'SOME-UNDEF-TYPE)=>T
  81 ;;; and (UPGRADED-COMPLEX-PART-TYPE 'SOME-UNDEF-TYPE)=>T.
  82 (assert (raises-error? (upgraded-array-element-type 'some-undef-type)))
  83 (assert (eql (upgraded-array-element-type t) t))
  84 (assert (raises-error? (upgraded-complex-part-type 'some-undef-type)))
  85 (assert (subtypep (upgraded-complex-part-type 'fixnum) 'real))
  86
  87 ;;; Do reasonable things with undefined types, and with compound types
  88 ;;; built from undefined types.
  89 ;;;
  90 ;;; part I: TYPEP
  91 (assert (typep #(11) '(simple-array t 1)))
  92 (assert (typep #(11) '(simple-array (or integer symbol) 1)))
  93 (assert (raises-error? (typep #(11) '(simple-array undef-type 1))))
  94 (assert (not (typep 11 '(simple-array undef-type 1))))
  95 ;;; part II: SUBTYPEP
  96
  97 (assert (subtypep '(vector some-undef-type) 'vector))
  98 (assert (not (subtypep '(vector some-undef-type) 'integer)))
  99 (assert-nil-nil (subtypep 'utype-1 'utype-2))
 100 (assert-nil-nil (subtypep '(vector utype-1) '(vector utype-2)))
 101 (assert-nil-nil (subtypep '(vector utype-1) '(vector t)))
 102 (assert-nil-nil (subtypep '(vector t) '(vector utype-2)))
 103
 104 ;;; ANSI specifically disallows bare AND and OR symbols as type specs.
 105 (assert (raises-error? (typep 11 'and)))
 106 (assert (raises-error? (typep 11 'or)))
 107 (assert (raises-error? (typep 11 'member)))
 108 (assert (raises-error? (typep 11 'values)))
 109 (assert (raises-error? (typep 11 'eql)))
 110 (assert (raises-error? (typep 11 'satisfies)))
 111 (assert (raises-error? (typep 11 'not)))
 112 ;;; and while it doesn't specifically disallow illegal compound
 113 ;;; specifiers from the CL package, we don't have any.
 114 (assert (raises-error? (subtypep 'fixnum '(fixnum 1))))
 115 (assert (raises-error? (subtypep 'class '(list))))
 116 (assert (raises-error? (subtypep 'foo '(ratio 1/2 3/2))))
 117 (assert (raises-error? (subtypep 'character '(character 10))))
 118 #+nil ; doesn't yet work on PCL-derived internal types
 119 (assert (raises-error? (subtypep 'lisp '(class))))
 120 #+nil
 121 (assert (raises-error? (subtypep 'bar '(method number number))))
 122
 123 ;;; Of course empty lists of subtypes are still OK.
 124 (assert (typep 11 '(and)))
 125 (assert (not (typep 11 '(or))))
 126
 127 ;;; bug 12: type system didn't grok nontrivial intersections
 128 (assert (subtypep '(and symbol (satisfies keywordp)) 'symbol))
 129 (assert (not (subtypep '(and symbol (satisfies keywordp)) 'null)))
 130 (assert (subtypep 'keyword 'symbol))
 131 (assert (not (subtypep 'symbol 'keyword)))
 132 (assert (subtypep 'ratio 'real))
 133 (assert (subtypep 'ratio 'number))
 134
 135 ;;; bug 50.g: Smarten up hairy type specifiers slightly. We may wish
 136 ;;; to revisit this, perhaps by implementing a COMPLEMENT type
 137 ;;; (analogous to UNION and INTERSECTION) to take the logic out of the
 138 ;;; HAIRY domain.
 139 (assert-nil-t (subtypep 'atom 'cons))
 140 (assert-nil-t (subtypep 'cons 'atom))
 141 ;;; These two are desireable but not necessary for ANSI conformance;
 142 ;;; maintenance work on other parts of the system broke them in
 143 ;;; sbcl-0.7.13.11 -- CSR
 144 #+nil
 145 (assert-nil-t (subtypep '(not list) 'cons))
 146 #+nil
 147 (assert-nil-t (subtypep '(not float) 'single-float))
 148 (assert-t-t (subtypep '(not atom) 'cons))
 149 (assert-t-t (subtypep 'cons '(not atom)))
 150 ;;; ANSI requires that SUBTYPEP relationships among built-in primitive
 151 ;;; types never be uncertain, i.e. never return NIL as second value.
 152 ;;; Prior to about sbcl-0.7.2.6, ATOM caused a lot of problems here
 153 ;;; (because it's a negation type, implemented as a HAIRY-TYPE, and
 154 ;;; CMU CL's HAIRY-TYPE logic punted a lot).
 155 (assert-t-t (subtypep 'integer 'atom))
 156 (assert-t-t (subtypep 'function 'atom))
 157 (assert-nil-t (subtypep 'list 'atom))
 158 (assert-nil-t (subtypep 'atom 'integer))
 159 (assert-nil-t (subtypep 'atom 'function))
 160 (assert-nil-t (subtypep 'atom 'list))
 161 ;;; ATOM is equivalent to (NOT CONS):
 162 (assert-t-t (subtypep 'integer '(not cons)))
 163 (assert-nil-t (subtypep 'list '(not cons)))
 164 (assert-nil-t (subtypep '(not cons) 'integer))
 165 (assert-nil-t (subtypep '(not cons) 'list))
 166 ;;; And we'd better check that all the named types are right. (We also
 167 ;;; do some more tests on ATOM here, since once CSR experimented with
 168 ;;; making it a named type.)
 169 (assert-t-t (subtypep 'nil 'nil))
 170 (assert-t-t (subtypep 'nil 'atom))
 171 (assert-t-t (subtypep 'nil 't))
 172 (assert-nil-t (subtypep 'atom 'nil))
 173 (assert-t-t (subtypep 'atom 'atom))
 174 (assert-t-t (subtypep 'atom 't))
 175 (assert-nil-t (subtypep 't 'nil))
 176 (assert-nil-t (subtypep 't 'atom))
 177 (assert-t-t (subtypep 't 't))
 178 ;;; Also, LIST is now somewhat special, in that (NOT LIST) should be
 179 ;;; recognized as a subtype of ATOM:
 180 (assert-t-t (subtypep '(not list) 'atom))
 181 (assert-nil-t (subtypep 'atom '(not list)))
 182 ;;; These used to fail, because when the two arguments to subtypep are
 183 ;;; of different specifier-type types (e.g. HAIRY and UNION), there
 184 ;;; are two applicable type methods -- in this case
 185 ;;; HAIRY-COMPLEX-SUBTYPEP-ARG1-TYPE-METHOD and
 186 ;;; UNION-COMPLEX-SUBTYPEP-ARG2-TYPE-METHOD. Both of these exist, but
 187 ;;; [!%]INVOKE-TYPE-METHOD aren't smart enough to know that if one of
 188 ;;; them returns NIL, NIL (indicating uncertainty) it should try the
 189 ;;; other. However, as of sbcl-0.7.2.6 or so, CALL-NEXT-METHOD-ish
 190 ;;; logic in those type methods fixed it.
 191 (assert-nil-t (subtypep '(not cons) 'list))
 192 (assert-nil-t (subtypep '(not single-float) 'float))
 193 ;;; Somewhere along the line (probably when adding CALL-NEXT-METHOD-ish
 194 ;;; logic in SUBTYPEP type methods) we fixed bug 58 too:
 195 (assert-t-t (subtypep '(and zilch integer) 'zilch))
 196 (assert-t-t (subtypep '(and integer zilch) 'zilch))
 197
 198 ;;; Bug 84: SB-KERNEL:CSUBTYPEP was a bit enthusiastic at
 199 ;;; special-casing calls to subtypep involving *EMPTY-TYPE*,
 200 ;;; corresponding to the NIL type-specifier; we were bogusly returning
 201 ;;; NIL, T (indicating surety) for the following:
 202 (assert-nil-nil (subtypep '(satisfies some-undefined-fun) 'nil))
 203
 204 ;;; It turns out that, as of sbcl-0.7.2, we require to be able to
 205 ;;; detect this to compile src/compiler/node.lisp (and in particular,
 206 ;;; the definition of the component structure). Since it's a sensible
 207 ;;; thing to want anyway, let's test for it here:
 208 (assert-t-t (subtypep '(or some-undefined-type (member :no-ir2-yet :dead))
 209                       '(or some-undefined-type (member :no-ir2-yet :dead))))
 210 ;;; BUG 158 (failure to compile loops with vector references and
 211 ;;; increments of greater than 1) was a symptom of type system
 212 ;;; uncertainty, to wit:
 213 (assert-t-t (subtypep '(and (mod 536870911) (or (integer 0 0) (integer 2 536870912)))
 214                       '(mod 536870911))) ; aka SB-INT:INDEX.
 215 ;;; floating point types can be tricky.
 216 (assert-t-t (subtypep '(member 0.0) '(single-float 0.0 0.0)))
 217 (assert-t-t (subtypep '(member -0.0) '(single-float 0.0 0.0)))
 218 (assert-t-t (subtypep '(member 0.0) '(single-float -0.0 0.0)))
 219 (assert-t-t (subtypep '(member -0.0) '(single-float 0.0 -0.0)))
 220 (assert-t-t (subtypep '(member 0.0d0) '(double-float 0.0d0 0.0d0)))
 221 (assert-t-t (subtypep '(member -0.0d0) '(double-float 0.0d0 0.0d0)))
 222 (assert-t-t (subtypep '(member 0.0d0) '(double-float -0.0d0 0.0d0)))
 223 (assert-t-t (subtypep '(member -0.0d0) '(double-float 0.0d0 -0.0d0)))
 224
 225 (assert-nil-t (subtypep '(single-float 0.0 0.0) '(member 0.0)))
 226 (assert-nil-t (subtypep '(single-float 0.0 0.0) '(member -0.0)))
 227 (assert-nil-t (subtypep '(single-float -0.0 0.0) '(member 0.0)))
 228 (assert-nil-t (subtypep '(single-float 0.0 -0.0) '(member -0.0)))
 229 (assert-nil-t (subtypep '(double-float 0.0d0 0.0d0) '(member 0.0d0)))
 230 (assert-nil-t (subtypep '(double-float 0.0d0 0.0d0) '(member -0.0d0)))
 231 (assert-nil-t (subtypep '(double-float -0.0d0 0.0d0) '(member 0.0d0)))
 232 (assert-nil-t (subtypep '(double-float 0.0d0 -0.0d0) '(member -0.0d0)))
 233
 234 (assert-t-t (subtypep '(member 0.0 -0.0) '(single-float 0.0 0.0)))
 235 (assert-t-t (subtypep '(single-float 0.0 0.0) '(member 0.0 -0.0)))
 236 (assert-t-t (subtypep '(member 0.0d0 -0.0d0) '(double-float 0.0d0 0.0d0)))
 237 (assert-t-t (subtypep '(double-float 0.0d0 0.0d0) '(member 0.0d0 -0.0d0)))
 238
 239 (assert-t-t (subtypep '(not (single-float 0.0 0.0)) '(not (member 0.0))))
 240 (assert-t-t (subtypep '(not (double-float 0.0d0 0.0d0)) '(not (member 0.0d0))))
 241
 242 (assert-t-t (subtypep '(float -0.0) '(float 0.0)))
 243 (assert-t-t (subtypep '(float 0.0) '(float -0.0)))
 244 (assert-t-t (subtypep '(float (0.0)) '(float (-0.0))))
 245 (assert-t-t (subtypep '(float (-0.0)) '(float (0.0))))
 246 \f
 247 ;;;; Douglas Thomas Crosher rewrote the CMU CL type test system to
 248 ;;;; allow inline type tests for CONDITIONs and STANDARD-OBJECTs, and
 249 ;;;; generally be nicer, and Martin Atzmueller ported the patches.
 250 ;;;; They look nice but they're nontrivial enough that it's not
 251 ;;;; obvious from inspection that everything is OK. Let's make sure
 252 ;;;; that things still basically work.
 253
 254 ;; structure type tests setup
 255 (defstruct structure-foo1)
 256 (defstruct (structure-foo2 (:include structure-foo1))
 257   x)
 258 (defstruct (structure-foo3 (:include structure-foo2)))
 259 (defstruct (structure-foo4 (:include structure-foo3))
 260   y z)
 261
 262 ;; structure-class tests setup
 263 (defclass structure-class-foo1 () () (:metaclass cl:structure-class))
 264 (defclass structure-class-foo2 (structure-class-foo1)
 265   () (:metaclass cl:structure-class))
 266 (defclass structure-class-foo3 (structure-class-foo2)
 267   () (:metaclass cl:structure-class))
 268 (defclass structure-class-foo4 (structure-class-foo3)
 269   () (:metaclass cl:structure-class))
 270
 271 ;; standard-class tests setup
 272 (defclass standard-class-foo1 () () (:metaclass cl:standard-class))
 273 (defclass standard-class-foo2 (standard-class-foo1)
 274   () (:metaclass cl:standard-class))
 275 (defclass standard-class-foo3 (standard-class-foo2)
 276   () (:metaclass cl:standard-class))
 277 (defclass standard-class-foo4 (standard-class-foo3)
 278   () (:metaclass cl:standard-class))
 279
 280 ;; condition tests setup
 281 (define-condition condition-foo1 (condition) ())
 282 (define-condition condition-foo2 (condition-foo1) ())
 283 (define-condition condition-foo3 (condition-foo2) ())
 284 (define-condition condition-foo4 (condition-foo3) ())
 285
 286 ;;; inline type tests
 287 (format t "~&/setting up *TESTS-OF-INLINE-TYPE-TESTS*~%")
 288 (defparameter *tests-of-inline-type-tests*
 289   '(progn
 290
 291      ;; structure type tests
 292      (assert (typep (make-structure-foo3) 'structure-foo2))
 293      (assert (not (typep (make-structure-foo1) 'structure-foo4)))
 294      (assert (typep (nth-value 1
 295                                (ignore-errors (structure-foo2-x
 296                                                (make-structure-foo1))))
 297                     'type-error))
 298      (assert (null (ignore-errors
 299                      (setf (structure-foo2-x (make-structure-foo1)) 11))))
 300
 301      ;; structure-class tests
 302      (assert (typep (make-instance 'structure-class-foo3)
 303                     'structure-class-foo2))
 304      (assert (not (typep (make-instance 'structure-class-foo1)
 305                          'structure-class-foo4)))
 306      (assert (null (ignore-errors
 307                      (setf (slot-value (make-instance 'structure-class-foo1)
 308                                        'x)
 309                            11))))
 310
 311      ;; standard-class tests
 312      (assert (typep (make-instance 'standard-class-foo3)
 313                     'standard-class-foo2))
 314      (assert (not (typep (make-instance 'standard-class-foo1)
 315                          'standard-class-foo4)))
 316      (assert (null (ignore-errors
 317                      (setf (slot-value (make-instance 'standard-class-foo1) 'x)
 318                            11))))
 319
 320      ;; condition tests
 321      (assert (typep (make-condition 'condition-foo3)
 322                     'condition-foo2))
 323      (assert (not (typep (make-condition 'condition-foo1)
 324                          'condition-foo4)))
 325      (assert (null (ignore-errors
 326                      (setf (slot-value (make-condition 'condition-foo1) 'x)
 327                            11))))
 328      (assert (subtypep 'error 't))
 329      (assert (subtypep 'simple-condition 'condition))
 330      (assert (subtypep 'simple-error 'simple-condition))
 331      (assert (subtypep 'simple-error 'error))
 332      (assert (not (subtypep 'condition 'simple-condition)))
 333      (assert (not (subtypep 'error 'simple-error)))
 334      (assert (eq (car (sb-pcl:class-direct-superclasses
 335                        (find-class 'simple-condition)))
 336                  (find-class 'condition)))
 337
 338      #+nil ; doesn't look like a good test
 339      (let ((subclasses (mapcar #'find-class
 340                                '(simple-type-error
 341                                  simple-error
 342                                  simple-warning
 343                                  sb-int:simple-file-error
 344                                  sb-int:simple-style-warning))))
 345        (assert (null (set-difference
 346                       (sb-pcl:class-direct-subclasses (find-class
 347                                                        'simple-condition))
 348                       subclasses))))
 349
 350      ;; precedence lists
 351      (assert (equal (sb-pcl:class-precedence-list
 352                      (find-class 'simple-condition))
 353                     (mapcar #'find-class '(simple-condition
 354                                            condition
 355                                            sb-pcl::slot-object
 356                                            sb-kernel:instance
 357                                            t))))
 358
 359      ;; stream classes
 360      (assert (equal (sb-pcl:class-direct-superclasses (find-class
 361                                                        'fundamental-stream))
 362                     (mapcar #'find-class '(standard-object stream))))
 363      (assert (null (set-difference
 364                     (sb-pcl:class-direct-subclasses (find-class
 365                                                      'fundamental-stream))
 366                     (mapcar #'find-class '(fundamental-binary-stream
 367                                            fundamental-character-stream
 368                                            fundamental-output-stream
 369                                            fundamental-input-stream)))))
 370      (assert (equal (sb-pcl:class-precedence-list (find-class
 371                                                    'fundamental-stream))
 372                     (mapcar #'find-class '(fundamental-stream
 373                                            standard-object
 374                                            sb-pcl::std-object
 375                                            sb-pcl::slot-object
 376                                            stream
 377                                            sb-kernel:instance
 378                                            t))))
 379      (assert (equal (sb-pcl:class-precedence-list (find-class
 380                                                    'fundamental-stream))
 381                     (mapcar #'find-class '(fundamental-stream
 382                                            standard-object
 383                                            sb-pcl::std-object
 384                                            sb-pcl::slot-object stream
 385                                            sb-kernel:instance t))))
 386      (assert (subtypep (find-class 'stream) (find-class t)))
 387      (assert (subtypep (find-class 'fundamental-stream) 'stream))
 388      (assert (not (subtypep 'stream 'fundamental-stream)))))
 389 ;;; Test under the interpreter.
 390 (eval *tests-of-inline-type-tests*)
 391 (format t "~&/done with interpreted *TESTS-OF-INLINE-TYPE-TESTS*~%")
 392 ;;; Test under the compiler.
 393 (defun tests-of-inline-type-tests ()
 394   #.*tests-of-inline-type-tests*)
 395 (tests-of-inline-type-tests)
 396 (format t "~&/done with compiled (TESTS-OF-INLINE-TYPE-TESTS)~%")
 397 \f
 398 ;;; Redefinition of classes should alter the type hierarchy (BUG 140):
 399 (defclass superclass () ())
 400 (defclass maybe-subclass () ())
 401 (assert-nil-t (subtypep 'maybe-subclass 'superclass))
 402 (defclass maybe-subclass (superclass) ())
 403 (assert-t-t (subtypep 'maybe-subclass 'superclass))
 404 (defclass maybe-subclass () ())
 405 (assert-nil-t (subtypep 'maybe-subclass 'superclass))
 406 \f
 407 ;;; Prior to sbcl-0.7.6.27, there was some confusion in ARRAY types
 408 ;;; specialized on some as-yet-undefined type which would cause this
 409 ;;; program to fail (bugs #123 and #165). Verify that it doesn't.
 410 (defun foo (x)
 411   (declare (type (vector bar) x))
 412   (aref x 1))
 413 (deftype bar () 'single-float)
 414 (assert (eql (foo (make-array 3 :element-type 'bar :initial-element 0.0f0))
 415              0.0f0))
 416
 417 ;;; bug 260a
 418 (assert-t-t
 419  (let* ((s (gensym))
 420         (t1 (sb-kernel:specifier-type s)))
 421    (eval `(defstruct ,s))
 422    (sb-kernel:type= t1 (sb-kernel:specifier-type s))))
 423
 424 ;;; bug found by PFD's random subtypep tester
 425 (let ((t1 '(cons rational (cons (not rational) (cons integer t))))
 426       (t2 '(not (cons (integer 0 1) (cons single-float long-float)))))
 427   (assert-t-t (subtypep t1 t2))
 428   (assert-nil-t (subtypep t2 t1))
 429   (assert-t-t (subtypep `(not ,t2) `(not ,t1)))
 430   (assert-nil-t (subtypep `(not ,t1) `(not ,t2))))
 431 \f
 432 ;;; success
 433 (quit :unix-status 104)