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