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 ;;; sbcl-0.6.10 did (UPGRADED-ARRAY-ELEMENT-TYPE 'SOME-UNDEF-TYPE)=>T
  61 ;;; and (UPGRADED-COMPLEX-PART-TYPE 'SOME-UNDEF-TYPE)=>T.
  62 (assert (raises-error? (upgraded-array-element-type 'some-undef-type)))
  63 (assert (eql (upgraded-array-element-type t) t))
  64 (assert (raises-error? (upgraded-complex-part-type 'some-undef-type)))
  65 (assert (subtypep (upgraded-complex-part-type 'fixnum) 'real))
  66
  67 ;;; Do reasonable things with undefined types, and with compound types
  68 ;;; built from undefined types.
  69 ;;;
  70 ;;; part I: TYPEP
  71 (assert (typep #(11) '(simple-array t 1)))
  72 (assert (typep #(11) '(simple-array (or integer symbol) 1)))
  73 ;;; FIXME: This is broken because of compiler bug 123: the compiler
  74 ;;; optimizes the type test to T, so it never gets a chance to raise a
  75 ;;; runtime error. (It used to work under the IR1 interpreter just
  76 ;;; because the IR1 interpreter doesn't try to optimize TYPEP as hard
  77 ;;; as the byte compiler does.)
  78 #+nil (assert (raises-error? (typep #(11) '(simple-array undef-type 1))))
  79 (assert (not (typep 11 '(simple-array undef-type 1))))
  80 ;;; part II: SUBTYPEP
  81 (assert (subtypep '(vector some-undef-type) 'vector))
  82 (assert (not (subtypep '(vector some-undef-type) 'integer)))
  83 (assert-nil-nil (subtypep 'utype-1 'utype-2))
  84 (assert-nil-nil (subtypep '(vector utype-1) '(vector utype-2)))
  85 (assert-nil-nil (subtypep '(vector utype-1) '(vector t)))
  86 (assert-nil-nil (subtypep '(vector t) '(vector utype-2)))
  87
  88 ;;; ANSI specifically disallows bare AND and OR symbols as type specs.
  89 #| ; Alas, this is part of bug 10, still unfixed as of sbcl-0.6.11.10.
  90 (assert (raises-error? (typep 11 'and)))
  91 (assert (raises-error? (typep 11 'or)))
  92 |#
  93 ;;; Of course empty lists of subtypes are still OK.
  94 (assert (typep 11 '(and)))
  95 (assert (not (typep 11 '(or))))
  96
  97 ;;; bug 12: type system didn't grok nontrivial intersections
  98 (assert (subtypep '(and symbol (satisfies keywordp)) 'symbol))
  99 (assert (not (subtypep '(and symbol (satisfies keywordp)) 'null)))
 100 (assert (subtypep 'keyword 'symbol))
 101 (assert (not (subtypep 'symbol 'keyword)))
 102 (assert (subtypep 'ratio 'real))
 103 (assert (subtypep 'ratio 'number))
 104
 105 ;;; bug 50.g: Smarten up hairy type specifiers slightly. We may wish
 106 ;;; to revisit this, perhaps by implementing a COMPLEMENT type
 107 ;;; (analogous to UNION and INTERSECTION) to take the logic out of the
 108 ;;; HAIRY domain.
 109 (assert-nil-t (subtypep 'atom 'cons))
 110 (assert-nil-t (subtypep 'cons 'atom))
 111 (assert-nil-t (subtypep '(not list) 'cons))
 112 (assert-nil-t (subtypep '(not float) 'single-float))
 113 (assert-t-t (subtypep '(not atom) 'cons))
 114 (assert-t-t (subtypep 'cons '(not atom)))
 115 ;;; FIXME: Another thing to revisit is %INVOKE-TYPE-METHOD.
 116 ;;; Essentially, the problem is that when the two arguments to
 117 ;;; subtypep are of different specifier-type types (e.g. HAIRY and
 118 ;;; UNION), there are two applicable type methods -- in this case
 119 ;;; HAIRY-COMPLEX-SUBTYPEP-ARG1-TYPE-METHOD and
 120 ;;; UNION-COMPLEX-SUBTYPEP-ARG2-TYPE-METHOD.  Both of these exist, but
 121 ;;; [!%]INVOKE-TYPE-METHOD aren't smart enough to know that if one of
 122 ;;; them returns NIL, NIL (indicating uncertainty) it should try the
 123 ;;; other; this is complicated by the presence of other TYPE-METHODS
 124 ;;; (e.g. INTERSECTION and UNION) whose return convention may or may
 125 ;;; not follow the same standard.
 126 #||
 127 (assert-nil-t (subtypep '(not cons) 'list))
 128 (assert-nil-t (subtypep '(not single-float) 'float))
 129 ||#
 130 ;;; If we fix the above FIXME, we should for free have fixed bug 58.
 131 #||
 132 (assert-t-t (subtypep '(and zilch integer) 'zilch))
 133 ||#
 134 \f
 135 ;;;; Douglas Thomas Crosher rewrote the CMU CL type test system to
 136 ;;;; allow inline type tests for CONDITIONs and STANDARD-OBJECTs, and
 137 ;;;; generally be nicer, and Martin Atzmueller ported the patches.
 138 ;;;; They look nice but they're nontrivial enough that it's not
 139 ;;;; obvious from inspection that everything is OK. Let's make sure
 140 ;;;; that things still basically work.
 141
 142 ;; structure type tests setup
 143 (defstruct structure-foo1)
 144 (defstruct (structure-foo2 (:include structure-foo1))
 145   x)
 146 (defstruct (structure-foo3 (:include structure-foo2)))
 147 (defstruct (structure-foo4 (:include structure-foo3))
 148   y z)
 149
 150 ;; structure-class tests setup
 151 (defclass structure-class-foo1 () () (:metaclass cl:structure-class))
 152 (defclass structure-class-foo2 (structure-class-foo1)
 153   () (:metaclass cl:structure-class))
 154 (defclass structure-class-foo3 (structure-class-foo2)
 155   () (:metaclass cl:structure-class))
 156 (defclass structure-class-foo4 (structure-class-foo3)
 157   () (:metaclass cl:structure-class))
 158
 159 ;; standard-class tests setup
 160 (defclass standard-class-foo1 () () (:metaclass cl:standard-class))
 161 (defclass standard-class-foo2 (standard-class-foo1)
 162   () (:metaclass cl:standard-class))
 163 (defclass standard-class-foo3 (standard-class-foo2)
 164   () (:metaclass cl:standard-class))
 165 (defclass standard-class-foo4 (standard-class-foo3)
 166   () (:metaclass cl:standard-class))
 167
 168 ;; condition tests setup
 169 (define-condition condition-foo1 (condition) ())
 170 (define-condition condition-foo2 (condition-foo1) ())
 171 (define-condition condition-foo3 (condition-foo2) ())
 172 (define-condition condition-foo4 (condition-foo3) ())
 173
 174 ;;; inline type tests
 175 (format t "~&/setting up *TESTS-OF-INLINE-TYPE-TESTS*~%")
 176 (defparameter *tests-of-inline-type-tests*
 177   '(progn
 178
 179      ;; structure type tests
 180      (assert (typep (make-structure-foo3) 'structure-foo2))
 181      (assert (not (typep (make-structure-foo1) 'structure-foo4)))
 182      (assert (typep (nth-value 1
 183                                (ignore-errors (structure-foo2-x
 184                                                (make-structure-foo1))))
 185                     'type-error))
 186      (assert (null (ignore-errors
 187                      (setf (structure-foo2-x (make-structure-foo1)) 11))))
 188
 189      ;; structure-class tests
 190      (assert (typep (make-instance 'structure-class-foo3)
 191                     'structure-class-foo2))
 192      (assert (not (typep (make-instance 'structure-class-foo1)
 193                          'structure-class-foo4)))
 194      (assert (null (ignore-errors
 195                      (setf (slot-value (make-instance 'structure-class-foo1)
 196                                        'x)
 197                            11))))
 198
 199      ;; standard-class tests
 200      (assert (typep (make-instance 'standard-class-foo3)
 201                     'standard-class-foo2))
 202      (assert (not (typep (make-instance 'standard-class-foo1)
 203                          'standard-class-foo4)))
 204      (assert (null (ignore-errors
 205                      (setf (slot-value (make-instance 'standard-class-foo1) 'x)
 206                            11))))
 207
 208      ;; condition tests
 209      (assert (typep (make-condition 'condition-foo3)
 210                     'condition-foo2))
 211      (assert (not (typep (make-condition 'condition-foo1)
 212                          'condition-foo4)))
 213      (assert (null (ignore-errors
 214                      (setf (slot-value (make-condition 'condition-foo1) 'x)
 215                            11))))
 216      (assert (subtypep 'error 't))
 217      (assert (subtypep 'simple-condition 'condition))
 218      (assert (subtypep 'simple-error 'simple-condition))
 219      (assert (subtypep 'simple-error 'error))
 220      (assert (not (subtypep 'condition 'simple-condition)))
 221      (assert (not (subtypep 'error 'simple-error)))
 222      (assert (eq (car (sb-kernel:class-direct-superclasses
 223                        (find-class 'simple-condition)))
 224                  (find-class 'condition)))
 225
 226      (assert (eq (car (sb-pcl:class-direct-superclasses (sb-pcl:find-class
 227                                                          'simple-condition)))
 228                  (sb-pcl:find-class 'condition)))
 229
 230     (let ((subclasses (mapcar #'sb-pcl:find-class
 231                               '(simple-type-error
 232                                 simple-error
 233                                 simple-warning
 234                                 sb-int:simple-file-error
 235                                 sb-int:simple-style-warning))))
 236       (assert (null (set-difference
 237                      (sb-pcl:class-direct-subclasses (sb-pcl:find-class
 238                                                       'simple-condition))
 239                      subclasses))))
 240
 241      ;; precedence lists
 242      (assert (equal (sb-pcl:class-precedence-list
 243                      (sb-pcl:find-class 'simple-condition))
 244                     (mapcar #'sb-pcl:find-class '(simple-condition
 245                                                   condition
 246                                                   sb-kernel:instance
 247                                                   t))))
 248
 249      ;; stream classes
 250      (assert (null (sb-kernel:class-direct-superclasses
 251                     (find-class 'fundamental-stream))))
 252      (assert (equal (sb-pcl:class-direct-superclasses (sb-pcl:find-class
 253                                                        'fundamental-stream))
 254                     (mapcar #'sb-pcl:find-class '(standard-object stream))))
 255      (assert (null (set-difference
 256                     (sb-pcl:class-direct-subclasses (sb-pcl:find-class
 257                                                      'fundamental-stream))
 258                     (mapcar #'sb-pcl:find-class '(fundamental-binary-stream
 259                                                   fundamental-character-stream
 260                                                   fundamental-output-stream
 261                                                   fundamental-input-stream)))))
 262      (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
 263                                                    'fundamental-stream))
 264                     (mapcar #'sb-pcl:find-class '(fundamental-stream
 265                                                   standard-object
 266                                                   sb-pcl::std-object
 267                                                   sb-pcl::slot-object
 268                                                   stream
 269                                                   sb-kernel:instance
 270                                                   t))))
 271      (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
 272                                                    'fundamental-stream))
 273                     (mapcar #'sb-pcl:find-class '(fundamental-stream
 274                                                   standard-object
 275                                                   sb-pcl::std-object
 276                                                   sb-pcl::slot-object stream
 277                                                   sb-kernel:instance t))))
 278      (assert (subtypep (find-class 'stream) (find-class t)))
 279      (assert (subtypep (find-class 'fundamental-stream) 'stream))
 280      (assert (not (subtypep 'stream 'fundamental-stream)))))
 281 ;;; Test under the interpreter.
 282 (eval *tests-of-inline-type-tests*)
 283 (format t "~&/done with interpreted *TESTS-OF-INLINE-TYPE-TESTS*~%")
 284 ;;; Test under the compiler.
 285 (defun tests-of-inline-type-tests ()
 286   #.*tests-of-inline-type-tests*)
 287 (tests-of-inline-type-tests)
 288 (format t "~&/done with compiled (TESTS-OF-INLINE-TYPE-TESTS)~%")
 289
 290 ;;; success
 291 (quit :unix-status 104)