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 \f
 186 ;;;; Douglas Thomas Crosher rewrote the CMU CL type test system to
 187 ;;;; allow inline type tests for CONDITIONs and STANDARD-OBJECTs, and
 188 ;;;; generally be nicer, and Martin Atzmueller ported the patches.
 189 ;;;; They look nice but they're nontrivial enough that it's not
 190 ;;;; obvious from inspection that everything is OK. Let's make sure
 191 ;;;; that things still basically work.
 192
 193 ;; structure type tests setup
 194 (defstruct structure-foo1)
 195 (defstruct (structure-foo2 (:include structure-foo1))
 196   x)
 197 (defstruct (structure-foo3 (:include structure-foo2)))
 198 (defstruct (structure-foo4 (:include structure-foo3))
 199   y z)
 200
 201 ;; structure-class tests setup
 202 (defclass structure-class-foo1 () () (:metaclass cl:structure-class))
 203 (defclass structure-class-foo2 (structure-class-foo1)
 204   () (:metaclass cl:structure-class))
 205 (defclass structure-class-foo3 (structure-class-foo2)
 206   () (:metaclass cl:structure-class))
 207 (defclass structure-class-foo4 (structure-class-foo3)
 208   () (:metaclass cl:structure-class))
 209
 210 ;; standard-class tests setup
 211 (defclass standard-class-foo1 () () (:metaclass cl:standard-class))
 212 (defclass standard-class-foo2 (standard-class-foo1)
 213   () (:metaclass cl:standard-class))
 214 (defclass standard-class-foo3 (standard-class-foo2)
 215   () (:metaclass cl:standard-class))
 216 (defclass standard-class-foo4 (standard-class-foo3)
 217   () (:metaclass cl:standard-class))
 218
 219 ;; condition tests setup
 220 (define-condition condition-foo1 (condition) ())
 221 (define-condition condition-foo2 (condition-foo1) ())
 222 (define-condition condition-foo3 (condition-foo2) ())
 223 (define-condition condition-foo4 (condition-foo3) ())
 224
 225 ;;; inline type tests
 226 (format t "~&/setting up *TESTS-OF-INLINE-TYPE-TESTS*~%")
 227 (defparameter *tests-of-inline-type-tests*
 228   '(progn
 229
 230      ;; structure type tests
 231      (assert (typep (make-structure-foo3) 'structure-foo2))
 232      (assert (not (typep (make-structure-foo1) 'structure-foo4)))
 233      (assert (typep (nth-value 1
 234                                (ignore-errors (structure-foo2-x
 235                                                (make-structure-foo1))))
 236                     'type-error))
 237      (assert (null (ignore-errors
 238                      (setf (structure-foo2-x (make-structure-foo1)) 11))))
 239
 240      ;; structure-class tests
 241      (assert (typep (make-instance 'structure-class-foo3)
 242                     'structure-class-foo2))
 243      (assert (not (typep (make-instance 'structure-class-foo1)
 244                          'structure-class-foo4)))
 245      (assert (null (ignore-errors
 246                      (setf (slot-value (make-instance 'structure-class-foo1)
 247                                        'x)
 248                            11))))
 249
 250      ;; standard-class tests
 251      (assert (typep (make-instance 'standard-class-foo3)
 252                     'standard-class-foo2))
 253      (assert (not (typep (make-instance 'standard-class-foo1)
 254                          'standard-class-foo4)))
 255      (assert (null (ignore-errors
 256                      (setf (slot-value (make-instance 'standard-class-foo1) 'x)
 257                            11))))
 258
 259      ;; condition tests
 260      (assert (typep (make-condition 'condition-foo3)
 261                     'condition-foo2))
 262      (assert (not (typep (make-condition 'condition-foo1)
 263                          'condition-foo4)))
 264      (assert (null (ignore-errors
 265                      (setf (slot-value (make-condition 'condition-foo1) 'x)
 266                            11))))
 267      (assert (subtypep 'error 't))
 268      (assert (subtypep 'simple-condition 'condition))
 269      (assert (subtypep 'simple-error 'simple-condition))
 270      (assert (subtypep 'simple-error 'error))
 271      (assert (not (subtypep 'condition 'simple-condition)))
 272      (assert (not (subtypep 'error 'simple-error)))
 273      (assert (eq (car (sb-kernel:class-direct-superclasses
 274                        (find-class 'simple-condition)))
 275                  (find-class 'condition)))
 276
 277      (assert (eq (car (sb-pcl:class-direct-superclasses (sb-pcl:find-class
 278                                                          'simple-condition)))
 279                  (sb-pcl:find-class 'condition)))
 280
 281     (let ((subclasses (mapcar #'sb-pcl:find-class
 282                               '(simple-type-error
 283                                 simple-error
 284                                 simple-warning
 285                                 sb-int:simple-file-error
 286                                 sb-int:simple-style-warning))))
 287       (assert (null (set-difference
 288                      (sb-pcl:class-direct-subclasses (sb-pcl:find-class
 289                                                       'simple-condition))
 290                      subclasses))))
 291
 292      ;; precedence lists
 293      (assert (equal (sb-pcl:class-precedence-list
 294                      (sb-pcl:find-class 'simple-condition))
 295                     (mapcar #'sb-pcl:find-class '(simple-condition
 296                                                   condition
 297                                                   sb-kernel:instance
 298                                                   t))))
 299
 300      ;; stream classes
 301      (assert (null (sb-kernel:class-direct-superclasses
 302                     (find-class 'fundamental-stream))))
 303      (assert (equal (sb-pcl:class-direct-superclasses (sb-pcl:find-class
 304                                                        'fundamental-stream))
 305                     (mapcar #'sb-pcl:find-class '(standard-object stream))))
 306      (assert (null (set-difference
 307                     (sb-pcl:class-direct-subclasses (sb-pcl:find-class
 308                                                      'fundamental-stream))
 309                     (mapcar #'sb-pcl:find-class '(fundamental-binary-stream
 310                                                   fundamental-character-stream
 311                                                   fundamental-output-stream
 312                                                   fundamental-input-stream)))))
 313      (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
 314                                                    'fundamental-stream))
 315                     (mapcar #'sb-pcl:find-class '(fundamental-stream
 316                                                   standard-object
 317                                                   sb-pcl::std-object
 318                                                   sb-pcl::slot-object
 319                                                   stream
 320                                                   sb-kernel:instance
 321                                                   t))))
 322      (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
 323                                                    'fundamental-stream))
 324                     (mapcar #'sb-pcl:find-class '(fundamental-stream
 325                                                   standard-object
 326                                                   sb-pcl::std-object
 327                                                   sb-pcl::slot-object stream
 328                                                   sb-kernel:instance t))))
 329      (assert (subtypep (find-class 'stream) (find-class t)))
 330      (assert (subtypep (find-class 'fundamental-stream) 'stream))
 331      (assert (not (subtypep 'stream 'fundamental-stream)))))
 332 ;;; Test under the interpreter.
 333 (eval *tests-of-inline-type-tests*)
 334 (format t "~&/done with interpreted *TESTS-OF-INLINE-TYPE-TESTS*~%")
 335 ;;; Test under the compiler.
 336 (defun tests-of-inline-type-tests ()
 337   #.*tests-of-inline-type-tests*)
 338 (tests-of-inline-type-tests)
 339 (format t "~&/done with compiled (TESTS-OF-INLINE-TYPE-TESTS)~%")
 340
 341 ;;; success
 342 (quit :unix-status 104)