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