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 \f
 105 ;;;; Douglas Thomas Crosher rewrote the CMU CL type test system to
 106 ;;;; allow inline type tests for CONDITIONs and STANDARD-OBJECTs, and
 107 ;;;; generally be nicer, and Martin Atzmueller ported the patches.
 108 ;;;; They look nice but they're nontrivial enough that it's not
 109 ;;;; obvious from inspection that everything is OK. Let's make sure
 110 ;;;; that things still basically work.
 111
 112 ;; structure type tests setup
 113 (defstruct structure-foo1)
 114 (defstruct (structure-foo2 (:include structure-foo1))
 115   x)
 116 (defstruct (structure-foo3 (:include structure-foo2)))
 117 (defstruct (structure-foo4 (:include structure-foo3))
 118   y z)
 119
 120 ;; structure-class tests setup
 121 (defclass structure-class-foo1 () () (:metaclass cl:structure-class))
 122 (defclass structure-class-foo2 (structure-class-foo1)
 123   () (:metaclass cl:structure-class))
 124 (defclass structure-class-foo3 (structure-class-foo2)
 125   () (:metaclass cl:structure-class))
 126 (defclass structure-class-foo4 (structure-class-foo3)
 127   () (:metaclass cl:structure-class))
 128
 129 ;; standard-class tests setup
 130 (defclass standard-class-foo1 () () (:metaclass cl:standard-class))
 131 (defclass standard-class-foo2 (standard-class-foo1)
 132   () (:metaclass cl:standard-class))
 133 (defclass standard-class-foo3 (standard-class-foo2)
 134   () (:metaclass cl:standard-class))
 135 (defclass standard-class-foo4 (standard-class-foo3)
 136   () (:metaclass cl:standard-class))
 137
 138 ;; condition tests setup
 139 (define-condition condition-foo1 (condition) ())
 140 (define-condition condition-foo2 (condition-foo1) ())
 141 (define-condition condition-foo3 (condition-foo2) ())
 142 (define-condition condition-foo4 (condition-foo3) ())
 143
 144 ;;; inline type tests
 145 (format t "~&/setting up *TESTS-OF-INLINE-TYPE-TESTS*~%")
 146 (defparameter *tests-of-inline-type-tests*
 147   '(progn
 148
 149      ;; structure type tests
 150      (assert (typep (make-structure-foo3) 'structure-foo2))
 151      (assert (not (typep (make-structure-foo1) 'structure-foo4)))
 152      (assert (typep (nth-value 1
 153                                (ignore-errors (structure-foo2-x
 154                                                (make-structure-foo1))))
 155                     'type-error))
 156      (assert (null (ignore-errors
 157                      (setf (structure-foo2-x (make-structure-foo1)) 11))))
 158
 159      ;; structure-class tests
 160      (assert (typep (make-instance 'structure-class-foo3)
 161                     'structure-class-foo2))
 162      (assert (not (typep (make-instance 'structure-class-foo1)
 163                          'structure-class-foo4)))
 164      (assert (null (ignore-errors
 165                      (setf (slot-value (make-instance 'structure-class-foo1)
 166                                        'x)
 167                            11))))
 168
 169      ;; standard-class tests
 170      (assert (typep (make-instance 'standard-class-foo3)
 171                     'standard-class-foo2))
 172      (assert (not (typep (make-instance 'standard-class-foo1)
 173                          'standard-class-foo4)))
 174      (assert (null (ignore-errors
 175                      (setf (slot-value (make-instance 'standard-class-foo1) 'x)
 176                            11))))
 177
 178      ;; condition tests
 179      (assert (typep (make-condition 'condition-foo3)
 180                     'condition-foo2))
 181      (assert (not (typep (make-condition 'condition-foo1)
 182                          'condition-foo4)))
 183      (assert (null (ignore-errors
 184                      (setf (slot-value (make-condition 'condition-foo1) 'x)
 185                            11))))
 186      (assert (subtypep 'error 't))
 187      (assert (subtypep 'simple-condition 'condition))
 188      (assert (subtypep 'simple-error 'simple-condition))
 189      (assert (subtypep 'simple-error 'error))
 190      (assert (not (subtypep 'condition 'simple-condition)))
 191      (assert (not (subtypep 'error 'simple-error)))
 192      (assert (eq (car (sb-kernel:class-direct-superclasses
 193                        (find-class 'simple-condition)))
 194                  (find-class 'condition)))
 195
 196      (assert (eq (car (sb-pcl:class-direct-superclasses (sb-pcl:find-class
 197                                                          'simple-condition)))
 198                  (sb-pcl:find-class 'condition)))
 199
 200     (let ((subclasses (mapcar #'sb-pcl:find-class
 201                               '(simple-type-error
 202                                 simple-error
 203                                 simple-warning
 204                                 sb-int:simple-file-error
 205                                 sb-int:simple-style-warning))))
 206       (assert (null (set-difference
 207                      (sb-pcl:class-direct-subclasses (sb-pcl:find-class
 208                                                       'simple-condition))
 209                      subclasses))))
 210
 211      ;; precedence lists
 212      (assert (equal (sb-pcl:class-precedence-list
 213                      (sb-pcl:find-class 'simple-condition))
 214                     (mapcar #'sb-pcl:find-class '(simple-condition
 215                                                   condition
 216                                                   sb-kernel:instance
 217                                                   t))))
 218
 219      ;; stream classes
 220      (assert (null (sb-kernel:class-direct-superclasses
 221                     (find-class 'fundamental-stream))))
 222      (assert (equal (sb-pcl:class-direct-superclasses (sb-pcl:find-class
 223                                                        'fundamental-stream))
 224                     (mapcar #'sb-pcl:find-class '(standard-object stream))))
 225      (assert (null (set-difference
 226                     (sb-pcl:class-direct-subclasses (sb-pcl:find-class
 227                                                      'fundamental-stream))
 228                     (mapcar #'sb-pcl:find-class '(fundamental-binary-stream
 229                                                   fundamental-character-stream
 230                                                   fundamental-output-stream
 231                                                   fundamental-input-stream)))))
 232      (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
 233                                                    'fundamental-stream))
 234                     (mapcar #'sb-pcl:find-class '(fundamental-stream
 235                                                   standard-object
 236                                                   sb-pcl::std-object
 237                                                   sb-pcl::slot-object
 238                                                   stream
 239                                                   sb-kernel:instance
 240                                                   t))))
 241      (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
 242                                                    'fundamental-stream))
 243                     (mapcar #'sb-pcl:find-class '(fundamental-stream
 244                                                   standard-object
 245                                                   sb-pcl::std-object
 246                                                   sb-pcl::slot-object stream
 247                                                   sb-kernel:instance t))))
 248      (assert (subtypep (find-class 'stream) (find-class t)))
 249      (assert (subtypep (find-class 'fundamental-stream) 'stream))
 250      (assert (not (subtypep 'stream 'fundamental-stream)))))
 251 ;;; Test under the interpreter.
 252 (eval *tests-of-inline-type-tests*)
 253 (format t "~&/done with interpreted *TESTS-OF-INLINE-TYPE-TESTS*~%")
 254 ;;; Test under the compiler.
 255 (defun tests-of-inline-type-tests ()
 256   #.*tests-of-inline-type-tests*)
 257 (tests-of-inline-type-tests)
 258 (format t "~&/done with compiled (TESTS-OF-INLINE-TYPE-TESTS)~%")
 259
 260 ;;; success
 261 (quit :unix-status 104)