subtypep.lsp 5.13 KB
Newer Older
1 2 3 4 5 6 7
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Wed Jan 29 17:28:19 2003
;;;; Contains: Tests of SUBTYPEP

(in-package :cl-test)

8

9

10 11
;;; More subtypep tests are in types-and-class.lsp

12 13 14 15
(deftest subtypep.order.1
  (let ((i 0) x y)
    (values
     (notnot (subtypep (progn (setf x (incf i)) t)
sds's avatar
sds committed
16
                       (progn (setf y (incf i)) t)))
17 18 19
     i x y))
  t 2 1 2)

20 21 22
(deftest simple-base-string-is-sequence
    (subtypep* 'simple-base-string 'sequence)
  t t)
23

24 25
(deftest subtype.env.1
  (mapcar #'notnot
sds's avatar
sds committed
26
          (multiple-value-list (subtypep 'bit 'integer nil)))
27 28 29 30 31
  (t t))

(deftest subtype.env.2
  (macrolet
      ((%foo (&environment env)
sds's avatar
sds committed
32 33 34 35
             (list 'quote
                   (mapcar #'notnot
                           (multiple-value-list
                            (subtypep 'bit 'integer env))))))
36 37 38 39 40 41
    (%foo))
  (t t))

(deftest subtype.env.3
  (macrolet
      ((%foo (&environment env)
sds's avatar
sds committed
42 43 44
             (multiple-value-bind (sub good)
                 (subtypep nil (type-of env))
               (or (not good) (notnot sub)))))
45 46 47 48 49 50
    (%foo))
  t)

(deftest subtype.env.4
  (macrolet
      ((%foo (&environment env)
sds's avatar
sds committed
51 52 53
             (multiple-value-bind (sub good)
                 (subtypep (type-of env) (type-of env))
               (or (not good) (notnot sub)))))
54 55 56 57 58 59
    (%foo))
  t)

(deftest subtype.env.5
  (macrolet
      ((%foo (&environment env)
sds's avatar
sds committed
60 61 62
             (multiple-value-bind (sub good)
                 (subtypep (type-of env) t)
               (or (not good) (notnot sub)))))
63 64 65 66
    (%foo))
  t)

(deftest subtypep.error.1
67 68
  (signals-error (subtypep) program-error)
  t)
69 70

(deftest subtypep.error.2
71 72
  (signals-error (subtypep t) program-error)
  t)
73 74

(deftest subtypep.error.3
75 76
  (signals-error (subtypep t t nil nil) program-error)
  t)
77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115

;;; Special cases of types-6 that are/were causing problems in CMU CL

(deftest keyword-is-subtype-of-atom
  (subtypep* 'keyword 'atom)
  t t)

(deftest ratio-is-subtype-of-atom
  (subtypep* 'ratio 'atom)
  t t)

(deftest extended-char-is-subtype-of-atom
  (subtypep* 'extended-char 'atom)
  t t)

(deftest string-is-not-simple-vector
  (subtypep* 'string 'simple-vector)
  nil t)

(deftest base-string-is-not-simple-vector
  (subtypep* 'base-string 'simple-vector)
  nil t)

(deftest simple-string-is-not-simple-vector
  (subtypep* 'simple-string 'simple-vector)
  nil t)

(deftest simple-base-string-is-not-simple-vector
  (subtypep* 'simple-base-string 'simple-vector)
  nil t)

(deftest bit-vector-is-not-simple-vector
  (subtypep* 'bit-vector 'simple-vector)
  nil t)

(deftest simple-bit-vector-is-not-simple-vector
  (subtypep* 'simple-bit-vector 'simple-vector)
  nil t)

116 117
;;; Extended characters

pfdietz's avatar
pfdietz committed
118 119 120 121 122
(deftest subtypep.extended-char.1
  (if (subtypep* 'character 'base-char)
      (subtypep* 'extended-char nil)
    (values t t))
  t t)
123

124 125 126 127 128 129 130 131 132 133 134 135 136
(deftest subtypep.extended-char.2
  (if (subtypep* 'extended-char nil)
      (subtypep* 'character 'base-char)
    (values t t))
  t t)

(deftest subtypep.extended-char.3
  (check-equivalence 'extended-char '(and character (not base-char)))
  nil)


;;; Some and, or combinations

137 138
(deftest subtypep.and/or.1
  (check-equivalence
pfdietz's avatar
pfdietz committed
139
   '(and (or symbol (integer 0 15))
sds's avatar
sds committed
140
         (or symbol (integer 10 25)))
141 142 143 144 145 146
   '(or symbol (integer 10 15)))
  nil)

(deftest subtypep.and/or.2
  (check-equivalence
   '(and (or (not symbol) (integer 0 10))
sds's avatar
sds committed
147
         (or symbol (integer 11 25)))
148 149
   '(integer 11 25))
  nil)
150 151

(deftest subtypep.and.1
152
  (loop for type in *types-list3*
sds's avatar
sds committed
153
        append (check-equivalence `(and ,type ,type) type))
154 155 156
  nil)

(deftest subtypep.or.1
157
  (loop for type in *types-list3*
sds's avatar
sds committed
158
        append (check-equivalence `(or ,type ,type) type))
159
  nil)
160 161 162 163 164 165 166 167

(deftest subtypep.and.2
  (check-equivalence t '(and))
  nil)

(deftest subtypep.or.2
  (check-equivalence nil '(or))
  nil)
168 169 170

(deftest subtypep.and.3
  (loop for type in *types-list3*
sds's avatar
sds committed
171
        append (check-equivalence `(and ,type) type))
172 173 174 175
  nil)

(deftest subtypep.or.3
  (loop for type in *types-list3*
sds's avatar
sds committed
176
        append (check-equivalence `(or ,type) type))
177 178 179 180
  nil)

(deftest subtypep.and.4
  (let* ((n (length *types-list3*))
sds's avatar
sds committed
181
         (a (make-array n :initial-contents *types-list3*)))
182 183
    (trim-list
     (loop for i below 1000
sds's avatar
sds committed
184 185 186 187
           for tp1 = (aref a (random n))
           for tp2 = (aref a (random n))
           append (check-equivalence `(and ,tp1 ,tp2)
                                     `(and ,tp2 ,tp1)))
188 189 190 191 192
     100))
  nil)

(deftest subtypep.or.4
  (let* ((n (length *types-list3*))
sds's avatar
sds committed
193
         (a (make-array n :initial-contents *types-list3*)))
194 195
    (trim-list
     (loop for i below 1000
sds's avatar
sds committed
196 197 198 199
           for tp1 = (aref a (random n))
           for tp2 = (aref a (random n))
           append (check-equivalence `(or ,tp1 ,tp2)
                                     `(or ,tp2 ,tp1)))
200 201 202
     100))
  nil)

203 204 205 206 207
;;; Check that types that are supposed to be nonempty are
;;; not subtypes of NIL

(deftest subtypep.nil.1
  (loop for (type) in *subtype-table*
sds's avatar
sds committed
208 209
        unless (member type '(nil extended-char))
        append (check-all-not-subtypep type nil))
210 211
  nil)

pfdietz's avatar
pfdietz committed
212 213
(deftest subtypep.nil.2
  (loop for (type) in *subtype-table*
sds's avatar
sds committed
214 215 216
        for class = (find-class type nil)
        unless (or (not class) (member type '(nil extended-char)))
        append (check-all-not-subtypep class nil))
pfdietz's avatar
pfdietz committed
217
  nil)