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 ;;; inline type tests
 141 (format t "~&/setting up *TESTS-OF-INLINE-TYPE-TESTS*~%")
 142 (defparameter *tests-of-inline-type-tests*
 143   '(progn
 144
 145      ;; structure type tests
 146      (assert (typep (make-structure-foo3) 'structure-foo2))
 147      (assert (not (typep (make-structure-foo1) 'structure-foo4)))
 148      (assert (null (ignore-errors
 149                      (setf (structure-foo2-x (make-structure-foo1)) 11))))
 150
 151      ;; structure-class tests
 152      (assert (typep (make-instance 'structure-class-foo3)
 153                     'structure-class-foo2))
 154      (assert (not (typep (make-instance 'structure-class-foo1)
 155                          'structure-class-foo4)))
 156      (assert (null (ignore-errors
 157                      (setf (slot-value (make-instance 'structure-class-foo1)
 158                                        'x)
 159                            11))))
 160
 161      ;; standard-class tests
 162      (assert (typep (make-instance 'standard-class-foo3)
 163                     'standard-class-foo2))
 164      (assert (not (typep (make-instance 'standard-class-foo1)
 165                          'standard-class-foo4)))
 166      (assert (null (ignore-errors
 167                      (setf (slot-value (make-instance 'standard-class-foo1) 'x)
 168                            11))))
 169
 170      ;; condition tests
 171      (assert (typep (make-condition 'condition-foo3)
 172                     'condition-foo2))
 173      (assert (not (typep (make-condition 'condition-foo1)
 174                          'condition-foo4)))
 175      (assert (null (ignore-errors
 176                      (setf (slot-value (make-condition 'condition-foo1) 'x)
 177                            11))))
 178      (assert (subtypep 'error 't))
 179      (assert (subtypep 'simple-condition 'condition))
 180      (assert (subtypep 'simple-error 'simple-condition))
 181      (assert (subtypep 'simple-error 'error))
 182      (assert (not (subtypep 'condition 'simple-condition)))
 183      (assert (not (subtypep 'error 'simple-error)))
 184      (assert (eq (car (sb-kernel:class-direct-superclasses
 185                        (find-class 'simple-condition)))
 186                  (find-class 'condition)))
 187
 188      (assert (eq (car (sb-pcl:class-direct-superclasses (sb-pcl:find-class
 189                                                          'simple-condition)))
 190                  (sb-pcl:find-class 'condition)))
 191      (assert (null (set-difference
 192                     (sb-pcl:class-direct-subclasses (sb-pcl:find-class
 193                                                      'simple-condition))
 194                     (mapcar #'sb-pcl:find-class
 195                             '(simple-type-error simple-error
 196                                                 sb-int:simple-style-warning)))))
 197
 198      ;; precedence lists
 199      (assert (equal (sb-pcl:class-precedence-list
 200                      (sb-pcl:find-class 'simple-condition))
 201                     (mapcar #'sb-pcl:find-class '(simple-condition
 202                                                   condition
 203                                                   sb-kernel:instance
 204                                                   t))))
 205
 206      ;; stream classes
 207      (assert (null (sb-kernel:class-direct-superclasses
 208                     (find-class 'fundamental-stream))))
 209      (assert (equal (sb-pcl:class-direct-superclasses (sb-pcl:find-class
 210                                                        'fundamental-stream))
 211                     (mapcar #'sb-pcl:find-class '(standard-object stream))))
 212      (assert (null (set-difference
 213                     (sb-pcl:class-direct-subclasses (sb-pcl:find-class
 214                                                      'fundamental-stream))
 215                     (mapcar #'sb-pcl:find-class '(fundamental-binary-stream
 216                                                   fundamental-character-stream
 217                                                   fundamental-output-stream
 218                                                   fundamental-input-stream)))))
 219      (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
 220                                                    'fundamental-stream))
 221                     (mapcar #'sb-pcl:find-class '(fundamental-stream
 222                                                   standard-object
 223                                                   sb-pcl::std-object
 224                                                   sb-pcl::slot-object
 225                                                   stream
 226                                                   sb-kernel:instance
 227                                                   t))))
 228      (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class
 229                                                    'fundamental-stream))
 230                     (mapcar #'sb-pcl:find-class '(fundamental-stream
 231                                                   standard-object
 232                                                   sb-pcl::std-object
 233                                                   sb-pcl::slot-object stream
 234                                                   sb-kernel:instance t))))
 235      (assert (subtypep (find-class 'stream) (find-class t)))
 236      (assert (subtypep (find-class 'fundamental-stream) 'stream))
 237      (assert (not (subtypep 'stream 'fundamental-stream)))))
 238 ;;; Test under the interpreter.
 239 (eval *tests-of-inline-type-tests*)
 240 (format t "~&/done with interpreted *TESTS-OF-INLINE-TYPE-TESTS*~%")
 241 ;;; Test under the compiler.
 242 (defun tests-of-inline-type-tests ()
 243   #.*tests-of-inline-type-tests*)
 244 (tests-of-inline-type-tests)
 245 (format t "~&/done with compiled (TESTS-OF-INLINE-TYPE-TESTS)~%")
 246
 247 ;;; success
 248 (quit :unix-status 104)