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