1 ;;;; miscellaneous tests of LOOP-related stuff
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
14 ;;; The bug reported by Alexei Dejneka on sbcl-devel 2001-09-03
16 (assert (equal (let ((hash (make-hash-table)))
17 (setf (gethash 'key1 hash
) 'val1
)
18 (setf (gethash 'key2 hash
) 'val2
)
19 (sort (loop for key being each hash-key in hash
24 ;;; Bug 81, reported by Wolfhard Buss on cmucl-help 2001-02-14, was
25 ;;; fixed by Alexey Dejneka's patch on sbcl-devel 2001-09-30.
26 (with-test (:name
:loop-destructuring-bind
)
27 ;; FIXME: should this produce a warning? I don't see why.
28 ;; caught STYLE-WARNING:
29 ;; This is not a FLOAT:
31 (declare (muffle-conditions style-warning
))
32 (assert (equal '(0.0
1.0 2.0 3.0)
33 (loop with
(a . b
) of-type float
= '(0.0 .
1.0)
34 and
(c . d
) of-type float
= '(2.0 .
3.0)
35 return
(list a b c d
)))))
37 ;;; a bug reported and fixed by Alexey Dejneka sbcl-devel 2001-10-05:
38 ;;; The type declarations should apply, hence under Python's
39 ;;; declarations-are-assertions rule, the code should signal a type
40 ;;; error. (Except when running interpreted code)
41 #+#.
(cl:if
(cl:eq sb-ext
:*evaluator-mode
* :compile
) '(and) '(or))
42 (with-test (:name
:loop-type-decl
)
43 (declare (muffle-conditions style-warning
))
44 (assert (typep (nth-value 1
48 of-type float
= '(5 .
5)
49 return
(list a b
))))))
52 ;;; bug 103, reported by Arthur Lemmens sbcl-devel 2001-05-05,
53 ;;; fixed by Alexey Dejneka patch sbcl-devel 2001-10-05:
54 ;;; LOOP syntax requires that forms after INITIALLY, FINALLY, and DO
55 ;;; must be compound forms.
56 (with-test (:name
:loop-syntax-err
)
57 (multiple-value-bind (function warnings-p failure-p
)
63 (declare (ignore function warnings-p
))
66 ;;; a bug reported by Paul F. Dietz (in his ANSI test suite):
67 ;;; duplicate bindings in LOOP must signal errors of type
69 (with-test (:name
:loop-duplicate-binding
)
70 (assert (typep (nth-value 1
73 (loop for
(a . a
) in
'((1 .
2) (3 .
4))
77 ;;; similar to gcl/ansi-test LOOP.1.27, and fixed at the same time:
78 (assert (equal (loop for x downto
7 by
2 from
13 collect x
) '(13 11 9 7)))
80 ;;; some more from gcl/ansi-test:
81 (let ((table (make-hash-table)))
82 (setf (gethash 'foo table
) '(bar baz
))
83 (assert (= (loop for nil being the hash-keys of table count t
) 1))
84 (assert (equal (loop for nil being the hash-keys of table
85 using
(hash-value (v1 . v2
))
90 (assert (= (loop for nil being the external-symbols of
:cl count t
) 978))
91 (assert (= (loop for x being the external-symbols of
:cl count x
) 977))
93 (let ((cl:*package
* (find-package :cl
)))
94 (assert (= (loop for x being each external-symbol count t
) 978)))
96 (assert (eq (loop for a
= (return t
) return nil
) t
))
98 (multiple-value-bind (result error
)
100 (loop for nil being the external-symbols of
:nonexistent-package
102 (assert (null result
))
103 (assert (typep error
'package-error
)))
105 (assert (equal (loop for i from
1 repeat
(the (integer 7 7) 7) collect i
)
108 (multiple-value-bind (result error
)
110 (eval '(loop for i from
1 repeat
7 of-type fixnum collect i
)))
111 (assert (null result
))
112 (assert (typep error
'program-error
)))
115 (ignore-errors (loop for i from
1 repeat
6.5 collect i
))
116 (ignore-errors (loop for i from
1 repeat
(eval '6.5) collect i
))))
118 (assert (eq (block nil
119 (loop named foo do
(loop-finish) finally
(return :good
))
123 (assert (= (loop with
(a nil
) = '(1 2) return a
) 1))
124 (assert (= (loop with
(nil a
) = '(1 2) return a
) 2))
125 (assert (= (loop with
(a . nil
) = '(1 2) return a
) 1))
126 (assert (equal (loop with
(nil . a
) = '(1 2) return a
) '(2)))
128 (with-test (:name
:loop-invalid-collector-1
)
129 (multiple-value-bind (result error
)
131 (loop for i in
'(1 2 3) collect i always
(< i
4)))
132 (assert (null result
))
133 (assert (typep error
'program-error
))))
134 (with-test (:name
:loop-invalid-collector-2
)
136 (loop for i in
'(1 2 3) collect i into foo always
(< i
4)
137 finally
(return foo
))
139 (with-test (:name
:loop-invalid-collector-3
)
141 (loop for i in
'(1 2 3) collect i into foo always
(= i
4)
142 finally
(return foo
))
144 (with-test (:name
:loop-invalid-collector-4
)
145 (multiple-value-bind (result error
)
147 (loop for i in
'(1 2 3) always
(< i
4) collect i
))
148 (assert (null result
))
149 (assert (typep error
'program-error
))))
151 (loop for i in
'(1 2 3) always
(< i
4) collect i into foo
152 finally
(return foo
))
155 (loop for i in
'(1 2 3) always
(= i
4) collect i into foo
156 finally
(return foo
))
158 (with-test (:name
:loop-invalid-collector-5
)
159 (multiple-value-bind (result error
)
161 (loop for i in
'(1 2 3) thereis
(= i
3) collect i
))
162 (assert (null result
))
163 (assert (typep error
'program-error
))))
165 (with-test (:name
:loop-invalid-collector-6
)
166 (multiple-value-bind (result error
)
168 (loop with i
= 1 for x from
1 to
3 collect x into i
))
169 (assert (null result
))
170 (assert (typep error
'program-error
))))
171 (with-test (:name
:loop-invalid-collector-7
)
172 (multiple-value-bind (result error
)
173 ;; this one has a plausible interpretation in terms of LET*, but
174 ;; ANSI seems specifically to disallow it
176 (loop with i
= 1 with i
= (1+ i
)
179 (assert (null result
))
180 (assert (typep error
'program-error
))))
184 ;; this one just seems weird. Nevertheless...
185 (loop for i in
'(a b c d
)
189 '(a z b z c z d z
))))
191 (let ((ht (make-hash-table)))
192 (setf (gethash 1 ht
) 3)
193 (setf (gethash 7 ht
) 15)
194 (assert (= (loop for v fixnum being each hash-key in ht sum v
) 8))
195 (assert (= (loop for v fixnum being each hash-value in ht sum v
) 18))
196 #+#.
(cl:if
(cl:eq sb-ext
:*evaluator-mode
* :compile
) '(and) '(or))
197 (assert-error (loop for v float being each hash-value in ht sum v
)
200 ;; arithmetic indexes can be NIL or symbols.
201 (with-test (:name
:loop-anonymous-arithmetic-index
)
202 ;; FIXME: these produce style-warnings. If they're acceptable, they should not warn.
203 (declare (muffle-conditions style-warning
))
204 (assert (equal (loop for nil from
0 to
2 collect nil
)
206 (assert (equal (loop for nil to
2 collect nil
)
209 ;; although allowed by the loop syntax definition in 6.2/LOOP,
210 ;; 6.1.2.1.1 says: "The variable var is bound to the value of form1 in
211 ;; the first iteration[...]"; since we can't bind (i j) to anything,
212 ;; we give a program error.
213 (with-test (:name
:statically-observable-destructuring-problem-1
)
214 (multiple-value-bind (function warnings-p failure-p
)
217 (loop for
(i j
) from
4 to
6 collect nil
)))
218 (declare (ignore function warnings-p
))
221 ;; ...and another for indexes without FROM forms (these are treated
222 ;; differently by the loop code right now
223 (with-test (:name
:statically-observable-destructuring-problem-2
)
224 (multiple-value-bind (function warnings-p failure-p
)
227 (loop for
(i j
) to
6 collect nil
)))
228 (declare (ignore function warnings-p
))
234 (loop for d of-type double-float from
0d0 to
10d0 by x collect d
))
235 '(0d0 2d0
4d0
6d0
8d0
10d0
)))
239 (loop for d of-type double-float downfrom
10d0 to
0d0 by x collect d
))
240 '(10d0 8d0
6d0
4d0
2d0
0d0
)))
242 (let ((fn (handler-case
243 (compile nil
'(lambda ()
244 (declare (special x y
))
245 (loop thereis
(pop x
) thereis
(pop y
))))
246 (warning (c) (error "Warned: ~S" c
)))))
247 (let ((x (list nil nil
1))
248 (y (list nil
2 nil
)))
249 (declare (special x y
))
250 (assert (= (funcall fn
) 2))))
252 ;;; Incorrect LIST type declaration, reported and patched by Teemu
253 ;;; Kalvas: end testing is done "as if by atom" so this is supposed
255 (assert (equal '(1 2) (loop for
(a . b
) on
'(1 2 .
3) collect a
)))
257 ;;; Detection of duplicate bindings, reported by Bruno Haible for CMUCL.
258 (multiple-value-bind (_ condition
)
260 (macroexpand '(LOOP WITH A
= 0 FOR A DOWNFROM
10 TO
0 DO
(PRINT A
))))
262 (assert (typep condition
'program-error
)))
264 ;;; Loop variable with a range excluding 0, reported by Andras Simon.
265 ;;; (Used to signal an error during macroexpansion.)
266 (with-test (:name
:loop-var-range-excludes-zero
)
267 (assert (not (loop with foo of-type
(single-float 1.0 2.0) = 1.5
268 do
(progn foo
(return))))))
270 ;;; 1.0.26.12 used to signal a bogus type error for this.
271 (loop with x of-type
(simple-vector 1) = (make-array '(1))
275 (with-test (:name
:bug-540186
)
276 (let ((fun (compile nil
`(lambda (x)
277 (loop for i from
0 below
(length x
)
278 for vec of-type vector
= (aref x i
)
280 (assert (equal '("foo" "bar")
282 (vector "foo" "bar"))))))
284 (with-test (:name
:bug-lp613871
)
285 (multiple-value-bind (function warnings-p failure-p
)
286 (compile nil
'(lambda () (loop with nil
= 1 repeat
2 collect t
)))
287 (assert (null warnings-p
))
288 (assert (null failure-p
))
289 (assert (equal '(t t
) (funcall function
))))
290 (multiple-value-bind (function warnings-p failure-p
)
291 (compile nil
'(lambda () (loop with nil repeat
2 collect t
)))
292 (assert (null warnings-p
))
293 (assert (null failure-p
))
294 (assert (equal '(t t
) (funcall function
)))))
296 (with-test (:name
:bug-654220-regression
)
297 (assert (= 32640 (loop for i to
255
298 sum i into sum of-type fixnum
299 finally
(return sum
)))))
301 (with-test (:name
:of-type-character-init
)
302 ;; The intention here is to if we initialize C to NIL before iteration start
303 ;; by looking for tell-tale types such as (OR NULL CHARACTER). ...not the
304 ;; most robust test ever, no.
305 (let* ((fun (compile nil
`(lambda (x)
306 (loop for c of-type character in x
307 collect
(char-code c
)))))
308 (consts (ctu:find-code-constants fun
:type
'(or symbol list
))))
309 (assert (or (null consts
) (equal 'character consts
)))))
311 (with-test (:name
:type-of-nilled-vars
)
312 (assert (equal (loop for
(a b
) float
= '(1.0
2.0)
315 (assert (equal (loop for
(a nil b
) float
= '(1.0
3.0 2.0)
319 (with-test (:name
:misplaced-declarations
)
321 (compile nil
`(lambda ()
322 (loop with
(a) = '(1.0
)
327 (with-test (:name
:duplicate-bindings
)
329 (funcall (compile nil
`(lambda ()
330 (loop with
(a b
) = '(1.0
2.0)
331 and
(c a
) = '(3.0
4.0)
332 return
(list a b c
))))))
334 (funcall (compile nil
`(lambda ()
336 with
((a) b
) = '((1.0
) 2.0)
337 return
(list a b
))))))
339 (funcall (compile nil
`(lambda ()
340 (loop with
(b) = '(10)
345 (funcall (compile nil
`(lambda ()
346 (loop with
(a) = '(3)
348 collect a into b
))))))
350 (with-test (:name
:multiple-maximize
)
352 (compile nil
`(lambda ()
353 (loop for x to
10 maximize x minimize x
)))
356 (compile nil
`(lambda ()
357 (loop for x to
10 minimize x minimize x
)))
360 (compile nil
`(lambda ()
361 (loop for x to
10 minimize x into z minimize x into z finally
(return z
))))
364 (with-test (:name
:destructuring-less
)
365 (assert (equal (loop with
(a b
) = '() repeat
1 collect
(list a b
))
368 (with-test (:name
:count-with-sum
)
369 (assert (= (loop repeat
1 count
1 sum
#c
(1 2))
371 (assert (= (loop repeat
1 sum
1 count
1)
374 (with-test (:name
:iterate-over-complex
)
377 (loop for c from
#c
(0 1) repeat
5 collect c
)
378 '(#C
(0 1) #C
(1 1) #C
(2 1) #C
(3 1) #C
(4 1)))))
380 (with-test (:name
:side-effecting-start-form
)
381 (assert (equal (let ((n 0))
382 (loop for x from
(incf n
) to
(+ n
5) collect x
))
385 (with-test (:name
:summing-complex
)
386 (assert (equal (loop for i from
1 to
4
387 sum
(complex i
(1+ i
)) of-type complex
)
390 (with-test (:name
:negative-repeat
)
391 (assert (zerop (let ((z 0))
392 (loop repeat
0 do
(incf z
))
394 (assert (zerop (let ((z 0))
395 (loop repeat -
1.5 do
(incf z
))
397 (assert (zerop (let ((z 0))
398 (loop repeat -
1.5 do
(incf z
))
400 (assert (zerop (let ((z 0))
401 (loop repeat -
1000000 do
(incf z
))
404 (with-test (:name
:of-type-character
)
405 (assert (null (loop with a t return a
)))
407 (assert (typep (loop with a of-type extended-char return a
) 'extended-char
))
408 (assert (typep (loop with a of-type character return a
) 'character
))
409 (assert (typep (loop with a of-type base-char return a
) 'base-char
))
410 (assert (typep (loop with a of-type standard-char return a
) 'standard-char
)))
412 (with-test (:name
:empty-type
)
414 (compile nil
`(lambda ()
415 (loop with a of-type
(and fixnum string
) return a
)))
418 (compile nil
`(lambda ()
419 (loop for i to
10 sum i of-type
(and fixnum string
))))
422 (with-test (:name
:loop-repeat-const
)
423 ;; without explicit constant-folding in LOOP-DO-REPEAT, the type of this loop's
424 ;; counter is INTEGER which unfortunately resulted in generic math throughout,
425 ;; since a FOR/THEN clause interacts badly with type inference.
426 ;; [if there is no FOR/THEN, the compiler understands the code better,
427 ;; and is able to infer a lower bound on decrementing from (+ 1 5)]
429 (compile nil
'(lambda ()
430 (declare (optimize speed
))
431 (loop for baz
= 'this then
'that repeat
(+ 1 5)
434 (with-test (:name
:loop-default-init-type
)
435 (assert-no-signal (compile nil
437 (declare (optimize speed
))
438 (loop for a of-type
(simple-vector 4) in list
439 collect
(aref a
2))))
440 sb-ext
:compiler-note
))
442 (with-test (:name
:with-destructuring
)
443 (declare (muffle-conditions style-warning
)) ; why?
444 (assert (= (loop with
((a . b
)) = '((1 .
2))
447 (assert (= (loop with
(((a) b
)) = '(((1) 3))
451 (with-test (:name
:destructuring-m-v-list
:skipped-on
:interpreter
)
453 (loop for i from
0 below n-iter
454 for
(a b
) = (multiple-value-list (floor i
5))
456 (ctu:assert-no-consing
(f 1000))))
458 (with-test (:name
:destructuring-m-v-list-with-nil
)
459 (assert (equal-mod-gensyms
460 (macroexpand-1 '(sb-loop::loop-desetq
(x nil z
) (multiple-value-list (foo))))
461 '(multiple-value-bind (g1 g2 g3
) (foo)
462 (declare (ignore g2
))
463 (sb-loop::loop-desetq x g1
)
464 (sb-loop::loop-desetq z g3
)))))
466 (with-test (:name
:collect-list-type
)
468 (equal (third (sb-kernel:%simple-fun-type
473 finally
(return m
))))))
474 '(values list
&optional
)))
476 (equal (third (sb-kernel:%simple-fun-type
481 '(values list
&optional
))))