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

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

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

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