source: trunk/source/tests/ansi-tests/getf.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 4.5 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sun Apr 20 07:37:41 2003
4;;;; Contains: Tests of GETF
5
6(in-package :cl-test)
7
8(compile-and-load "cons-aux.lsp")
9
10(deftest getf.1
11  (getf nil 'a)
12  nil)
13
14(deftest getf.2
15  (getf nil 'a 'b)
16  b)
17
18(deftest getf.3
19  (getf '(a b) 'a)
20  b)
21
22(deftest getf.4
23  (getf '(a b) 'a 'c)
24  b)
25
26(deftest getf.5
27  (let ((x 0))
28    (values
29     (getf '(a b) 'a (incf x))
30     x))
31  b 1)
32
33(deftest getf.order.1
34  (let ((i 0) x y)
35    (values
36     (getf (progn (setf x (incf i)) '(a b))
37           (progn (setf y (incf i)) 'a))
38     i x y))
39  b 2 1 2)
40                 
41(deftest getf.order.2
42  (let ((i 0) x y z)
43    (values
44     (getf (progn (setf x (incf i)) '(a b))
45           (progn (setf y (incf i)) 'a)
46           (setf z (incf i)))
47     i x y z))
48  b 3 1 2 3)
49
50(deftest setf-getf.1
51  (let ((p (copy-list '(a 1 b 2))))
52    (setf (getf p 'c) 3)
53    ;; Must check that only a, b, c have properties
54    (and
55     (eqlt (getf p 'a) 1)
56     (eqlt (getf p 'b) 2)
57     (eqlt (getf p 'c) 3)
58     (eqlt
59      (loop
60       for ptr on p by #'cddr count
61       (not (member (car ptr) '(a b c))))
62      0)
63     t))
64  t)
65
66(deftest setf-getf.2
67  (let ((p (copy-list '(a 1 b 2))))
68    (setf (getf p 'a) 3)
69    ;; Must check that only a, b have properties
70    (and
71     (eqlt (getf p 'a) 3)
72     (eqlt (getf p 'b) 2)
73     (eqlt
74      (loop
75       for ptr on p by #'cddr count
76       (not (member (car ptr) '(a b))))
77      0)
78     t))
79  t)   
80
81(deftest setf-getf.3
82  (let ((p (copy-list '(a 1 b 2))))
83    (setf (getf p 'c 17) 3)
84    ;; Must check that only a, b, c have properties
85    (and
86     (eqlt (getf p 'a) 1)
87     (eqlt (getf p 'b) 2)
88     (eqlt (getf p 'c) 3)
89     (eqlt
90      (loop
91       for ptr on p by #'cddr count
92       (not (member (car ptr) '(a b c))))
93      0)
94     t))
95  t)
96
97(deftest setf-getf.4
98  (let ((p (copy-list '(a 1 b 2))))
99    (setf (getf p 'a 17) 3)
100    ;; Must check that only a, b have properties
101    (and
102     (eqlt (getf p 'a) 3)
103     (eqlt (getf p 'b) 2)
104     (eqlt
105      (loop
106       for ptr on p by #'cddr count
107       (not (member (car ptr) '(a b))))
108      0)
109     t))
110  t)
111
112(deftest setf-getf.5
113  (let ((p (copy-list '(a 1 b 2)))
114        (foo nil))
115    (setf (getf p 'a (progn (setf foo t) 0)) 3)
116    ;; Must check that only a, b have properties
117    (and
118     (eqlt (getf p 'a) 3)
119     (eqlt (getf p 'b) 2)
120     (eqlt
121      (loop
122       for ptr on p by #'cddr count
123       (not (member (car ptr) '(a b))))
124      0)
125     foo))
126  t)
127
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    (values
135     cnt1 ; (eqlt cnt1 1)
136     cnt2 ; (eqlt cnt2 1)
137     cnt3 ; (eqlt cnt3 1)
138     (getf (car p) 'a)
139     (getf (car p) 'b)
140     (getf (car p) 'c)
141     (loop
142        for ptr on (car p) by #'cddr count
143          (not (member (car ptr) '(a b c))))))
144  1 1 1
145  1 2 3
146  0)
147
148(deftest setf-getf.order.2
149  (let ((p (list (copy-list '(a 1 b 2))))
150        (i 0) x y z w)
151    (setf (getf (car (progn (setf x (incf i)) p))
152                (progn (setf y (incf i)) 'c)
153                (setf z (incf i)))
154          (progn (setf w (incf i)) 3))
155    ;; Must check that only a, b, c have properties
156    (values
157     i x y z w
158     (getf (car p) 'a)
159     (getf (car p) 'b)
160     (getf (car p) 'c)
161     (loop for ptr on (car p) by #'cddr count
162          (not (member (car ptr) '(a b c))))))
163  4 1 2 3 4 1 2 3 0)
164
165(deftest incf-getf.1
166  (let ((p (copy-list '(a 1 b 2))))
167    (incf (getf p 'b))
168    ;; Must check that only a, b have properties
169    (and
170     (eqlt (getf p 'a) 1)
171     (eqlt (getf p 'b) 3)
172     (eqlt
173      (loop
174       for ptr on p by #'cddr count
175       (not (member (car ptr) '(a b))))
176      0)
177     t))
178  t)
179
180(deftest incf-getf.2
181  (let ((p (copy-list '(a 1 b 2))))
182    (incf (getf p 'c 19))
183    ;; Must check that only a, b have properties
184    (and
185     (eqlt (getf p 'a) 1)
186     (eqlt (getf p 'b) 2)
187     (eqlt (getf p 'c) 20)
188     (eqlt
189        (loop
190         for ptr on p by #'cddr count
191         (not (member (car ptr) '(a b c))))
192        0)
193     t))
194  t)
195
196(deftest push-getf.1
197  (let ((p nil))
198    (values
199     (push 'x (getf p 'a))
200     p))
201  (x) (a (x)))
202
203;;; Error tests
204
205(deftest getf.error.1
206  (signals-error (getf) program-error)
207  t)
208
209(deftest getf.error.2
210  (signals-error (getf nil) program-error)
211  t)
212
213(deftest getf.error.3
214  (signals-error (getf nil nil nil nil) program-error)
215  t)
216
217(deftest getf.error.4
218  (signals-error (getf '(a . b) 'c) type-error)
219  t)
220
221(deftest getf.error.5
222  (signals-error (getf '(a 10 . b) 'c) type-error)
223  t)
Note: See TracBrowser for help on using the repository browser.