getf.lsp 4.59 KB
Newer Older
1 2
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
3 4
;;;; Created:  Sun Apr 20 07:37:41 2003
;;;; Contains: Tests of GETF
5 6

(in-package :cl-test)
7

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

10 11
(deftest getf.1
  (getf nil 'a)
12 13
  nil)

14 15
(deftest getf.2
  (getf nil 'a 'b)
16 17
  b)

18 19
(deftest getf.3
  (getf '(a b) 'a)
20 21
  b)

22 23
(deftest getf.4
  (getf '(a b) 'a 'c)
24 25
  b)

26 27 28 29 30
(deftest getf.5
  (let ((x 0))
    (values
     (getf '(a b) 'a (incf x))
     x))
31 32
  b 1)

33
(deftest getf.order.1
34 35 36
  (let ((i 0) x y)
    (values
     (getf (progn (setf x (incf i)) '(a b))
sds's avatar
sds committed
37
           (progn (setf y (incf i)) 'a))
38 39
     i x y))
  b 2 1 2)
sds's avatar
sds committed
40

41
(deftest getf.order.2
42 43 44
  (let ((i 0) x y z)
    (values
     (getf (progn (setf x (incf i)) '(a b))
sds's avatar
sds committed
45 46
           (progn (setf y (incf i)) 'a)
           (setf z (incf i)))
47
     i x y z))
48
  b 3 1 2 3)
49 50 51 52 53 54 55 56 57 58 59 60 61 62 63

(deftest setf-getf.1
  (let ((p (copy-list '(a 1 b 2))))
    (setf (getf p 'c) 3)
    ;; Must check that only a, b, c have properties
    (and
     (eqlt (getf p 'a) 1)
     (eqlt (getf p 'b) 2)
     (eqlt (getf p 'c) 3)
     (eqlt
      (loop
       for ptr on p by #'cddr count
       (not (member (car ptr) '(a b c))))
      0)
     t))
64 65
  t)

66 67 68 69 70 71 72 73 74 75 76 77 78
(deftest setf-getf.2
  (let ((p (copy-list '(a 1 b 2))))
    (setf (getf p 'a) 3)
    ;; Must check that only a, b have properties
    (and
     (eqlt (getf p 'a) 3)
     (eqlt (getf p 'b) 2)
     (eqlt
      (loop
       for ptr on p by #'cddr count
       (not (member (car ptr) '(a b))))
      0)
     t))
sds's avatar
sds committed
79
  t)
80 81 82 83 84 85 86 87 88 89 90 91 92 93 94

(deftest setf-getf.3
  (let ((p (copy-list '(a 1 b 2))))
    (setf (getf p 'c 17) 3)
    ;; Must check that only a, b, c have properties
    (and
     (eqlt (getf p 'a) 1)
     (eqlt (getf p 'b) 2)
     (eqlt (getf p 'c) 3)
     (eqlt
      (loop
       for ptr on p by #'cddr count
       (not (member (car ptr) '(a b c))))
      0)
     t))
95 96
  t)

97 98 99 100 101 102 103 104 105 106 107 108 109
(deftest setf-getf.4
  (let ((p (copy-list '(a 1 b 2))))
    (setf (getf p 'a 17) 3)
    ;; Must check that only a, b have properties
    (and
     (eqlt (getf p 'a) 3)
     (eqlt (getf p 'b) 2)
     (eqlt
      (loop
       for ptr on p by #'cddr count
       (not (member (car ptr) '(a b))))
      0)
     t))
110 111
  t)

112 113
(deftest setf-getf.5
  (let ((p (copy-list '(a 1 b 2)))
sds's avatar
sds committed
114
        (foo nil))
115 116 117 118 119 120 121 122 123 124 125
    (setf (getf p 'a (progn (setf foo t) 0)) 3)
    ;; Must check that only a, b have properties
    (and
     (eqlt (getf p 'a) 3)
     (eqlt (getf p 'b) 2)
     (eqlt
      (loop
       for ptr on p by #'cddr count
       (not (member (car ptr) '(a b))))
      0)
     foo))
126 127
  t)

128
(deftest setf-getf.order.1
129
  (let ((p (list (copy-list '(a 1 b 2))))
130
        (cnt1 0) (cnt2 0) (cnt3 0))
131
    (setf (getf (car (progn (incf cnt1) p)) 'c (incf cnt3))
132
          (progn (incf cnt2) 3))
133
    ;; Must check that only a, b, c have properties
134 135 136 137 138 139 140 141 142 143 144 145 146
    (values
     cnt1 ; (eqlt cnt1 1)
     cnt2 ; (eqlt cnt2 1)
     cnt3 ; (eqlt cnt3 1)
     (getf (car p) 'a)
     (getf (car p) 'b)
     (getf (car p) 'c)
     (loop
        for ptr on (car p) by #'cddr count
          (not (member (car ptr) '(a b c))))))
  1 1 1
  1 2 3
  0)
147

148
(deftest setf-getf.order.2
149
  (let ((p (list (copy-list '(a 1 b 2))))
sds's avatar
sds committed
150
        (i 0) x y z w)
151
    (setf (getf (car (progn (setf x (incf i)) p))
sds's avatar
sds committed
152 153 154
                (progn (setf y (incf i)) 'c)
                (setf z (incf i)))
          (progn (setf w (incf i)) 3))
155
    ;; Must check that only a, b, c have properties
156 157 158 159 160 161
    (values
     i x y z w
     (getf (car p) 'a)
     (getf (car p) 'b)
     (getf (car p) 'c)
     (loop for ptr on (car p) by #'cddr count
sds's avatar
sds committed
162
          (not (member (car ptr) '(a b c))))))
163
  4 1 2 3 4 1 2 3 0)
164

165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188
(deftest incf-getf.1
  (let ((p (copy-list '(a 1 b 2))))
    (incf (getf p 'b))
    ;; Must check that only a, b have properties
    (and
     (eqlt (getf p 'a) 1)
     (eqlt (getf p 'b) 3)
     (eqlt
      (loop
       for ptr on p by #'cddr count
       (not (member (car ptr) '(a b))))
      0)
     t))
  t)

(deftest incf-getf.2
  (let ((p (copy-list '(a 1 b 2))))
    (incf (getf p 'c 19))
    ;; Must check that only a, b have properties
    (and
     (eqlt (getf p 'a) 1)
     (eqlt (getf p 'b) 2)
     (eqlt (getf p 'c) 20)
     (eqlt
sds's avatar
sds committed
189 190 191 192
        (loop
         for ptr on p by #'cddr count
         (not (member (car ptr) '(a b c))))
        0)
193
     t))
194 195
  t)

196 197 198 199 200
(deftest push-getf.1
  (let ((p nil))
    (values
     (push 'x (getf p 'a))
     p))
201 202
  (x) (a (x)))

203 204
;;; Error tests

205
(deftest getf.error.1
206 207
  (signals-error (getf) program-error)
  t)
208 209

(deftest getf.error.2
210 211
  (signals-error (getf nil) program-error)
  t)
212 213

(deftest getf.error.3
214 215
  (signals-error (getf nil nil nil nil) program-error)
  t)
216

217
(deftest getf.error.4
218 219
  (signals-error (getf '(a . b) 'c) type-error)
  t)
220 221

(deftest getf.error.5
222 223
  (signals-error (getf '(a 10 . b) 'c) type-error)
  t)