0.8.8.23:
[sbcl/lichteblau.git] / tests / loop.pure.lisp
blobfebf5a79ca24ee8f0c436d4418dc05f6b411610e
1 ;;;; miscellaneous tests of LOOP-related stuff
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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
8 ;;;; from CMU CL.
9 ;;;;
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 (in-package "CL-USER")
16 ;;; The bug reported by Alexei Dejneka on sbcl-devel 2001-09-03
17 ;;; is fixed now.
18 (assert (equal (let ((hash (make-hash-table)))
19 (setf (gethash 'key1 hash) 'val1)
20 (setf (gethash 'key2 hash) 'val2)
21 (sort (loop for key being each hash-key in hash
22 collect key)
23 #'string<))
24 '(key1 key2)))
26 ;;; Bug 81, reported by Wolfhard Buss on cmucl-help 2001-02-14, was
27 ;;; fixed by Alexey Dejneka's patch on sbcl-devel 2001-09-30.
28 (assert (equal '(0.0 1.0 2.0 3.0)
29 (loop with (a . b) of-type float = '(0.0 . 1.0)
30 and (c . d) of-type float = '(2.0 . 3.0)
31 return (list a b c d))))
33 ;;; a bug reported and fixed by Alexey Dejneka sbcl-devel 2001-10-05:
34 ;;; The type declarations should apply, hence under Python's
35 ;;; declarations-are-assertions rule, the code should signal a type
36 ;;; error.
37 (assert (typep (nth-value 1
38 (ignore-errors
39 (funcall (lambda ()
40 (loop with (a . b)
41 of-type float = '(5 . 5)
42 return (list a b))))))
43 'type-error))
45 ;;; bug 103, reported by Arthur Lemmens sbcl-devel 2001-05-05,
46 ;;; fixed by Alexey Dejneka patch sbcl-devel 2001-10-05:
47 ;;; LOOP syntax requires that forms after INITIALLY, FINALLY, and DO
48 ;;; must be compound forms.
49 (multiple-value-bind (function warnings-p failure-p)
50 (compile nil
51 '(lambda ()
52 (loop while t do
53 *print-level*
54 (print t))))
55 (declare (ignore function warnings-p))
56 (assert failure-p))
58 ;;; a bug reported by Paul F. Dietz (in his ANSI test suite):
59 ;;; duplicate bindings in LOOP must signal errors of type
60 ;;; PROGRAM-ERROR.
61 (assert (typep (nth-value 1
62 (ignore-errors
63 (funcall (lambda ()
64 (loop for (a . a) in '((1 . 2) (3 . 4))
65 return a)))))
66 'program-error))
68 ;;; similar to gcl/ansi-test LOOP.1.27, and fixed at the same time:
69 (assert (equal (loop for x downto 7 by 2 from 13 collect x) '(13 11 9 7)))
71 ;;; some more from gcl/ansi-test:
72 (let ((table (make-hash-table)))
73 (setf (gethash 'foo table) '(bar baz))
74 (assert (= (loop for nil being the hash-keys of table count t) 1))
75 (assert (equal (loop for nil being the hash-keys of table
76 using (hash-value (v1 . v2))
77 when v1
78 return v2)
79 '(baz))))
81 (assert (= (loop for nil being the external-symbols of :cl count t) 978))
82 (assert (= (loop for x being the external-symbols of :cl count x) 977))
84 (let ((*package* (find-package :cl)))
85 (assert (= (loop for x being each external-symbol count t) 978)))
87 (assert (eq (loop for a = (return t) return nil) t))
89 (multiple-value-bind (result error)
90 (ignore-errors
91 (loop for nil being the external-symbols of :nonexistent-package
92 count t))
93 (assert (null result))
94 (assert (typep error 'package-error)))
96 (assert (equal (loop for i from 1 repeat (the (integer 7 7) 7) collect i)
97 '(1 2 3 4 5 6 7)))
99 (multiple-value-bind (result error)
100 (ignore-errors
101 (eval '(loop for i from 1 repeat 7 of-type fixnum collect i)))
102 (assert (null result))
103 (assert (typep error 'program-error)))
105 (assert (equal
106 (ignore-errors (loop for i from 1 repeat 6.5 collect i))
107 (ignore-errors (loop for i from 1 repeat (eval '6.5) collect i))))
109 (assert (eq (block nil
110 (loop named foo do (loop-finish) finally (return :good))
111 :bad)
112 :good))
114 (assert (= (loop with (a nil) = '(1 2) return a) 1))
115 (assert (= (loop with (nil a) = '(1 2) return a) 2))
116 (assert (= (loop with (a . nil) = '(1 2) return a) 1))
117 (assert (equal (loop with (nil . a) = '(1 2) return a) '(2)))
119 (multiple-value-bind (result error)
120 (ignore-errors
121 (loop for i in '(1 2 3) collect i always (< i 4)))
122 (assert (null result))
123 (assert (typep error 'program-error)))
124 (assert (equal
125 (loop for i in '(1 2 3) collect i into foo always (< i 4)
126 finally (return foo))
127 '(1 2 3)))
128 (assert (equal
129 (loop for i in '(1 2 3) collect i into foo always (= i 4)
130 finally (return foo))
131 nil))
132 (multiple-value-bind (result error)
133 (ignore-errors
134 (loop for i in '(1 2 3) always (< i 4) collect i))
135 (assert (null result))
136 (assert (typep error 'program-error)))
137 (assert (equal
138 (loop for i in '(1 2 3) always (< i 4) collect i into foo
139 finally (return foo))
140 '(1 2 3)))
141 (assert (equal
142 (loop for i in '(1 2 3) always (= i 4) collect i into foo
143 finally (return foo))
144 nil))
145 (multiple-value-bind (result error)
146 (ignore-errors
147 (loop for i in '(1 2 3) thereis (= i 3) collect i))
148 (assert (null result))
149 (assert (typep error 'program-error)))
151 (multiple-value-bind (result error)
152 (ignore-errors
153 (loop with i = 1 for x from 1 to 3 collect x into i))
154 (assert (null result))
155 (assert (typep error 'program-error)))
156 (multiple-value-bind (result error)
157 ;; this one has a plausible interpretation in terms of LET*, but
158 ;; ANSI seems specifically to disallow it
159 (ignore-errors
160 (loop with i = 1 with i = (1+ i)
161 for x from 1 to 3
162 collect (+ x i)))
163 (assert (null result))
164 (assert (typep error 'program-error)))
166 (let ((it 'z))
167 (assert (equal
168 ;; this one just seems weird. Nevertheless...
169 (loop for i in '(a b c d)
170 when i
171 collect it
172 and collect it)
173 '(a z b z c z d z))))
175 (let ((ht (make-hash-table)))
176 (setf (gethash 1 ht) 3)
177 (setf (gethash 7 ht) 15)
178 (assert (= (loop for v fixnum being each hash-key in ht sum v) 8))
179 (assert (= (loop for v fixnum being each hash-value in ht sum v) 18))
180 (assert (raises-error? (loop for v float being each hash-value in ht sum v)
181 type-error)))
183 ;; arithmetic indexes can be NIL or symbols.
184 (assert (equal (loop for nil from 0 to 2 collect nil)
185 '(nil nil nil)))
186 (assert (equal (loop for nil to 2 collect nil)
187 '(nil nil nil)))
189 ;; although allowed by the loop syntax definition in 6.2/LOOP,
190 ;; 6.1.2.1.1 says: "The variable var is bound to the value of form1 in
191 ;; the first iteration[...]"; since we can't bind (i j) to anything,
192 ;; we give a program error.
193 (multiple-value-bind (function warnings-p failure-p)
194 (compile nil
195 `(lambda ()
196 (loop for (i j) from 4 to 6 collect nil)))
197 (assert failure-p))
199 ;; ...and another for indexes without FROM forms (these are treated
200 ;; differently by the loop code right now
201 (multiple-value-bind (function warnings-p failure-p)
202 (compile nil
203 `(lambda ()
204 (loop for (i j) to 6 collect nil)))
205 (assert failure-p))
207 (assert
208 (equal
209 (let ((x 2d0))
210 (loop for d of-type double-float from 0d0 to 10d0 by x collect d))
211 '(0d0 2d0 4d0 6d0 8d0 10d0)))
212 (assert
213 (equal
214 (let ((x 2d0))
215 (loop for d of-type double-float downfrom 10d0 to 0d0 by x collect d))
216 '(10d0 8d0 6d0 4d0 2d0 0d0)))