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