nsublis.lsp 5.06 KB
Newer Older
1 2 3 4 5 6 7
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat Apr 19 21:35:33 2003
;;;; Contains: Tests of NSUBLIS

(in-package :cl-test)

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

10 11
(deftest nsublis.1
  (check-nsublis '((a b) g (d e 10 g h) 15 . g)
sds's avatar
sds committed
12
                 '((e . e2) (g . 17)))
13 14 15 16
  ((a b) 17 (d e2 10 17 h) 15 . 17))

(deftest nsublis.2
  (check-nsublis '(f6 10 (f4 (f3 (f1 a b) (f1 a p)) (f2 a b)))
sds's avatar
sds committed
17 18
                 '(((f1 a b) . (f2 a b)) ((f2 a b) . (f1 a b)))
                 :test #'equal)
19 20 21 22
  (f6 10 (f4 (f3 (f2 a b) (f1 a p)) (f1 a b))))

(deftest nsublis.3
  (check-nsublis '(10 ((10 20 (a b c) 30)) (((10 20 30 40))))
sds's avatar
sds committed
23
                 '((30 . "foo")))
24 25 26 27 28
  (10 ((10 20 (a b c) "foo")) (((10 20 "foo" 40)))))

(deftest nsublis.4
  (check-nsublis
   (nsublis (copy-tree '((a . 2) (b . 4) (c . 1)))
sds's avatar
sds committed
29
            (copy-tree '(a b c d e (a b c a d b) f)))
30 31
   '((t . "yes"))
   :key #'(lambda (x) (and (typep x 'integer)
sds's avatar
sds committed
32
                           (evenp x))))
33 34 35 36
  ("yes" "yes" 1 d e ("yes" "yes" 1 "yes" d "yes") f))

(deftest nsublis.5
  (check-nsublis '("fee" (("fee" "Fie" "foo"))
sds's avatar
sds committed
37 38
                   fie ("fee" "fie"))
                 `((,(copy-seq "fie") . #\f)))
39 40 41 42
  ("fee" (("fee" "Fie" "foo")) fie ("fee" "fie")))

(deftest nsublis.6
  (check-nsublis '("fee" fie (("fee" "Fie" "foo") 1)
sds's avatar
sds committed
43 44 45
                   ("fee" "fie"))
                 `((,(copy-seq "fie") . #\f))
                 :test 'equal)
46 47 48 49
  ("fee" fie (("fee" "Fie" "foo") 1) ("fee" #\f)))

(deftest nsublis.7
  (check-nsublis '(("aa" a b)
sds's avatar
sds committed
50 51 52 53 54 55 56
                   (z "bb" d)
                   ((x . "aa")))
                 `((,(copy-seq "aa") . 1)
                   (,(copy-seq "bb") . 2))
                 :test 'equal
                 :key #'(lambda (x) (if (consp x) (car x)
                                      '*not-present*)))
57 58 59 60 61 62 63 64 65
  (1 (z . 2) ((x . "aa"))))

(deftest nsublis.8
  (nsublis nil 'a :bad-keyword t :allow-other-keys t)
  a)

;; Check that a null key arg is ignored.

(deftest nsublis.9
sds's avatar
sds committed
66
  (check-nsublis
67 68 69 70 71
   '(1 2 a b)
   '((1 . 2) (a . b))
   :key nil)
  (2 2 b b))

72 73
(deftest nsublis.10
  (check-nsublis  (list 0 3 8 20)
sds's avatar
sds committed
74 75
                  '((1 . x) (5 . y) (10 . z))
                  :test #'(lambda (x y) (and (realp x) (realp y) (< x y))))
76 77 78 79
  (x y z 20))

(deftest nsublis.11
  (check-nsublis  (list 0 3 8 20)
sds's avatar
sds committed
80 81 82
                  '((1 . x) (5 . y) (10 . z))
                  :test-not
                  #'(lambda (x y) (not (and (realp x) (realp y) (< x y)))))
83 84
  (x y z 20))

85 86
(defharmless nsublis.test-and-test-not.1
  (nsublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd)
sds's avatar
sds committed
87
           :test #'eql :test-not #'eql))
88 89 90

(defharmless nsublis.test-and-test-not.2
  (nsublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd)
sds's avatar
sds committed
91
           :test-not #'eql :test #'eql))
92

93 94 95 96 97 98
;;; Order of argument evaluation
(deftest nsublis.order.1
  (let ((i 0) w x y z)
    (values
     (nsublis
      (progn (setf w (incf i))
sds's avatar
sds committed
99
             '((a . z)))
100
      (progn (setf x (incf i))
sds's avatar
sds committed
101
             (copy-tree '(a b c d)))
102 103 104 105 106 107 108 109 110 111 112
      :test (progn (setf y (incf i)) #'eql)
      :key (progn (setf z (incf i)) #'identity))
     i w x y z))
  (z b c d)
  4 1 2 3 4)

(deftest nsublis.order.2
  (let ((i 0) w x y z)
    (values
     (nsublis
      (progn (setf w (incf i))
sds's avatar
sds committed
113
             '((a . z)))
114
      (progn (setf x (incf i))
sds's avatar
sds committed
115
             (copy-tree '(a b c d)))
116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146
      :key (progn (setf y (incf i)) #'identity)
      :test-not (progn (setf z (incf i)) (complement #'eql))
      )
     i w x y z))
  (z b c d)
  4 1 2 3 4)

;;; Keyword tests

(deftest nsublis.allow-other-keys.1
  (nsublis nil 'a :bad t :allow-other-keys t)
  a)

(deftest nsublis.allow-other-keys.2
  (nsublis nil 'a :allow-other-keys t :bad t)
  a)

(deftest nsublis.allow-other-keys.3
  (nsublis nil 'a :allow-other-keys t)
  a)

(deftest nsublis.allow-other-keys.4
  (nsublis nil 'a :allow-other-keys nil)
  a)

(deftest nsublis.allow-other-keys.5
  (nsublis nil 'a :allow-other-keys t :allow-other-keys t :bad t)
  a)

(deftest nsublis.keywords.6
  (nsublis '((1 . a)) (list 0 1 2)
sds's avatar
sds committed
147 148
           :key #'(lambda (x) (if (numberp x) (1+ x) x))
           :key #'identity)
149 150 151 152 153
  (a 1 2))

;; Argument error cases

(deftest nsublis.error.1
154 155
  (signals-error (nsublis) program-error)
  t)
156 157

(deftest nsublis.error.2
158 159
  (signals-error (nsublis nil) program-error)
  t)
160 161

(deftest nsublis.error.3
162 163
  (signals-error (nsublis nil 'a :test) program-error)
  t)
164 165

(deftest nsublis.error.4
166 167
  (signals-error (nsublis nil 'a :bad-keyword t) program-error)
  t)
168 169

(deftest nsublis.error.5
170
  (signals-error (nsublis '((a . 1) (b . 2))
sds's avatar
sds committed
171 172 173
                           (list 'a 'b 'c 'd)
                           :test #'identity)
                 program-error)
174
  t)
175 176

(deftest nsublis.error.6
177
  (signals-error (nsublis '((a . 1) (b . 2))
sds's avatar
sds committed
178 179 180
                           (list 'a 'b 'c 'd)
                           :key #'cons)
                 program-error)
181
  t)
182 183

(deftest nsublis.error.7
184
  (signals-error (nsublis '((a . 1) (b . 2))
sds's avatar
sds committed
185 186 187
                           (list 'a 'b 'c 'd)
                           :test-not #'identity)
                 program-error)
188
  t)
189 190

(deftest nsublis.error.8
191
  (signals-error (nsublis '((a . 1) . bad)
sds's avatar
sds committed
192 193
                           (list 'a 'b 'c 'd))
                 type-error)
194
  t)