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.6.11.10.
  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 ;;; FIXME: Another thing to revisit is %INVOKE-TYPE-METHOD.
 121 ;;; Essentially, the problem is that when the two arguments to
 122 ;;; subtypep are of different specifier-type types (e.g. HAIRY and
 123 ;;; UNION), there are two applicable type methods -- in this case
 124 ;;; HAIRY-COMPLEX-SUBTYPEP-ARG1-TYPE-METHOD and
 125 ;;; UNION-COMPLEX-SUBTYPEP-ARG2-TYPE-METHOD.  Both of these exist, but
 126 ;;; [!%]INVOKE-TYPE-METHOD aren't smart enough to know that if one of
 127 ;;; them returns NIL, NIL (indicating uncertainty) it should try the
 128 ;;; other; this is complicated by the presence of other TYPE-METHODS
 129 ;;; (e.g. INTERSECTION and UNION) whose return convention may or may
 130 ;;; not follow the same standard.
 131 #||
 132 (assert-nil-t (subtypep '(not cons) 'list))
 133 (assert-nil-t (subtypep '(not single-float) 'float))
 134 ||#
 135 ;;; If we fix the above FIXME, we should for free have fixed bug 58.
 136 #||
 137 (assert-t-t (subtypep '(and zilch integer) 'zilch))
 138 ||#
 139 ;;; Bug 84: SB-KERNEL:CSUBTYPEP was a bit enthusiastic at
 140 ;;; special-casing calls to subtypep involving *EMPTY-TYPE*,
 141 ;;; corresponding to the NIL type-specifier; we were bogusly returning
 142 ;;; NIL, T (indicating surety) for the following:
 143 (assert-nil-nil (subtypep '(satisfies some-undefined-fun) 'nil))
 144 \f
 145 ;;;; Douglas Thomas Crosher rewrote the CMU CL type test system to
 146 ;;;; allow inline type tests for CONDITIONs and STANDARD-OBJECTs, and
 147 ;;;; generally be nicer, and Martin Atzmueller ported the patches.
 148 ;;;; They look nice but they're nontrivial enough that it's not
 149 ;;;; obvious from inspection that everything is OK. Let's make sure
 150 ;;;; that things still basically work.
 151
 152 ;; structure type tests setup
 153 (defstruct structure-foo1)
 154 (defstruct (structure-foo2 (:include structure-foo1))
 155   x)
 156 (defstruct (structure-foo3 (:include structure-foo2)))
 157 (defstruct (structure-foo4 (:include structure-foo3))
 158   y z)
 159
 160 ;; structure-class tests setup
 161 (defclass structure-class-foo1 () () (:metaclass cl:structure-class))
 162 (defclass structure-class-foo2 (structure-class-foo1)
 163   () (:metaclass cl:structure-class))
 164 (defclass structure-class-foo3 (structure-class-foo2)
 165   () (:metaclass cl:structure-class))
 166 (defclass structure-class-foo4 (structure-class-foo3)
 167   () (:metaclass cl:structure-class))
 168
 169 ;; standard-class tests setup
 170 (defclass standard-class-foo1 () () (:metaclass cl:standard-class))
 171 (defclass standard-class-foo2 (standard-class-foo1)
 172   () (:metaclass cl:standard-class))
 173 (defclass standard-class-foo3 (standard-class-foo2)
 174   () (:metaclass cl:standard-class))
 175 (defclass standard-class-foo4 (standard-class-foo3)
 176   () (:metaclass cl:standard-class))
 177
 178 ;; condition tests setup
 179 (define-condition condition-foo1 (condition) ())
 180 (define-condition condition-foo2 (condition-foo1) ())
 181 (define-condition condition-foo3 (condition-foo2) ())
 182 (define-condition condition-foo4 (condition-foo3) ())
 183
 184 ;;; inline type tests
 185 (format t "~&/setting up *TESTS-OF-INLINE-TYPE-TESTS*~%")
 186 (defparameter *tests-of-inline-type-tests*
 187   '(progn
 188
 189      ;; structure type tests
 190      (assert (typep (make-structure-foo3) 'structure-foo2))
 191      (assert (not (typep (make-structure-foo1) 'structure-foo4)))
 192      (assert (typep (nth-value 1
 193                                (ignore-errors (structure-foo2-x
 194                                                (make-structure-foo1))))
 195                     'type-error))
 196      (assert (null (ignore-errors
 197                      (setf (structure-foo2-x (make-structure-foo1)) 11))))
 198
 199      ;; structure-class tests
 200      (assert (typep (make-instance 'structure-class-foo3)
 201                     'structure-class-foo2))
 202      (assert (not (typep (make-instance 'structure-class-foo1)
 203                          'structure-class-foo4)))
 204      (assert (null (ignore-errors
 205                      (setf (slot-value (make-instance 'structure-class-foo1)
 206                                        'x)
 207                            11))))
 208
 209      ;; standard-class tests
 210      (assert (typep (make-instance 'standard-class-foo3)
 211                     'standard-class-foo2))
 212      (assert (not (typep (make-instance 'standard-class-foo1)
 213                          'standard-class-foo4)))
 214      (assert (null (ignore-errors
 215                      (setf (slot-value (make-instance 'standard-class-foo1) 'x)
 216                            11))))
 217
 218      ;; condition tests
 219      (assert (typep (make-condition 'condition-foo3)
 220                     'condition-foo2))
 221      (assert (not (typep (make-condition 'condition-foo1)
 222                          'condition-foo4)))
 223      (assert (null (ignore-errors
 224                      (setf (slot-value (make-condition 'condition-foo1) 'x)
 225                            11))))
 226      (assert (subtypep 'error 't))
 227      (assert (subtypep 'simple-condition 'condition))
 228      (assert (subtypep 'simple-error 'simple-condition))
 229      (assert (subtypep 'simple-error 'error))
 230      (assert (not (subtypep 'condition 'simple-condition)))
 231      (assert (not (subtypep 'error 'simple-error)))
 232      (assert (eq (car (sb-kernel:class-direct-superclasses
 233                        (find-class 'simple-condition)))
 234                  (find-class 'condition)))
 235
 236      (assert (eq (car (sb-pcl:class-direct-superclasses (sb-pcl:find-class
 237                                                          'simple-condition)))
 238                  (sb-pcl:find-class 'condition)))
 239
 240     (let ((subclasses (mapcar #'sb-pcl:find-class
 241                               '(simple-type-error
 242                                 simple-error
 243                                 simple-warning
 244                                 sb-int:simple-file-error
 245                                 sb-int:simple-style-warning))))
 246       (assert (null (set-difference
 247                      (sb-pcl:class-direct-subclasses (sb-pcl:find-class
 248                                                       'simple-condition))
 249                      subclasses))))
 250
 251      ;; precedence lists
 252      (assert (equal (sb-pcl:class-precedence-list
 253                      (sb-pcl:find-class 'simple-condition))
 254                     (mapcar #'sb-pcl:find-class '(simple-condition
 255                                                   condition
 256                                                   sb-kernel:instance
 257                                                   t))))
 258
 259      ;; stream classes
 260      (assert (null (sb-kernel:class-direct-superclasses
 261                     (find-class 'fundamental-stream))))
 262      (assert (equal (sb-pcl:class-direct-superclasses (sb-pcl:find-class
 263                                                        'fundamental-stream))
 264                     (mapcar #'sb-pcl:find-class '(standard-object stream))))
 265      (assert (null (set-difference
 266                     (sb-pcl:class-direct-subclasses (sb-pcl:find-class
 267                                                      'fundamental-stream))
 268                     (mapcar #'sb-pcl:find-class '(fundamental-binary-stream
 269                                                   fundamental-character-stream
 270                                                   fundamental-output-stream
 271                                                   fundamental-input-stream)))))
 272      (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
 273                                                    'fundamental-stream))
 274                     (mapcar #'sb-pcl:find-class '(fundamental-stream
 275                                                   standard-object
 276                                                   sb-pcl::std-object
 277                                                   sb-pcl::slot-object
 278                                                   stream
 279                                                   sb-kernel:instance
 280                                                   t))))
 281      (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
 282                                                    'fundamental-stream))
 283                     (mapcar #'sb-pcl:find-class '(fundamental-stream
 284                                                   standard-object
 285                                                   sb-pcl::std-object
 286                                                   sb-pcl::slot-object stream
 287                                                   sb-kernel:instance t))))
 288      (assert (subtypep (find-class 'stream) (find-class t)))
 289      (assert (subtypep (find-class 'fundamental-stream) 'stream))
 290      (assert (not (subtypep 'stream 'fundamental-stream)))))
 291 ;;; Test under the interpreter.
 292 (eval *tests-of-inline-type-tests*)
 293 (format t "~&/done with interpreted *TESTS-OF-INLINE-TYPE-TESTS*~%")
 294 ;;; Test under the compiler.
 295 (defun tests-of-inline-type-tests ()
 296   #.*tests-of-inline-type-tests*)
 297 (tests-of-inline-type-tests)
 298 (format t "~&/done with compiled (TESTS-OF-INLINE-TYPE-TESTS)~%")
 299
 300 ;;; success
 301 (quit :unix-status 104)