assoc-if-not.lsp 4.77 KB
Newer Older
1 2 3 4 5
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sun Apr 20 07:28:37 2003
;;;; Contains: Tests of ASSOC-IF-NOT

6

7

8

9

10 11
(deftest assoc-if-not.1
    (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d))))
sds's avatar
sds committed
12 13
           (xcopy (make-scaffold-copy x))
           (result (assoc-if-not #'oddp x)))
14 15 16 17 18 19 20 21
      (and
       (check-scaffold-copy x xcopy)
       (eqt result (third x))
       result))
  (6 . c))

(deftest assoc-if-not.2
  (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d))))
sds's avatar
sds committed
22 23
         (xcopy (make-scaffold-copy x))
         (result (assoc-if-not #'evenp x :key #'1+)))
24 25 26 27 28 29 30
    (and
     (check-scaffold-copy x xcopy)
     (eqt result (third x))
     result))
  (6 . c))

(deftest assoc-if-not.3
31
  (let* ((x (copy-list '((1 . a) nil (3 . b) (6 . c) (7 . d))))
sds's avatar
sds committed
32 33
         (xcopy (make-scaffold-copy x))
         (result (assoc-if-not #'oddp x)))
34 35 36 37
    (and
     (check-scaffold-copy x xcopy)
     (eqt result (fourth x))
     result))
38 39 40
  (6 . c))

(deftest assoc-if-not.4
41
  (assoc-if-not #'identity '((a . b) nil (c . d) (nil . e) (f . g)))
42 43 44 45 46 47 48 49
  (nil . e))

;;; Order of argument evaluation tests

(deftest assoc-if-not.order.1
  (let ((i 0) x y)
    (values
     (assoc-if-not (progn (setf x (incf i)) #'identity)
sds's avatar
sds committed
50 51
                   (progn (setf y (incf i))
                          '((a . 1) (b . 2) (nil . 17) (d . 4))))
52 53 54 55 56 57 58
     i x y))
  (nil . 17) 2 1 2)

(deftest assoc-if-not.order.2
  (let ((i 0) x y z)
    (values
     (assoc-if-not (progn (setf x (incf i)) #'identity)
sds's avatar
sds committed
59 60 61
                   (progn (setf y (incf i))
                          '((a . 1) (b . 2) (nil . 17) (d . 4)))
                   :key (progn (setf z (incf i)) #'null))
62 63 64 65 66 67 68
     i x y z))
  (a . 1) 3 1 2 3)

;;; Keyword tests

(deftest assoc-if-not.allow-other-keys.1
  (assoc-if-not #'identity
sds's avatar
sds committed
69
                '((a . 1) (nil . 2) (c . 3)) :bad t :allow-other-keys t)
70 71 72 73
  (nil . 2))

(deftest assoc-if-not.allow-other-keys.2
  (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3))
sds's avatar
sds committed
74
            :allow-other-keys t :also-bad t)
75 76 77 78
  (nil . 2))

(deftest assoc-if-not.allow-other-keys.3
  (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3))
sds's avatar
sds committed
79
            :allow-other-keys t :also-bad t :key #'not)
80 81 82 83 84 85 86 87 88 89 90 91
  (a . 1))

(deftest assoc-if-not.allow-other-keys.4
  (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :allow-other-keys t)
  (nil . 2))

(deftest assoc-if-not.allow-other-keys.5
  (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :allow-other-keys nil)
  (nil . 2))

(deftest assoc-if-not.keywords.6
  (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3))
sds's avatar
sds committed
92
                :key #'identity :key #'null)
93 94 95 96 97 98
  (nil . 2))

(deftest assoc-if-not.keywords.7
  (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :key nil :key #'null)
  (nil . 2))

99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119
;;; Macro env tests

(deftest assoc-if-not.env.1
  (macrolet
   ((%m (z) z))
   (let ((alist '((1 . a) (3 . b) (4 . c) (6 . d))))
     (values
      (assoc-if-not (expand-in-current-env (%m 'oddp)) alist)
      (assoc-if-not (expand-in-current-env (%m #'oddp)) alist)
      (assoc-if-not 'oddp (expand-in-current-env (%m alist))))))
  (4 . c)
  (4 . c)
  (4 . c))

(deftest assoc-if-not.env.2
  (macrolet
   ((%m (z) z))
   (let ((alist '((1 . a) (3 . b) (4 . c) (6 . d))))
     (values
      (assoc-if-not 'evenp alist (expand-in-current-env (%m :key)) #'1+)
      (assoc-if-not #'evenp alist :key (expand-in-current-env (%m '1+)))
pfdietz's avatar
pfdietz committed
120 121
      )))
  (4 . c)
pfdietz's avatar
pfdietz committed
122
  (4 . c))
sds's avatar
sds committed
123

124 125 126
;;; Error tests

(deftest assoc-if-not.error.1
127 128
  (signals-error (assoc-if-not) program-error)
  t)
129 130

(deftest assoc-if-not.error.2
131 132
  (signals-error (assoc-if-not #'null) program-error)
  t)
133 134

(deftest assoc-if-not.error.3
135
  (signals-error (assoc-if-not #'null nil :bad t)
sds's avatar
sds committed
136
                 program-error)
137
  t)
138 139

(deftest assoc-if-not.error.4
140
  (signals-error (assoc-if-not #'null nil :key)
sds's avatar
sds committed
141
                 program-error)
142
  t)
143 144

(deftest assoc-if-not.error.5
145
  (signals-error (assoc-if-not #'null nil 1 1)
sds's avatar
sds committed
146
                 program-error)
147
  t)
148 149

(deftest assoc-if-not.error.6
150
  (signals-error (assoc-if-not #'null nil :bad t :allow-other-keys nil)
sds's avatar
sds committed
151
                 program-error)
152
  t)
153 154

(deftest assoc-if-not.error.7
155
  (signals-error (assoc-if-not #'cons '((a b)(c d)))
sds's avatar
sds committed
156
                 program-error)
157
  t)
158 159

(deftest assoc-if-not.error.8
160
  (signals-error (assoc-if-not #'identity '((a b)(c d)) :key #'cons)
sds's avatar
sds committed
161
                 program-error)
162
  t)
163 164

(deftest assoc-if-not.error.9
165
  (signals-type-error x 'a (assoc-if-not #'car '((a b)(c d))))
166
  t)
167 168

(deftest assoc-if-not.error.10
169
  (signals-type-error x 'a (assoc-if-not #'identity '((a b)(c d)) :key #'car))
170
  t)
171 172

(deftest assoc-if-not.error.11
173
  (signals-error (assoc-if-not #'identity '((a . b) . c))
sds's avatar
sds committed
174
                 type-error)
175
  t)
176

177
(deftest assoc-if-not.error.12
178
  (signals-error (assoc-if-not #'identity '((a . b) :bad (c . d)))
sds's avatar
sds committed
179
                 type-error)
180
  t)
181 182

(deftest assoc-if-not.error.13
183
  (signals-type-error x 'y (assoc-if-not #'identity x))
184
  t)