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
 174   (assert (eq (car (sb-kernel:class-direct-superclasses (find-class
 175                                                          'simple-condition)))
 176               (find-class 'condition)))
 177
 178   (assert (eq (car (sb-pcl:class-direct-superclasses (sb-pcl:find-class
 179                                                       'simple-condition)))
 180               (sb-pcl:find-class 'condition)))
 181   (assert (null (set-difference
 182                  (sb-pcl:class-direct-subclasses (sb-pcl:find-class
 183                                                   'simple-condition))
 184                  (mapcar #'sb-pcl:find-class '(simple-type-error simple-error
 185                                                sb-int:simple-style-warning)))))
 186   ;; precedence lists
 187   (assert (equal (sb-pcl:class-precedence-list
 188                   (sb-pcl:find-class 'simple-condition))
 189                  (mapcar #'sb-pcl:find-class '(simple-condition condition
 190                                                sb-kernel:instance t))))
 191
 192   ;; stream classes
 193   (assert (null (sb-kernel:class-direct-superclasses (find-class
 194                                                       'fundamental-stream))))
 195   (assert (equal (sb-pcl:class-direct-superclasses (sb-pcl:find-class
 196                                                     'fundamental-stream))
 197                  (mapcar #'sb-pcl:find-class '(standard-object stream))))
 198   (assert (null (set-difference
 199                  (sb-pcl:class-direct-subclasses (sb-pcl:find-class
 200                                                   'fundamental-stream))
 201                  (mapcar #'sb-pcl:find-class '(fundamental-binary-stream
 202                                                fundamental-character-stream
 203                                                fundamental-output-stream
 204                                                fundamental-input-stream)))))
 205   (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
 206                                                 'fundamental-stream))
 207                  (mapcar #'sb-pcl:find-class '(fundamental-stream
 208                                                standard-object
 209                                                sb-pcl::std-object
 210                                                sb-pcl::slot-object
 211                                                stream
 212                                                sb-kernel:instance
 213                                                t))))
 214   (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
 215                                                 'fundamental-stream))
 216                  (mapcar #'sb-pcl:find-class '(fundamental-stream
 217                                                standard-object
 218                                                sb-pcl::std-object
 219                                                sb-pcl::slot-object stream
 220                                                sb-kernel:instance t)))))
 221
 222 ;;; inline-type tests:
 223 ;;; Test the interpreted version.
 224 (test-inline-type-tests)
 225 ;;; Test the compiled version.
 226 (compile nil #'test-inline-type-tests)
 227 (test-inline-type-tests)
 228
 229 ;;; success
 230 (quit :unix-status 104)