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 (assert (raises-error? (typep #(11) '(simple-array undef-type 1))))
  74 (assert (not (typep 11 '(simple-array undef-type 1))))
  75 ;;; part II: SUBTYPEP
  76 (assert (subtypep '(vector some-undef-type) 'vector))
  77 (assert (not (subtypep '(vector some-undef-type) 'integer)))
  78 (assert-nil-nil (subtypep 'utype-1 'utype-2))
  79 (assert-nil-nil (subtypep '(vector utype-1) '(vector utype-2)))
  80 (assert-nil-nil (subtypep '(vector utype-1) '(vector t)))
  81 (assert-nil-nil (subtypep '(vector t) '(vector utype-2)))
  82
  83 ;;; ANSI specifically disallows bare AND and OR symbols as type specs.
  84 #| ; Alas, this is part of bug 10, still unfixed as of sbcl-0.6.11.10.
  85 (assert (raises-error? (typep 11 'and)))
  86 (assert (raises-error? (typep 11 'or)))
  87 |#
  88 ;;; Of course empty lists of subtypes are still OK.
  89 (assert (typep 11 '(and)))
  90 (assert (not (typep 11 '(or))))
  91
  92 ;;; bug 12: type system didn't grok nontrivial intersections
  93 (assert (subtypep '(and symbol (satisfies keywordp)) 'symbol))
  94 (assert (not (subtypep '(and symbol (satisfies keywordp)) 'null)))
  95 (assert (subtypep 'keyword 'symbol))
  96 (assert (not (subtypep 'symbol 'keyword)))
  97 (assert (subtypep 'ratio 'real))
  98 (assert (subtypep 'ratio 'number))
  99 \f
 100 ;;;; Douglas Thomas Crosher rewrote the CMU CL type test system to allow
 101 ;;;; inline type tests for CONDITIONs and STANDARD-OBJECTs, and generally
 102 ;;;; be nicer, and Martin Atzmueller ported the patches.
 103 ;;;; They look nice but they're nontrivial enough that it's not obvious
 104 ;;;; from inspection that everything is OK. Let's make sure that things
 105 ;;;; still basically work.
 106
 107 ;; structure type tests setup
 108 (defstruct structure-foo1)
 109 (defstruct (structure-foo2 (:include structure-foo1))
 110   x)
 111 (defstruct (structure-foo3 (:include structure-foo2)))
 112 (defstruct (structure-foo4 (:include structure-foo3))
 113   y z)
 114
 115 ;; structure-class tests setup
 116 (defclass structure-class-foo1 () () (:metaclass cl:structure-class))
 117 (defclass structure-class-foo2 (structure-class-foo1)
 118   () (:metaclass cl:structure-class))
 119 (defclass structure-class-foo3 (structure-class-foo2)
 120   () (:metaclass cl:structure-class))
 121 (defclass structure-class-foo4 (structure-class-foo3)
 122   () (:metaclass cl:structure-class))
 123
 124 ;; standard-class tests setup
 125 (defclass standard-class-foo1 () () (:metaclass cl:standard-class))
 126 (defclass standard-class-foo2 (standard-class-foo1)
 127   () (:metaclass cl:standard-class))
 128 (defclass standard-class-foo3 (standard-class-foo2)
 129   () (:metaclass cl:standard-class))
 130 (defclass standard-class-foo4 (standard-class-foo3)
 131   () (:metaclass cl:standard-class))
 132
 133 ;; condition tests setup
 134 (define-condition condition-foo1 (condition) ())
 135 (define-condition condition-foo2 (condition-foo1) ())
 136 (define-condition condition-foo3 (condition-foo2) ())
 137 (define-condition condition-foo4 (condition-foo3) ())
 138
 139 (fmakunbound 'test-inline-type-tests)
 140 (defun test-inline-type-tests ()
 141   ;; structure type tests
 142   (assert (typep (make-structure-foo3) 'structure-foo2))
 143   (assert (not (typep (make-structure-foo1) 'structure-foo4)))
 144   (assert (null (ignore-errors
 145                   (setf (structure-foo2-x (make-structure-foo1)) 11))))
 146
 147   ;; structure-class tests
 148   (assert (typep (make-instance 'structure-class-foo3)
 149                  'structure-class-foo2))
 150   (assert (not (typep (make-instance 'structure-class-foo1)
 151                       'structure-class-foo4)))
 152   (assert (null (ignore-errors
 153                   (setf (slot-value (make-instance 'structure-class-foo1) 'x)
 154                         11))))
 155
 156   ;; standard-class tests
 157   (assert (typep (make-instance 'standard-class-foo3)
 158                  'standard-class-foo2))
 159   (assert (not (typep (make-instance 'standard-class-foo1)
 160                       'standard-class-foo4)))
 161   (assert (null (ignore-errors
 162                   (setf (slot-value (make-instance 'standard-class-foo1) 'x)
 163                           11))))
 164
 165   ;; condition tests
 166   (assert (typep (make-condition 'condition-foo3)
 167                  'condition-foo2))
 168   (assert (not (typep (make-condition 'condition-foo1)
 169                       'condition-foo4)))
 170   (assert (null (ignore-errors
 171                   (setf (slot-value (make-condition 'condition-foo1) 'x)
 172                           11))))
 173   (assert (subtypep 'error 't))
 174   (assert (subtypep 'simple-condition 'condition))
 175   (assert (subtypep 'simple-error 'simple-condition))
 176   (assert (subtypep 'simple-error 'error))
 177   (assert (not (subtypep 'condition 'simple-condition)))
 178   (assert (not (subtypep 'error 'simple-error)))
 179   (assert (eq (car (sb-kernel:class-direct-superclasses (find-class
 180                                                          'simple-condition)))
 181               (find-class 'condition)))
 182
 183   (assert (eq (car (sb-pcl:class-direct-superclasses (sb-pcl:find-class
 184                                                       'simple-condition)))
 185               (sb-pcl:find-class 'condition)))
 186   (assert (null (set-difference
 187                  (sb-pcl:class-direct-subclasses (sb-pcl:find-class
 188                                                   'simple-condition))
 189                  (mapcar #'sb-pcl:find-class '(simple-type-error simple-error
 190                                                sb-int:simple-style-warning)))))
 191
 192   ;; precedence lists
 193   (assert (equal (sb-pcl:class-precedence-list
 194                   (sb-pcl:find-class 'simple-condition))
 195                  (mapcar #'sb-pcl:find-class '(simple-condition condition
 196                                                sb-kernel:instance t))))
 197
 198   ;; stream classes
 199   (assert (null (sb-kernel:class-direct-superclasses (find-class
 200                                                       'fundamental-stream))))
 201   (assert (equal (sb-pcl:class-direct-superclasses (sb-pcl:find-class
 202                                                     'fundamental-stream))
 203                  (mapcar #'sb-pcl:find-class '(standard-object stream))))
 204   (assert (null (set-difference
 205                  (sb-pcl:class-direct-subclasses (sb-pcl:find-class
 206                                                   'fundamental-stream))
 207                  (mapcar #'sb-pcl:find-class '(fundamental-binary-stream
 208                                                fundamental-character-stream
 209                                                fundamental-output-stream
 210                                                fundamental-input-stream)))))
 211   (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
 212                                                 'fundamental-stream))
 213                  (mapcar #'sb-pcl:find-class '(fundamental-stream
 214                                                standard-object
 215                                                sb-pcl::std-object
 216                                                sb-pcl::slot-object
 217                                                stream
 218                                                sb-kernel:instance
 219                                                t))))
 220   (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
 221                                                 'fundamental-stream))
 222                  (mapcar #'sb-pcl:find-class '(fundamental-stream
 223                                                standard-object
 224                                                sb-pcl::std-object
 225                                                sb-pcl::slot-object stream
 226                                                sb-kernel:instance t))))
 227   (assert (subtypep (find-class 'stream) (find-class t)))
 228   (assert (subtypep (find-class 'fundamental-stream) 'stream))
 229   (assert (not (subtypep 'stream 'fundamental-stream))))
 230
 231 ;;; inline-type tests:
 232 ;;; Test the interpreted version.
 233 (test-inline-type-tests)
 234 ;;; Test the compiled version.
 235 (compile nil #'test-inline-type-tests)
 236 (test-inline-type-tests)
 237
 238 ;;; success
 239 (quit :unix-status 104)