subsetp.lsp 7.14 KB
Newer Older
1 2 3
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Wed Apr  1 22:10:54 1998
4
;;;; Contains: Tests of SUBSETP
5

6

7

8

9

10 11
(defvar cons-test-24-var '(78 "z" (8 9)))

12 13
(deftest subsetp.1
  (subsetp-with-check (copy-tree '(78)) cons-test-24-var)
14 15
  t)

16 17
(deftest subsetp.2
  (subsetp-with-check (copy-tree '((8 9))) cons-test-24-var)
18 19
  nil)

20 21
(deftest subsetp.3
  (subsetp-with-check (copy-tree '((8 9)))
sds's avatar
sds committed
22
                      cons-test-24-var :test 'equal)
23 24
  t)

25 26
(deftest subsetp.4
  (subsetp-with-check (list 78 (copy-seq "Z")) cons-test-24-var
sds's avatar
sds committed
27
                      :test #'equalp)
28 29
  t)

30 31
(deftest subsetp.5
  (subsetp-with-check (list 1) (list 0 2 3 4)
sds's avatar
sds committed
32
                      :key #'(lambda (i) (floor (/ i 2))))
33 34
  t)

35 36
(deftest subsetp.6
  (subsetp-with-check (list 1 6) (list 0 2 3 4)
sds's avatar
sds committed
37
                      :key #'(lambda (i) (floor (/ i 2))))
38 39
  nil)

40 41
(deftest subsetp.7
  (subsetp-with-check (list '(a . 10) '(b . 20) '(c . 30))
sds's avatar
sds committed
42 43 44
                      (list '(z . c) '(a . y) '(b . 100) '(e . f)
                            '(c . foo))
                      :key #'car)
45 46
  t)

47 48
(deftest subsetp.8
  (subsetp-with-check (copy-tree '((a . 10) (b . 20) (c . 30)))
sds's avatar
sds committed
49 50 51
                      (copy-tree '((z . c) (a . y) (b . 100) (e . f)
                                   (c . foo)))
                      :key 'car)
52 53
  t)

54 55
(deftest subsetp.9
  (subsetp-with-check (list 'a 'b 'c)
sds's avatar
sds committed
56 57 58 59 60
                      (copy-tree
                       (list '(z . c) '(a . y) '(b . 100) '(e . f)
                             '(c . foo)))
                      :test #'(lambda (e1 e2)
                                (eqt e1 (car e2))))
61 62
  t)

63
(deftest subsetp.10
64
  (subsetp-with-check (list 'a 'b 'c)
sds's avatar
sds committed
65 66 67 68 69 70
                      (copy-tree
                       (list '(z . c) '(a . y) '(b . 100) '(e . f)
                             '(c . foo)))
                      :test #'(lambda (e1 e2)
                                (eqt e1 (car e2)))
                      :key nil)
71 72
  t)

73 74
(deftest subsetp.11
  (subsetp-with-check (list 'a 'b 'c)
sds's avatar
sds committed
75 76 77 78 79
                      (copy-tree
                       (list '(z . c) '(a . y) '(b . 100) '(e . f)
                             '(c . foo)))
                      :test-not  #'(lambda (e1 e2)
                                     (not (eqt e1 (car e2)))))
80 81 82 83
  t)

;; Check that it maintains order of arguments

84 85 86 87 88 89
(deftest subsetp.12
  (block fail
    (subsetp-with-check
     (list 1 2 3)
     (list 4 5 6)
     :test #'(lambda (x y)
sds's avatar
sds committed
90 91
               (when (< y x) (return-from fail 'fail))
               t)))
92 93 94 95 96 97 98 99 100
  t)

(deftest subsetp.13
  (block fail
    (subsetp-with-check
     (list 1 2 3)
     (list 4 5 6)
     :key #'identity
     :test #'(lambda (x y)
sds's avatar
sds committed
101 102
               (when (< y x) (return-from fail 'fail))
               t)))
103 104 105 106 107 108 109 110
  t)

(deftest subsetp.14
  (block fail
    (subsetp-with-check
     (list 1 2 3)
     (list 4 5 6)
     :test-not #'(lambda (x y)
sds's avatar
sds committed
111 112
                   (when (< y x) (return-from fail 'fail))
                   nil)))
113 114 115 116 117 118 119 120 121
  t)

(deftest subsetp.15
  (block fail
    (subsetp-with-check
     (list 1 2 3)
     (list 4 5 6)
     :key #'identity
     :test-not #'(lambda (x y)
sds's avatar
sds committed
122 123
                   (when (< y x) (return-from fail 'fail))
                   nil)))
124 125
  t)

126 127 128 129 130 131
(defharmless subsetp.test-and-test-not.1
  (subsetp '(a b c) '(a g c e b) :test #'eql :test-not #'eql))

(defharmless subsetp.test-and-test-not.3
  (subsetp '(a b c) '(a g c e b) :test-not #'eql :test #'eql))

132 133
;;; Order of argument evaluation tests

134
(deftest subsetp.order.1
135 136 137
  (let ((i 0) x y)
    (values
     (notnot (subsetp (progn (setf x (incf i))
sds's avatar
sds committed
138 139 140
                             '(a b c))
                      (progn (setf y (incf i))
                             '(a b c d))))
141 142 143
     i x y))
  t 2 1 2)

144
(deftest subsetp.order.2
145 146 147
  (let ((i 0) x y z w)
    (values
     (notnot (subsetp (progn (setf x (incf i))
sds's avatar
sds committed
148 149 150 151 152
                             '(a b c))
                      (progn (setf y (incf i))
                             '(a b c d))
                      :test (progn (setf z (incf i)) #'eql)
                      :key  (progn (setf w (incf i)) nil)))
153 154 155
     i x y z w))
  t 4 1 2 3 4)

156
(deftest subsetp.order.3
157 158 159
  (let ((i 0) x y z w)
    (values
     (notnot (subsetp (progn (setf x (incf i))
sds's avatar
sds committed
160 161 162 163 164
                             '(a b c))
                      (progn (setf y (incf i))
                             '(a b c d))
                      :key  (progn (setf z (incf i)) nil)
                      :test (progn (setf w (incf i)) #'eql)))
165 166 167
     i x y z w))
  t 4 1 2 3 4)

168 169 170
;;; Keyword tests

(deftest subsetp.allow-other-keys.1
171
  (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) :bad t :allow-other-keys 67))
172 173
  t)

174
(deftest subsetp.allow-other-keys.2
175
  (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5)
sds's avatar
sds committed
176
                   :allow-other-keys #'cons :bad t))
177 178
  t)

179
(deftest subsetp.allow-other-keys.3
180
  (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4)
sds's avatar
sds committed
181 182 183
                   :allow-other-keys (make-hash-table)
                   :bad t
                   :test #'(lambda (x y) (= (1+ x) y))))
184 185
  nil)

186
(deftest subsetp.allow-other-keys.4
187
  (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) :allow-other-keys t))
188 189 190
  t)

(deftest subsetp.allow-other-keys.5
191
  (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) :allow-other-keys nil))
192 193 194
  t)

(deftest subsetp.allow-other-keys.6
195
  (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5)
sds's avatar
sds committed
196 197
                   :allow-other-keys t :bad1 t
                   :allow-other-keys nil :bad2 t))
198 199 200
  t)

(deftest subsetp.keywords.7
201
  (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4)
sds's avatar
sds committed
202 203
                   :test #'(lambda (x y) (= (1+ x) y))
                   :test #'eql))
204 205 206
  nil)

(deftest subsetp.keywords.8
207
  (notnot-mv (subsetp '(1 2 3 4 10) '(0 1 2 3 4)
sds's avatar
sds committed
208 209
                   :key nil
                   :key #'(lambda (x) (mod x 2))))
210 211 212 213 214
  nil)


;;; Error tests

215
(deftest subsetp.error.1
216 217
  (signals-error (subsetp) program-error)
  t)
218 219

(deftest subsetp.error.2
220 221
  (signals-error (subsetp nil) program-error)
  t)
222 223

(deftest subsetp.error.3
224 225
  (signals-error (subsetp nil nil :bad t) program-error)
  t)
226 227

(deftest subsetp.error.4
228 229
  (signals-error (subsetp nil nil :key) program-error)
  t)
230 231

(deftest subsetp.error.5
232 233
  (signals-error (subsetp nil nil 1 2) program-error)
  t)
234 235

(deftest subsetp.error.6
236 237
  (signals-error (subsetp nil nil :bad t :allow-other-keys nil) program-error)
  t)
238 239

(deftest subsetp.error.7
240 241
  (signals-error (subsetp (list 1 2) (list 3 4) :test #'identity) program-error)
  t)
242 243

(deftest subsetp.error.8
244 245
  (signals-error (subsetp (list 1 2) (list 3 4) :test-not #'identity) program-error)
  t)
246 247

(deftest subsetp.error.9
248 249
  (signals-error (subsetp (list 1 2) (list 3 4) :key #'cons) program-error)
  t)
250 251

(deftest subsetp.error.10
252 253
  (signals-error (subsetp (list 1 2) (list 3 4) :key #'car) type-error)
  t)
254 255

(deftest subsetp.error.11
256 257
  (signals-error (subsetp (list 1 2 3) (list* 4 5 6)) type-error)
  t)
258 259

(deftest subsetp.error.12
260 261
  (signals-error (subsetp (list* 1 2 3) (list 1 2 3 4 5 6)) type-error)
  t)
262

263 264 265 266
;;; The next two tests previously compared against NIL, but arguably
;;; a conforming implementation is not required to signal an error
;;; in these cases, since it doesn't have to traverse the other list.

267
(deftest subsetp.error.13
268
  (check-type-error #'(lambda (x) (subsetp x '(a b))) #'listp)
269 270 271
  nil)

(deftest subsetp.error.14
272
  (check-type-error #'(lambda (x) (subsetp '(a b) x)) #'listp)
273 274
  nil)