assoc.lsp 6.97 KB
Newer Older
1 2 3 4 5 6 7
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sun Apr 20 07:27:20 2003
;;;; Contains: Tests of ASSOC

(in-package :cl-test)

8 9
(compile-and-load "cons-aux.lsp")

10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35
(deftest assoc.1
    (assoc nil nil)
  nil)

(deftest assoc.2
    (assoc nil '(nil))
  nil)

(deftest assoc.3
    (assoc nil '(nil (nil . 2) (a . b)))
  (nil . 2))

(deftest assoc.4
    (assoc nil '((a . b) (c . d)))
  nil)

(deftest assoc.5
    (assoc 'a '((a . b)))
  (a . b))

(deftest assoc.6
    (assoc 'a '((:a . b) (#:a . c) (a . d) (a . e) (z . f)))
  (a . d))

(deftest assoc.7
    (let* ((x (copy-tree '((a . b) (b . c) (c . d))))
sds's avatar
sds committed
36 37
           (xcopy (make-scaffold-copy x))
           (result (assoc 'b x)))
38 39 40 41 42 43 44 45 46 47 48
      (and
       (eqt result (second x))
       (check-scaffold-copy x xcopy)))
  t)

(deftest assoc.8
    (assoc 1 '((0 . a) (1 . b) (2 . c)))
  (1 . b))

(deftest assoc.9
    (assoc (copy-seq "abc")
sds's avatar
sds committed
49
           '((abc . 1) ("abc" . 2) ("abc" . 3)))
50 51 52 53 54 55 56 57 58 59 60 61 62 63
  nil)

(deftest assoc.10
    (assoc (copy-list '(a)) (copy-tree '(((a) b) ((a) (c)))))
  nil)

(deftest assoc.11
    (let ((x (list 'a 'b)))
      (assoc x `(((a b) c) (,x . d) (,x . e) ((a b) 1))))
  ((a b) . d))


(deftest assoc.12
    (assoc #\e '(("abefd" . 1) ("aevgd" . 2) ("edada" . 3))
sds's avatar
sds committed
64
           :key #'(lambda (x) (schar x 1)))
65 66 67 68
  ("aevgd" . 2))

(deftest assoc.13
    (assoc nil '(((a) . b) ( nil . c ) ((nil) . d))
sds's avatar
sds committed
69
           :key #'car)
70 71 72 73
  (nil . c))

(deftest assoc.14
    (assoc (copy-seq "abc")
sds's avatar
sds committed
74 75
           '((abc . 1) ("abc" . 2) ("abc" . 3))
           :test #'equal)
76 77 78 79
  ("abc" . 2))

(deftest assoc.15
    (assoc (copy-seq "abc")
sds's avatar
sds committed
80 81
           '((abc . 1) ("abc" . 2) ("abc" . 3))
           :test #'equalp)
82 83 84 85
  ("abc" . 2))

(deftest assoc.16
    (assoc (copy-list '(a)) (copy-tree '(((a) b) ((a) (c))))
sds's avatar
sds committed
86
           :test #'equal)
87 88 89 90
  ((a) b))

(deftest assoc.17
    (assoc (copy-seq "abc")
sds's avatar
sds committed
91 92
           '((abc . 1) (a . a) (b . b) ("abc" . 2) ("abc" . 3))
           :test-not (complement #'equalp))
93 94 95 96 97
  ("abc" . 2))

(deftest assoc.18
    (assoc 'a '((a . d)(b . c)) :test-not #'eq)
  (b . c))
sds's avatar
sds committed
98

99 100 101 102 103 104
(deftest assoc.19
    (assoc 'a '((a . d)(b . c)) :test (complement #'eq))
  (b . c))

(deftest assoc.20
    (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5))
sds's avatar
sds committed
105 106
           :key #'(lambda (x) (and (stringp x) (string-downcase x)))
           :test #'equal)
107 108 109 110
  ("A" . 6))

(deftest assoc.21
    (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5))
sds's avatar
sds committed
111 112
           :key #'(lambda (x) (and (stringp x) x))
           :test #'equal)
113 114 115 116
  ("a" . 3))

(deftest assoc.22
    (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5))
sds's avatar
sds committed
117 118
           :key #'(lambda (x) (and (stringp x) (string-downcase x)))
           :test-not (complement #'equal))
119 120 121 122
  ("A" . 6))

(deftest assoc.23
    (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5))
sds's avatar
sds committed
123 124
           :key #'(lambda (x) (and (stringp x) x))
           :test-not (complement #'equal))
125 126 127 128 129 130 131
  ("a" . 3))

;; Check that it works when test returns a true value
;; other than T

(deftest assoc.24
    (assoc 'a '((b . 1) (a . 2) (c . 3))
sds's avatar
sds committed
132
           :test #'(lambda (x y) (and (eqt x y) 'matched)))
133 134 135 136 137 138 139
  (a . 2))

;; Check that the order of the arguments to test is correct

(deftest assoc.25
    (block fail
      (assoc 'a '((b . 1) (c . 2) (a . 3))
sds's avatar
sds committed
140 141 142
             :test #'(lambda (x y)
                       (unless (eqt x 'a) (return-from fail 'fail))
                       (eqt x y))))
143 144
  (a . 3))

145 146 147 148 149 150 151 152 153 154
;;; Order of test arguments

(deftest assoc.26
  (assoc 10 '((1 a) (5 b) (8 c) (11 d) (12 e)) :test #'<)
  (11 d))

(deftest assoc.27
  (assoc 10 '((1 a) (5 b) (8 c) (11 d) (12 e)) :test-not #'>=)
  (11 d))

pfdietz's avatar
pfdietz committed
155
;;; Special cases: the nil key does not match the nil pair
156 157 158 159 160 161 162

(deftest assoc.30
  (let () (assoc nil '((a . b) nil (c . d) (nil . e) (nil . f) nil (g . h))))
  (nil . e))

(deftest assoc.31
  (let () (assoc nil '((a . b) nil (c . d) (nil . e) (nil . f) nil (g . h))
sds's avatar
sds committed
163
                 :test #'eq))
164 165
  (nil . e))

166 167 168 169 170 171 172 173
;;; :test & :test-not together are harmless

(defharmless assoc.test-and-test-not.1
  (assoc 'a '((a . 1) (b . 2)) :test #'eql :test-not #'eql))

(defharmless assoc.test-and-test-not.2
  (assoc 'a '((a . 1) (b . 2)) :test-not #'eql :test #'eql))

174 175 176 177 178 179
;;; Order of argument evaluation

(deftest assoc.order.1
  (let ((i 0) x y)
    (values
     (assoc (progn (setf x (incf i)) 'c)
sds's avatar
sds committed
180
            (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4))))
181 182 183 184 185 186 187
     i x y))
  (c . 3) 2 1 2)

(deftest assoc.order.2
  (let ((i 0) x y z)
    (values
     (assoc (progn (setf x (incf i)) 'c)
sds's avatar
sds committed
188 189
            (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4)))
            :test (progn (setf z (incf i)) #'eq))
190 191 192 193 194 195 196
     i x y z))
  (c . 3) 3 1 2 3)

(deftest assoc.order.3
  (let ((i 0) x y)
    (values
     (assoc (progn (setf x (incf i)) 'c)
sds's avatar
sds committed
197 198
            (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4)))
            :test #'eq)
199 200 201 202 203 204 205
     i x y))
  (c . 3) 2 1 2)

(deftest assoc.order.4
  (let ((i 0) x y z w)
    (values
     (assoc (progn (setf x (incf i)) 'c)
sds's avatar
sds committed
206 207 208
            (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4)))
            :key (progn (setf z (incf i)) #'identity)
            :key (progn (setf w (incf i)) #'not))
209 210 211 212 213 214 215 216 217 218 219 220 221 222 223
     i x y z w))
  (c . 3) 4 1 2 3 4)

;;; Keyword tests

(deftest assoc.allow-other-keys.1
  (assoc 'b '((a . 1) (b . 2) (c . 3)) :bad t :allow-other-keys t)
  (b . 2))

(deftest assoc.allow-other-keys.2
  (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys t :also-bad t)
  (b . 2))

(deftest assoc.allow-other-keys.3
  (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys t :also-bad t
sds's avatar
sds committed
224
         :test-not #'eql)
225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244
  (a . 1))

(deftest assoc.allow-other-keys.4
  (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys t)
  (b . 2))

(deftest assoc.allow-other-keys.5
  (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys nil)
  (b . 2))

(deftest assoc.keywords.6
  (assoc 'b '((a . 1) (b . 2) (c . 3)) :key #'identity :key #'null)
  (b . 2))

(deftest assoc.keywords.7
  (assoc 'b '((a . 1) (b . 2) (c . 3)) :key nil :key #'null)
  (b . 2))


(deftest assoc.error.1
245 246
  (signals-error (assoc) program-error)
  t)
247 248

(deftest assoc.error.2
249 250
  (signals-error (assoc nil) program-error)
  t)
251 252

(deftest assoc.error.3
253 254
  (signals-error (assoc nil nil :bad t) program-error)
  t)
255 256

(deftest assoc.error.4
257 258
  (signals-error (assoc nil nil :key) program-error)
  t)
259 260

(deftest assoc.error.5
261 262
  (signals-error (assoc nil nil 1 1) program-error)
  t)
263 264

(deftest assoc.error.6
265
  (signals-error (assoc nil nil :bad t :allow-other-keys nil)
sds's avatar
sds committed
266
                 program-error)
267
  t)
268 269

(deftest assoc.error.7
270
  (signals-error (assoc 'a '((a . b)) :test #'identity)
sds's avatar
sds committed
271
                 program-error)
272
  t)
273 274

(deftest assoc.error.8
275
  (signals-error (assoc 'a '((a . b)) :test-not #'identity)
sds's avatar
sds committed
276
                 program-error)
277
  t)
278 279

(deftest assoc.error.9
280
  (signals-error (assoc 'a '((a . b)) :key #'cons)
sds's avatar
sds committed
281
                 program-error)
282
  t)
283 284

(deftest assoc.error.10
285
  (signals-error (assoc 'z '((a . b) . c))
sds's avatar
sds committed
286
                 type-error)
287
  t)
288

289
(deftest assoc.error.11
290
  (signals-error (assoc 'z '((a . b) :bad (c . d)))
sds's avatar
sds committed
291
                 type-error)
292
  t)
293 294

(deftest assoc.error.12
295
  (signals-type-error x 'y (assoc 'x x))
296 297
  t)