tests/type.impure.lisp

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