source: trunk/source/tests/ansi-tests/every.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: 7.8 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Thu Oct 17 23:25:58 2002
4;;;; Contains: Tests of EVERY
5
6(in-package :cl-test)
7
8(deftest every.1
9  (notnot-mv (every #'identity nil))
10  t)
11
12(deftest every.2
13  (notnot-mv (every #'identity #()))
14  t)
15
16(deftest every.3
17  (let ((count 0))
18    (values
19     (every #'(lambda (x) (incf count) (< x 10))
20            '(1 2 4 13 5 1))
21     count))
22  nil 4)
23
24(deftest every.4
25  (notnot-mv (every #'= '(1 2 3 4) '(1 2 3 4 5)))
26  t)
27
28(deftest every.5
29  (notnot-mv (every #'= '(1 2 3 4 5) '(1 2 3 4)))
30  t)
31
32(deftest every.6
33  (every #'= '(1 2 3 4 5) '(1 2 3 4 6))
34  nil)
35
36(deftest every.7
37  (notnot-mv (every #'(lambda (x y) (or x y))
38                    '(nil t t nil t) #(t nil t t nil nil)))
39  t)
40
41(deftest every.8
42  (let ((x '(1))
43        (args nil))
44    (loop for i from 1 below (1- (min 100 call-arguments-limit))
45          do (push x args)
46          always (apply #'every #'= args)))
47  t)
48
49(deftest every.9
50  (notnot-mv (every #'zerop #*000000000000))
51  t)
52
53(deftest every.10
54  (notnot-mv (every #'zerop #*))
55  t)
56
57(deftest every.11
58  (every #'zerop #*0000010000)
59  nil)
60
61(deftest every.12
62  (notnot-mv (every #'(lambda (x) (eql x #\a)) "aaaaaaaa"))
63  t)
64
65(deftest every.13
66  (notnot-mv (every #'(lambda (x) (eql x #\a)) ""))
67  t)
68
69(deftest every.14
70  (every #'(lambda (x) (eql x #\a)) "aaaaaabaaaa")
71  nil)
72
73(deftest every.15
74  (every 'null '(nil nil t nil))
75  nil)
76
77(deftest every.16
78  (notnot-mv (every 'null '(nil nil nil nil)))
79  t)
80
81;;; Other specialized sequences
82
83(deftest every.17
84  (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 2 3 4 5 6)
85                       :fill-pointer 4)))
86    (loop for j from 0 to 9
87          do (setf (fill-pointer v) j)
88          collect (notnot (every #'zerop v))))
89  (t t t t t nil nil nil nil nil))
90
91(deftest every.18
92  (loop for i from 1 to 40
93        for type = `(unsigned-byte ,i)
94        unless
95        (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 1 1 1 1 1)
96                             :element-type type
97                             :fill-pointer 4)))
98          (equal (loop for j from 0 to 9
99                       do (setf (fill-pointer v) j)
100                       collect (notnot (every #'zerop v)))
101                 '(t t t t t nil nil nil nil nil)))
102        collect i)
103  nil)
104
105(deftest every.19
106  (loop for i from 1 to 40
107        for type = `(signed-byte ,i)
108        unless
109        (let ((v (make-array '(10) :initial-contents '(0 0 0 0 -1 -1 -1 -1 -1 -1)
110                             :element-type type
111                             :fill-pointer 4)))
112          (equal (loop for j from 0 to 9
113                       do (setf (fill-pointer v) j)
114                       collect (notnot (every #'zerop v)))
115                 '(t t t t t nil nil nil nil nil)))
116        collect i)
117  nil)
118
119(deftest every.20
120  (let ((v (make-array '(10) :initial-contents "abcd012345"
121                       :element-type 'character
122                       :fill-pointer 4)))
123    (loop for j from 0 to 9
124          do (setf (fill-pointer v) j)
125          collect (notnot (every #'alpha-char-p v))))
126  (t t t t t nil nil nil nil nil))
127
128(deftest every.21
129  (let ((v (make-array '(10) :initial-contents "abcd012345"
130                       :element-type 'base-char
131                       :fill-pointer 4)))
132    (loop for j from 0 to 9
133          do (setf (fill-pointer v) j)
134          collect (notnot (every #'alpha-char-p v))))
135  (t t t t t nil nil nil nil nil))
136
137(deftest every.22
138  (let ((v (make-array '(5) :initial-contents "abcde"
139                       :element-type 'base-char)))
140    (values
141     (notnot (every #'alpha-char-p v))
142     (setf (aref v 2) #\0)
143     (every #'alpha-char-p v)))
144  t #\0 nil)
145
146;;; Displaced vectors
147
148(deftest every.23
149  (let* ((v1 (make-array '(10) :initial-contents '(1 3 2 4 6 8 5 7 9 1)))
150         (v2 (make-array '(4) :displaced-to v1
151                         :displaced-index-offset 2)))
152    (values
153     (every #'evenp v1)
154     (notnot (every 'evenp v2))))
155  nil t)
156
157(deftest every.24
158  (loop for i from 1 to 40
159        for type = `(unsigned-byte ,i)
160        unless
161        (let* ((v1 (make-array '(10) :initial-contents '(1 1 0 0 0 0 1 1 1 1)
162                               :element-type type))
163               (v2 (make-array '(4) :displaced-to v1
164                               :displaced-index-offset 2
165                               :element-type type)))
166          (and (not (every 'evenp v1))
167               (every #'evenp v2)))
168        collect i)
169  nil)
170
171(deftest every.25
172  (loop for i from 1 to 40
173        for type = `(signed-byte ,i)
174        unless
175        (let* ((v1 (make-array '(10) :initial-contents '(-1 -1 0 0 0 0 -1 -1 -1 -1)
176                               :element-type type))
177               (v2 (make-array '(4) :displaced-to v1
178                               :displaced-index-offset 2
179                               :element-type type)))
180          (and (not (every 'evenp v1))
181               (every #'evenp v2)))
182        collect i)
183  nil)
184
185(deftest every.26
186  (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'character)))
187    (loop for i from 0 to 6
188          for s2 = (make-array '(2) :element-type 'character
189                               :displaced-to s1
190                               :displaced-index-offset i)
191          collect (notnot (every 'alpha-char-p s2))))
192  (nil nil t t nil nil nil))
193
194(deftest every.27
195  (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'base-char)))
196    (loop for i from 0 to 6
197          for s2 = (make-array '(2) :element-type 'base-char
198                               :displaced-to s1
199                               :displaced-index-offset i)
200          collect (notnot (every 'alpha-char-p s2))))
201  (nil nil t t nil nil nil))
202
203;;; adjustable vectors
204
205(deftest every.28
206  (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10)
207                       :adjustable t)))
208    (values
209     (notnot (every #'plusp v))
210     (progn
211       (adjust-array v '(11) :initial-element -1)
212       (every #'plusp v))))
213  t nil)
214
215(deftest every.29
216  (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10)
217                       :fill-pointer 10
218                       :adjustable t)))
219    (values
220     (notnot (every #'plusp v))
221     (progn
222       (adjust-array v '(11) :initial-element -1)
223       (every #'plusp v))))
224  t t)
225
226;;; Float, complex vectors
227
228(deftest every.30
229  (loop for type in '(short-float single-float double-float long-float)
230        for v = (make-array '(6)
231                            :element-type type
232                            :initial-contents
233                            (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6)))
234        unless (every #'plusp v)
235        collect (list type v))
236  nil)
237
238(deftest every.31
239  (loop for type in '(short-float single-float double-float long-float)
240        for v = (make-array '(6)
241                            :element-type type
242                            :fill-pointer 5
243                            :initial-contents
244                            (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 -1)))
245        unless (every #'plusp v)
246        collect (list type v))
247  nil)
248
249(deftest every.32
250  (loop for type in '(short-float single-float double-float long-float)
251        for ctype = `(complex ,type)
252        for v = (make-array '(6)
253                            :element-type ctype
254                            :initial-contents
255                            (mapcar #'(lambda (x) (complex x (coerce x type))) '(1 2 3 4 5 6)))
256        unless (every #'complexp v)
257        collect (list type v))
258  nil)
259
260;;; Order of arguments
261
262(deftest every.order.1
263  (let ((i 0) x y)
264    (values
265     (every (progn (setf x (incf i)) #'null)
266            (progn (setf y (incf i)) '(nil nil a nil)))
267     i x y))
268  nil 2 1 2)
269
270(deftest every.order.2
271  (let ((i 0) x y z)
272    (values
273     (every (progn (setf x (incf i)) #'equal)
274            (progn (setf y (incf i)) '(nil nil a nil))
275            (progn (setf z (incf i)) '(nil nil a b)))
276     i x y z))
277  nil 3 1 2 3)
278
279;;; Error cases
280
281(deftest every.error.1
282  (check-type-error #'(lambda (x) (every x '(a b c)))
283                    #'(lambda (x) (typep x '(or function symbol))))
284  nil)
285
286(deftest every.error.2
287  (check-type-error #'(lambda (x) (every #'null x))
288                    #'(lambda (x) (typep x 'sequence)))
289  nil)
290
291(deftest every.error.3
292  (check-type-error #'(lambda (x) (every #'eq () x))
293                    #'(lambda (x) (typep x 'sequence)))
294  nil)
295
296(deftest every.error.8
297  (signals-error (every) program-error)
298  t)
299
300(deftest every.error.9
301  (signals-error (every #'null) program-error)
302  t)
303
304(deftest every.error.10
305  (signals-error (locally (every 1 '(a b c)) t) type-error)
306  t)
307
308(deftest every.error.11
309  (signals-error (every #'cons '(a b c)) program-error)
310  t)
311
312(deftest every.error.12
313  (signals-error (every #'cons '(a b c) '(1 2 3) '(4 5 6)) program-error)
314  t)
315
316(deftest every.error.13
317  (signals-error (every #'car '(a b c)) type-error)
318  t)
319
320(deftest every.error.14
321  (signals-error (every #'identity '(1 2 3 . 4)) type-error)
322  t)
Note: See TracBrowser for help on using the repository browser.