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                (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
 113 ;;; Of course empty lists of subtypes are still OK.
 114 (assert (typep 11 '(and)))
 115 (assert (not (typep 11 '(or))))
 116
 117 ;;; bug 12: type system didn't grok nontrivial intersections
 118 (assert (subtypep '(and symbol (satisfies keywordp)) 'symbol))
 119 (assert (not (subtypep '(and symbol (satisfies keywordp)) 'null)))
 120 (assert (subtypep 'keyword 'symbol))
 121 (assert (not (subtypep 'symbol 'keyword)))
 122 (assert (subtypep 'ratio 'real))
 123 (assert (subtypep 'ratio 'number))
 124
 125 ;;; bug 50.g: Smarten up hairy type specifiers slightly. We may wish
 126 ;;; to revisit this, perhaps by implementing a COMPLEMENT type
 127 ;;; (analogous to UNION and INTERSECTION) to take the logic out of the
 128 ;;; HAIRY domain.
 129 (assert-nil-t (subtypep 'atom 'cons))
 130 (assert-nil-t (subtypep 'cons 'atom))
 131 ;;; These two are desireable but not necessary for ANSI conformance;
 132 ;;; maintenance work on other parts of the system broke them in
 133 ;;; sbcl-0.7.13.11 -- CSR
 134 #+nil
 135 (assert-nil-t (subtypep '(not list) 'cons))
 136 #+nil
 137 (assert-nil-t (subtypep '(not float) 'single-float))
 138 (assert-t-t (subtypep '(not atom) 'cons))
 139 (assert-t-t (subtypep 'cons '(not atom)))
 140 ;;; ANSI requires that SUBTYPEP relationships among built-in primitive
 141 ;;; types never be uncertain, i.e. never return NIL as second value.
 142 ;;; Prior to about sbcl-0.7.2.6, ATOM caused a lot of problems here
 143 ;;; (because it's a negation type, implemented as a HAIRY-TYPE, and
 144 ;;; CMU CL's HAIRY-TYPE logic punted a lot).
 145 (assert-t-t (subtypep 'integer 'atom))
 146 (assert-t-t (subtypep 'function 'atom))
 147 (assert-nil-t (subtypep 'list 'atom))
 148 (assert-nil-t (subtypep 'atom 'integer))
 149 (assert-nil-t (subtypep 'atom 'function))
 150 (assert-nil-t (subtypep 'atom 'list))
 151 ;;; ATOM is equivalent to (NOT CONS):
 152 (assert-t-t (subtypep 'integer '(not cons)))
 153 (assert-nil-t (subtypep 'list '(not cons)))
 154 (assert-nil-t (subtypep '(not cons) 'integer))
 155 (assert-nil-t (subtypep '(not cons) 'list))
 156 ;;; And we'd better check that all the named types are right. (We also
 157 ;;; do some more tests on ATOM here, since once CSR experimented with
 158 ;;; making it a named type.)
 159 (assert-t-t (subtypep 'nil 'nil))
 160 (assert-t-t (subtypep 'nil 'atom))
 161 (assert-t-t (subtypep 'nil 't))
 162 (assert-nil-t (subtypep 'atom 'nil))
 163 (assert-t-t (subtypep 'atom 'atom))
 164 (assert-t-t (subtypep 'atom 't))
 165 (assert-nil-t (subtypep 't 'nil))
 166 (assert-nil-t (subtypep 't 'atom))
 167 (assert-t-t (subtypep 't 't))
 168 ;;; Also, LIST is now somewhat special, in that (NOT LIST) should be
 169 ;;; recognized as a subtype of ATOM:
 170 (assert-t-t (subtypep '(not list) 'atom))
 171 (assert-nil-t (subtypep 'atom '(not list)))
 172 ;;; These used to fail, because when the two arguments to subtypep are
 173 ;;; of different specifier-type types (e.g. HAIRY and UNION), there
 174 ;;; are two applicable type methods -- in this case
 175 ;;; HAIRY-COMPLEX-SUBTYPEP-ARG1-TYPE-METHOD and
 176 ;;; UNION-COMPLEX-SUBTYPEP-ARG2-TYPE-METHOD. Both of these exist, but
 177 ;;; [!%]INVOKE-TYPE-METHOD aren't smart enough to know that if one of
 178 ;;; them returns NIL, NIL (indicating uncertainty) it should try the
 179 ;;; other. However, as of sbcl-0.7.2.6 or so, CALL-NEXT-METHOD-ish
 180 ;;; logic in those type methods fixed it.
 181 (assert-nil-t (subtypep '(not cons) 'list))
 182 (assert-nil-t (subtypep '(not single-float) 'float))
 183 ;;; Somewhere along the line (probably when adding CALL-NEXT-METHOD-ish
 184 ;;; logic in SUBTYPEP type methods) we fixed bug 58 too:
 185 (assert-t-t (subtypep '(and zilch integer) 'zilch))
 186 (assert-t-t (subtypep '(and integer zilch) 'zilch))
 187
 188 ;;; Bug 84: SB-KERNEL:CSUBTYPEP was a bit enthusiastic at
 189 ;;; special-casing calls to subtypep involving *EMPTY-TYPE*,
 190 ;;; corresponding to the NIL type-specifier; we were bogusly returning
 191 ;;; NIL, T (indicating surety) for the following:
 192 (assert-nil-nil (subtypep '(satisfies some-undefined-fun) 'nil))
 193
 194 ;;; It turns out that, as of sbcl-0.7.2, we require to be able to
 195 ;;; detect this to compile src/compiler/node.lisp (and in particular,
 196 ;;; the definition of the component structure). Since it's a sensible
 197 ;;; thing to want anyway, let's test for it here:
 198 (assert-t-t (subtypep '(or some-undefined-type (member :no-ir2-yet :dead))
 199                       '(or some-undefined-type (member :no-ir2-yet :dead))))
 200 ;;; BUG 158 (failure to compile loops with vector references and
 201 ;;; increments of greater than 1) was a symptom of type system
 202 ;;; uncertainty, to wit:
 203 (assert-t-t (subtypep '(and (mod 536870911) (or (integer 0 0) (integer 2 536870912)))
 204                       '(mod 536870911))) ; aka SB-INT:INDEX.
 205 ;;; floating point types can be tricky.
 206 (assert-t-t (subtypep '(member 0.0) '(single-float 0.0 0.0)))
 207 (assert-t-t (subtypep '(member -0.0) '(single-float 0.0 0.0)))
 208 (assert-t-t (subtypep '(member 0.0) '(single-float -0.0 0.0)))
 209 (assert-t-t (subtypep '(member -0.0) '(single-float 0.0 -0.0)))
 210 (assert-t-t (subtypep '(member 0.0d0) '(double-float 0.0d0 0.0d0)))
 211 (assert-t-t (subtypep '(member -0.0d0) '(double-float 0.0d0 0.0d0)))
 212 (assert-t-t (subtypep '(member 0.0d0) '(double-float -0.0d0 0.0d0)))
 213 (assert-t-t (subtypep '(member -0.0d0) '(double-float 0.0d0 -0.0d0)))
 214
 215 (assert-nil-t (subtypep '(single-float 0.0 0.0) '(member 0.0)))
 216 (assert-nil-t (subtypep '(single-float 0.0 0.0) '(member -0.0)))
 217 (assert-nil-t (subtypep '(single-float -0.0 0.0) '(member 0.0)))
 218 (assert-nil-t (subtypep '(single-float 0.0 -0.0) '(member -0.0)))
 219 (assert-nil-t (subtypep '(double-float 0.0d0 0.0d0) '(member 0.0d0)))
 220 (assert-nil-t (subtypep '(double-float 0.0d0 0.0d0) '(member -0.0d0)))
 221 (assert-nil-t (subtypep '(double-float -0.0d0 0.0d0) '(member 0.0d0)))
 222 (assert-nil-t (subtypep '(double-float 0.0d0 -0.0d0) '(member -0.0d0)))
 223
 224 (assert-t-t (subtypep '(member 0.0 -0.0) '(single-float 0.0 0.0)))
 225 (assert-t-t (subtypep '(single-float 0.0 0.0) '(member 0.0 -0.0)))
 226 (assert-t-t (subtypep '(member 0.0d0 -0.0d0) '(double-float 0.0d0 0.0d0)))
 227 (assert-t-t (subtypep '(double-float 0.0d0 0.0d0) '(member 0.0d0 -0.0d0)))
 228
 229 (assert-t-t (subtypep '(not (single-float 0.0 0.0)) '(not (member 0.0))))
 230 (assert-t-t (subtypep '(not (double-float 0.0d0 0.0d0)) '(not (member 0.0d0))))
 231
 232 (assert-t-t (subtypep '(float -0.0) '(float 0.0)))
 233 (assert-t-t (subtypep '(float 0.0) '(float -0.0)))
 234 (assert-t-t (subtypep '(float (0.0)) '(float (-0.0))))
 235 (assert-t-t (subtypep '(float (-0.0)) '(float (0.0))))
 236 \f
 237 ;;;; Douglas Thomas Crosher rewrote the CMU CL type test system to
 238 ;;;; allow inline type tests for CONDITIONs and STANDARD-OBJECTs, and
 239 ;;;; generally be nicer, and Martin Atzmueller ported the patches.
 240 ;;;; They look nice but they're nontrivial enough that it's not
 241 ;;;; obvious from inspection that everything is OK. Let's make sure
 242 ;;;; that things still basically work.
 243
 244 ;; structure type tests setup
 245 (defstruct structure-foo1)
 246 (defstruct (structure-foo2 (:include structure-foo1))
 247   x)
 248 (defstruct (structure-foo3 (:include structure-foo2)))
 249 (defstruct (structure-foo4 (:include structure-foo3))
 250   y z)
 251
 252 ;; structure-class tests setup
 253 (defclass structure-class-foo1 () () (:metaclass cl:structure-class))
 254 (defclass structure-class-foo2 (structure-class-foo1)
 255   () (:metaclass cl:structure-class))
 256 (defclass structure-class-foo3 (structure-class-foo2)
 257   () (:metaclass cl:structure-class))
 258 (defclass structure-class-foo4 (structure-class-foo3)
 259   () (:metaclass cl:structure-class))
 260
 261 ;; standard-class tests setup
 262 (defclass standard-class-foo1 () () (:metaclass cl:standard-class))
 263 (defclass standard-class-foo2 (standard-class-foo1)
 264   () (:metaclass cl:standard-class))
 265 (defclass standard-class-foo3 (standard-class-foo2)
 266   () (:metaclass cl:standard-class))
 267 (defclass standard-class-foo4 (standard-class-foo3)
 268   () (:metaclass cl:standard-class))
 269
 270 ;; condition tests setup
 271 (define-condition condition-foo1 (condition) ())
 272 (define-condition condition-foo2 (condition-foo1) ())
 273 (define-condition condition-foo3 (condition-foo2) ())
 274 (define-condition condition-foo4 (condition-foo3) ())
 275
 276 ;;; inline type tests
 277 (format t "~&/setting up *TESTS-OF-INLINE-TYPE-TESTS*~%")
 278 (defparameter *tests-of-inline-type-tests*
 279   '(progn
 280
 281      ;; structure type tests
 282      (assert (typep (make-structure-foo3) 'structure-foo2))
 283      (assert (not (typep (make-structure-foo1) 'structure-foo4)))
 284      (assert (typep (nth-value 1
 285                                (ignore-errors (structure-foo2-x
 286                                                (make-structure-foo1))))
 287                     'type-error))
 288      (assert (null (ignore-errors
 289                      (setf (structure-foo2-x (make-structure-foo1)) 11))))
 290
 291      ;; structure-class tests
 292      (assert (typep (make-instance 'structure-class-foo3)
 293                     'structure-class-foo2))
 294      (assert (not (typep (make-instance 'structure-class-foo1)
 295                          'structure-class-foo4)))
 296      (assert (null (ignore-errors
 297                      (setf (slot-value (make-instance 'structure-class-foo1)
 298                                        'x)
 299                            11))))
 300
 301      ;; standard-class tests
 302      (assert (typep (make-instance 'standard-class-foo3)
 303                     'standard-class-foo2))
 304      (assert (not (typep (make-instance 'standard-class-foo1)
 305                          'standard-class-foo4)))
 306      (assert (null (ignore-errors
 307                      (setf (slot-value (make-instance 'standard-class-foo1) 'x)
 308                            11))))
 309
 310      ;; condition tests
 311      (assert (typep (make-condition 'condition-foo3)
 312                     'condition-foo2))
 313      (assert (not (typep (make-condition 'condition-foo1)
 314                          'condition-foo4)))
 315      (assert (null (ignore-errors
 316                      (setf (slot-value (make-condition 'condition-foo1) 'x)
 317                            11))))
 318      (assert (subtypep 'error 't))
 319      (assert (subtypep 'simple-condition 'condition))
 320      (assert (subtypep 'simple-error 'simple-condition))
 321      (assert (subtypep 'simple-error 'error))
 322      (assert (not (subtypep 'condition 'simple-condition)))
 323      (assert (not (subtypep 'error 'simple-error)))
 324      (assert (eq (car (sb-pcl:class-direct-superclasses
 325                        (find-class 'simple-condition)))
 326                  (find-class 'condition)))
 327
 328     (let ((subclasses (mapcar #'find-class
 329                               '(simple-type-error
 330                                 simple-error
 331                                 simple-warning
 332                                 sb-int:simple-file-error
 333                                 sb-int:simple-style-warning))))
 334       (assert (null (set-difference
 335                      (sb-pcl:class-direct-subclasses (find-class
 336                                                       'simple-condition))
 337                      subclasses))))
 338
 339      ;; precedence lists
 340      (assert (equal (sb-pcl:class-precedence-list
 341                      (find-class 'simple-condition))
 342                     (mapcar #'find-class '(simple-condition
 343                                            condition
 344                                            sb-pcl::slot-object
 345                                            sb-kernel:instance
 346                                            t))))
 347
 348      ;; stream classes
 349      (assert (equal (sb-pcl:class-direct-superclasses (find-class
 350                                                        'fundamental-stream))
 351                     (mapcar #'find-class '(standard-object stream))))
 352      (assert (null (set-difference
 353                     (sb-pcl:class-direct-subclasses (find-class
 354                                                      'fundamental-stream))
 355                     (mapcar #'find-class '(fundamental-binary-stream
 356                                            fundamental-character-stream
 357                                            fundamental-output-stream
 358                                            fundamental-input-stream)))))
 359      (assert (equal (sb-pcl:class-precedence-list (find-class
 360                                                    'fundamental-stream))
 361                     (mapcar #'find-class '(fundamental-stream
 362                                            standard-object
 363                                            sb-pcl::std-object
 364                                            sb-pcl::slot-object
 365                                            stream
 366                                            sb-kernel:instance
 367                                            t))))
 368      (assert (equal (sb-pcl:class-precedence-list (find-class
 369                                                    'fundamental-stream))
 370                     (mapcar #'find-class '(fundamental-stream
 371                                            standard-object
 372                                            sb-pcl::std-object
 373                                            sb-pcl::slot-object stream
 374                                            sb-kernel:instance t))))
 375      (assert (subtypep (find-class 'stream) (find-class t)))
 376      (assert (subtypep (find-class 'fundamental-stream) 'stream))
 377      (assert (not (subtypep 'stream 'fundamental-stream)))))
 378 ;;; Test under the interpreter.
 379 (eval *tests-of-inline-type-tests*)
 380 (format t "~&/done with interpreted *TESTS-OF-INLINE-TYPE-TESTS*~%")
 381 ;;; Test under the compiler.
 382 (defun tests-of-inline-type-tests ()
 383   #.*tests-of-inline-type-tests*)
 384 (tests-of-inline-type-tests)
 385 (format t "~&/done with compiled (TESTS-OF-INLINE-TYPE-TESTS)~%")
 386 \f
 387 ;;; Redefinition of classes should alter the type hierarchy (BUG 140):
 388 (defclass superclass () ())
 389 (defclass maybe-subclass () ())
 390 (assert-nil-t (subtypep 'maybe-subclass 'superclass))
 391 (defclass maybe-subclass (superclass) ())
 392 (assert-t-t (subtypep 'maybe-subclass 'superclass))
 393 (defclass maybe-subclass () ())
 394 (assert-nil-t (subtypep 'maybe-subclass 'superclass))
 395 \f
 396 ;;; Prior to sbcl-0.7.6.27, there was some confusion in ARRAY types
 397 ;;; specialized on some as-yet-undefined type which would cause this
 398 ;;; program to fail (bugs #123 and #165). Verify that it doesn't.
 399 (defun foo (x)
 400   (declare (type (vector bar) x))
 401   (aref x 1))
 402 (deftype bar () 'single-float)
 403 (assert (eql (foo (make-array 3 :element-type 'bar :initial-element 0.0f0))
 404              0.0f0))
 405
 406 ;;; bug 260a
 407 (assert-t-t
 408  (let* ((s (gensym))
 409         (t1 (sb-kernel:specifier-type s)))
 410    (eval `(defstruct ,s))
 411    (sb-kernel:type= t1 (sb-kernel:specifier-type s))))
 412 \f
 413 ;;; success
 414 (quit :unix-status 104)