Commit | Line | Data |
---|---|---|
de142bea | 1 | ;;;; list.test --- tests guile's lists -*- scheme -*- |
6debc49e | 2 | ;;;; Copyright (C) 2000, 2001, 2006, 2011 Free Software Foundation, Inc. |
de142bea | 3 | ;;;; |
73be1d9e MV |
4 | ;;;; This library is free software; you can redistribute it and/or |
5 | ;;;; modify it under the terms of the GNU Lesser General Public | |
6 | ;;;; License as published by the Free Software Foundation; either | |
53befeb7 | 7 | ;;;; version 3 of the License, or (at your option) any later version. |
de142bea | 8 | ;;;; |
73be1d9e | 9 | ;;;; This library is distributed in the hope that it will be useful, |
de142bea | 10 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
73be1d9e MV |
11 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
12 | ;;;; Lesser General Public License for more details. | |
de142bea | 13 | ;;;; |
73be1d9e MV |
14 | ;;;; You should have received a copy of the GNU Lesser General Public |
15 | ;;;; License along with this library; if not, write to the Free Software | |
92205699 | 16 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
de142bea | 17 | |
a7e252d5 KR |
18 | (use-modules (test-suite lib) |
19 | (ice-9 documentation)) | |
de142bea DH |
20 | |
21 | ||
22 | ;;; | |
23 | ;;; miscellaneous | |
24 | ;;; | |
25 | ||
5c96bc39 DH |
26 | (define (documented? object) |
27 | (not (not (object-documentation object)))) | |
28 | ||
de142bea DH |
29 | ;; |
30 | ;; This unique tag is reserved for the unroll and diff-unrolled functions. | |
31 | ;; | |
32 | ||
33 | (define circle-indicator | |
34 | (cons 'circle 'indicator)) | |
35 | ||
36 | ;; | |
37 | ;; Extract every single scheme object that is contained within OBJ into a new | |
38 | ;; data structure. That means, if OBJ somewhere contains a pair, the newly | |
39 | ;; created structure holds a reference to the pair as well as references to | |
40 | ;; the car and cdr of that pair. For vectors, the newly created structure | |
41 | ;; holds a reference to that vector as well as references to every element of | |
42 | ;; that vector. Since this is done recursively, the original data structure | |
43 | ;; is deeply unrolled. If there are circles within the original data | |
44 | ;; structures, every reference that points backwards into the data structure | |
45 | ;; is denoted by storing the circle-indicator tag as well as the object the | |
46 | ;; circular reference points to. | |
47 | ;; | |
48 | ||
49 | (define (unroll obj) | |
50 | (let unroll* ((objct obj) | |
51 | (hist '())) | |
52 | (reverse! | |
53 | (let loop ((object objct) | |
54 | (histry hist) | |
55 | (result '())) | |
56 | (if (memq object histry) | |
57 | (cons (cons circle-indicator object) result) | |
58 | (let ((history (cons object histry))) | |
59 | (cond ((pair? object) | |
60 | (loop (cdr object) history | |
61 | (cons (cons object (unroll* (car object) history)) | |
62 | result))) | |
63 | ((vector? object) | |
64 | (cons (cons object | |
65 | (map (lambda (x) | |
66 | (unroll* x history)) | |
67 | (vector->list object))) | |
68 | result)) | |
69 | (else (cons object result))))))))) | |
70 | ||
71 | ;; | |
72 | ;; Compare two data-structures that were generated with unroll. If any of the | |
73 | ;; elements found not to be eq?, return a pair that holds the position of the | |
74 | ;; first found differences of the two data structures. If all elements are | |
75 | ;; found to be eq?, #f is returned. | |
76 | ;; | |
77 | ||
78 | (define (diff-unrolled a b) | |
79 | (cond ;; has everything been compared already? | |
80 | ((and (null? a) (null? b)) | |
81 | #f) | |
82 | ;; do both structures still contain elements? | |
83 | ((and (pair? a) (pair? b)) | |
84 | (cond ;; are the next elements both plain objects? | |
85 | ((and (not (pair? (car a))) (not (pair? (car b)))) | |
86 | (if (eq? (car a) (car b)) | |
87 | (diff-unrolled (cdr a) (cdr b)) | |
88 | (cons a b))) | |
89 | ;; are the next elements both container objects? | |
90 | ((and (pair? (car a)) (pair? (car b))) | |
91 | (if (eq? (caar a) (caar b)) | |
92 | (cond ;; do both objects close a circular structure? | |
93 | ((eq? circle-indicator (caar a)) | |
94 | (if (eq? (cdar a) (cdar b)) | |
95 | (diff-unrolled (cdr a) (cdr b)) | |
96 | (cons a b))) | |
97 | ;; do both objects hold a vector? | |
98 | ((vector? (caar a)) | |
99 | (or (let loop ((a1 (cdar a)) (b1 (cdar b))) | |
100 | (cond | |
101 | ((and (null? a1) (null? b1)) | |
102 | #f) | |
103 | ((and (pair? a1) (pair? b1)) | |
104 | (or (diff-unrolled (car a1) (car b1)) | |
105 | (loop (cdr a1) (cdr b1)))) | |
106 | (else | |
107 | (cons a1 b1)))) | |
108 | (diff-unrolled (cdr a) (cdr b)))) | |
109 | ;; do both objects hold a pair? | |
110 | (else | |
111 | (or (diff-unrolled (cdar a) (cdar b)) | |
112 | (diff-unrolled (cdr a) (cdr b))))) | |
113 | (cons a b))) | |
114 | (else | |
115 | (cons a b)))) | |
116 | (else | |
117 | (cons a b)))) | |
118 | ||
119 | ;;; list | |
120 | ||
a7e252d5 KR |
121 | (with-test-prefix "list" |
122 | ||
123 | (pass-if "documented?" | |
124 | (documented? list)) | |
125 | ||
126 | ;; in guile 1.6.7 and earlier `list' called using `apply' didn't make a | |
127 | ;; new list, it just returned the given list | |
128 | (pass-if "apply gets fresh list" | |
129 | (let* ((x '(1 2 3)) | |
130 | (y (apply list x))) | |
131 | (not (eq? x y))))) | |
de142bea | 132 | |
1d936c05 KR |
133 | ;;; make-list |
134 | ||
135 | (with-test-prefix "make-list" | |
136 | ||
137 | (pass-if "documented?" | |
138 | (documented? make-list)) | |
139 | ||
140 | (with-test-prefix "no init" | |
141 | (pass-if "0" | |
142 | (equal? '() (make-list 0))) | |
143 | (pass-if "1" | |
144 | (equal? '(()) (make-list 1))) | |
145 | (pass-if "2" | |
146 | (equal? '(() ()) (make-list 2))) | |
147 | (pass-if "3" | |
148 | (equal? '(() () ()) (make-list 3)))) | |
149 | ||
150 | (with-test-prefix "with init" | |
151 | (pass-if "0" | |
152 | (equal? '() (make-list 0 'foo))) | |
153 | (pass-if "1" | |
154 | (equal? '(foo) (make-list 1 'foo))) | |
155 | (pass-if "2" | |
156 | (equal? '(foo foo) (make-list 2 'foo))) | |
157 | (pass-if "3" | |
158 | (equal? '(foo foo foo) (make-list 3 'foo))))) | |
159 | ||
d2c32d63 | 160 | ;;; cons* |
de142bea | 161 | |
a7e252d5 KR |
162 | (with-test-prefix "cons*" |
163 | ||
164 | (pass-if "documented?" | |
165 | (documented? list)) | |
166 | ||
167 | (with-test-prefix "one arg" | |
168 | (pass-if "empty list" | |
169 | (eq? '() (cons* '()))) | |
170 | (pass-if "one elem list" | |
171 | (let* ((lst '(1))) | |
172 | (eq? lst (cons* lst)))) | |
173 | (pass-if "two elem list" | |
174 | (let* ((lst '(1 2))) | |
175 | (eq? lst (cons* lst))))) | |
176 | ||
177 | (with-test-prefix "two args" | |
178 | (pass-if "empty list" | |
179 | (equal? '(1) (cons* 1 '()))) | |
180 | (pass-if "one elem list" | |
181 | (let* ((lst '(1)) | |
182 | (ret (cons* 2 lst))) | |
183 | (and (equal? '(2 1) ret) | |
184 | (eq? lst (cdr ret))))) | |
185 | (pass-if "two elem list" | |
186 | (let* ((lst '(1 2)) | |
187 | (ret (cons* 3 lst))) | |
188 | (and (equal? '(3 1 2) ret) | |
189 | (eq? lst (cdr ret)))))) | |
190 | ||
191 | (with-test-prefix "three args" | |
192 | (pass-if "empty list" | |
193 | (equal? '(1 2) (cons* 1 2 '()))) | |
194 | (pass-if "one elem list" | |
195 | (let* ((lst '(1)) | |
196 | (ret (cons* 2 3 lst))) | |
197 | (and (equal? '(2 3 1) ret) | |
198 | (eq? lst (cddr ret))))) | |
199 | (pass-if "two elem list" | |
200 | (let* ((lst '(1 2)) | |
201 | (ret (cons* 3 4 lst))) | |
202 | (and (equal? '(3 4 1 2) ret) | |
203 | (eq? lst (cddr ret)))))) | |
204 | ||
205 | ;; in guile 1.6.7 and earlier `cons*' called using `apply' modified its | |
206 | ;; list argument | |
207 | (pass-if "apply list unchanged" | |
208 | (let* ((lst '(1 2 (3 4))) | |
209 | (ret (apply cons* lst))) | |
210 | (and (equal? lst '(1 2 (3 4))) | |
211 | (equal? ret '(1 2 3 4)))))) | |
de142bea DH |
212 | |
213 | ;;; null? | |
214 | ||
215 | ||
216 | ;;; list? | |
217 | ||
218 | ||
219 | ;;; length | |
220 | ||
221 | ||
222 | ;;; append | |
223 | ||
224 | ||
225 | ;;; | |
226 | ;;; append! | |
227 | ;;; | |
228 | ||
229 | (with-test-prefix "append!" | |
230 | ||
5c96bc39 DH |
231 | (pass-if "documented?" |
232 | (documented? append!)) | |
de142bea DH |
233 | |
234 | ;; Is the handling of empty lists as arguments correct? | |
235 | ||
236 | (pass-if "no arguments" | |
237 | (eq? (append!) | |
238 | '())) | |
239 | ||
240 | (pass-if "empty list argument" | |
241 | (eq? (append! '()) | |
242 | '())) | |
243 | ||
244 | (pass-if "some empty list arguments" | |
245 | (eq? (append! '() '() '()) | |
246 | '())) | |
247 | ||
248 | ;; Does the last non-empty-list argument remain unchanged? | |
249 | ||
250 | (pass-if "some empty lists with non-empty list" | |
251 | (let* ((foo (list 1 2)) | |
252 | (foo-unrolled (unroll foo)) | |
253 | (tst (append! '() '() '() foo)) | |
254 | (tst-unrolled (unroll tst))) | |
255 | (and (eq? tst foo) | |
256 | (not (diff-unrolled foo-unrolled tst-unrolled))))) | |
257 | ||
258 | (pass-if "some empty lists with improper list" | |
259 | (let* ((foo (cons 1 2)) | |
260 | (foo-unrolled (unroll foo)) | |
261 | (tst (append! '() '() '() foo)) | |
262 | (tst-unrolled (unroll tst))) | |
263 | (and (eq? tst foo) | |
264 | (not (diff-unrolled foo-unrolled tst-unrolled))))) | |
265 | ||
266 | (pass-if "some empty lists with circular list" | |
267 | (let ((foo (list 1 2))) | |
268 | (set-cdr! (cdr foo) (cdr foo)) | |
269 | (let* ((foo-unrolled (unroll foo)) | |
270 | (tst (append! '() '() '() foo)) | |
271 | (tst-unrolled (unroll tst))) | |
272 | (and (eq? tst foo) | |
273 | (not (diff-unrolled foo-unrolled tst-unrolled)))))) | |
274 | ||
275 | (pass-if "some empty lists with non list object" | |
276 | (let* ((foo (vector 1 2 3)) | |
277 | (foo-unrolled (unroll foo)) | |
278 | (tst (append! '() '() '() foo)) | |
279 | (tst-unrolled (unroll tst))) | |
280 | (and (eq? tst foo) | |
281 | (not (diff-unrolled foo-unrolled tst-unrolled))))) | |
282 | ||
283 | (pass-if "non-empty list between empty lists" | |
284 | (let* ((foo (list 1 2)) | |
285 | (foo-unrolled (unroll foo)) | |
286 | (tst (append! '() '() '() foo '() '() '())) | |
287 | (tst-unrolled (unroll tst))) | |
288 | (and (eq? tst foo) | |
289 | (not (diff-unrolled foo-unrolled tst-unrolled))))) | |
290 | ||
291 | ;; Are arbitrary lists append!ed correctly? | |
292 | ||
293 | (pass-if "two one-element lists" | |
294 | (let* ((foo (list 1)) | |
295 | (foo-unrolled (unroll foo)) | |
296 | (bar (list 2)) | |
297 | (bar-unrolled (unroll bar)) | |
298 | (tst (append! foo bar)) | |
299 | (tst-unrolled (unroll tst)) | |
300 | (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled))) | |
301 | (and (equal? tst '(1 2)) | |
302 | (not (diff-unrolled (car diff-foo-tst) (unroll '()))) | |
303 | (not (diff-unrolled bar-unrolled (cdr diff-foo-tst)))))) | |
304 | ||
305 | (pass-if "three one-element lists" | |
306 | (let* ((foo (list 1)) | |
307 | (foo-unrolled (unroll foo)) | |
308 | (bar (list 2)) | |
309 | (bar-unrolled (unroll bar)) | |
310 | (baz (list 3)) | |
311 | (baz-unrolled (unroll baz)) | |
312 | (tst (append! foo bar baz)) | |
313 | (tst-unrolled (unroll tst)) | |
314 | (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled))) | |
315 | (and (equal? tst '(1 2 3)) | |
316 | (not (diff-unrolled (car diff-foo-tst) (unroll '()))) | |
317 | (let* ((tst-unrolled-2 (cdr diff-foo-tst)) | |
318 | (diff-foo-bar (diff-unrolled bar-unrolled tst-unrolled-2))) | |
319 | (and (not (diff-unrolled (car diff-foo-bar) (unroll '()))) | |
320 | (not (diff-unrolled baz-unrolled (cdr diff-foo-bar)))))))) | |
321 | ||
322 | (pass-if "two two-element lists" | |
323 | (let* ((foo (list 1 2)) | |
324 | (foo-unrolled (unroll foo)) | |
325 | (bar (list 3 4)) | |
326 | (bar-unrolled (unroll bar)) | |
327 | (tst (append! foo bar)) | |
328 | (tst-unrolled (unroll tst)) | |
329 | (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled))) | |
330 | (and (equal? tst '(1 2 3 4)) | |
331 | (not (diff-unrolled (car diff-foo-tst) (unroll '()))) | |
332 | (not (diff-unrolled bar-unrolled (cdr diff-foo-tst)))))) | |
333 | ||
334 | (pass-if "three two-element lists" | |
335 | (let* ((foo (list 1 2)) | |
336 | (foo-unrolled (unroll foo)) | |
337 | (bar (list 3 4)) | |
338 | (bar-unrolled (unroll bar)) | |
339 | (baz (list 5 6)) | |
340 | (baz-unrolled (unroll baz)) | |
341 | (tst (append! foo bar baz)) | |
342 | (tst-unrolled (unroll tst)) | |
343 | (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled))) | |
344 | (and (equal? tst '(1 2 3 4 5 6)) | |
345 | (not (diff-unrolled (car diff-foo-tst) (unroll '()))) | |
346 | (let* ((tst-unrolled-2 (cdr diff-foo-tst)) | |
347 | (diff-foo-bar (diff-unrolled bar-unrolled tst-unrolled-2))) | |
348 | (and (not (diff-unrolled (car diff-foo-bar) (unroll '()))) | |
349 | (not (diff-unrolled baz-unrolled (cdr diff-foo-bar)))))))) | |
350 | ||
351 | (pass-if "empty list between non-empty lists" | |
352 | (let* ((foo (list 1 2)) | |
353 | (foo-unrolled (unroll foo)) | |
354 | (bar (list 3 4)) | |
355 | (bar-unrolled (unroll bar)) | |
356 | (baz (list 5 6)) | |
357 | (baz-unrolled (unroll baz)) | |
358 | (tst (append! foo '() bar '() '() baz '() '() '())) | |
359 | (tst-unrolled (unroll tst)) | |
360 | (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled))) | |
361 | (and (equal? tst '(1 2 3 4 5 6)) | |
362 | (not (diff-unrolled (car diff-foo-tst) (unroll '()))) | |
363 | (let* ((tst-unrolled-2 (cdr diff-foo-tst)) | |
364 | (diff-foo-bar (diff-unrolled bar-unrolled tst-unrolled-2))) | |
365 | (and (not (diff-unrolled (car diff-foo-bar) (unroll '()))) | |
366 | (not (diff-unrolled baz-unrolled (cdr diff-foo-bar)))))))) | |
367 | ||
368 | (pass-if "list and improper list" | |
369 | (let* ((foo (list 1 2)) | |
370 | (foo-unrolled (unroll foo)) | |
371 | (bar (cons 3 4)) | |
372 | (bar-unrolled (unroll bar)) | |
373 | (tst (append! foo bar)) | |
374 | (tst-unrolled (unroll tst)) | |
375 | (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled))) | |
376 | (and (equal? tst '(1 2 3 . 4)) | |
377 | (not (diff-unrolled (car diff-foo-tst) (unroll '()))) | |
378 | (not (diff-unrolled bar-unrolled (cdr diff-foo-tst)))))) | |
379 | ||
380 | (pass-if "list and circular list" | |
381 | (let* ((foo (list 1 2)) | |
382 | (foo-unrolled (unroll foo)) | |
383 | (bar (list 3 4 5))) | |
384 | (set-cdr! (cddr bar) (cdr bar)) | |
385 | (let* ((bar-unrolled (unroll bar)) | |
386 | (tst (append! foo bar)) | |
387 | (tst-unrolled (unroll tst)) | |
388 | (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled))) | |
389 | (and (equal? (map (lambda (n x) (eqv? (list-ref tst n) x)) | |
390 | (iota 9) | |
391 | '(1 2 3 4 5 4 5 4 5)) | |
392 | '(#t #t #t #t #t #t #t #t #t)) | |
393 | (not (diff-unrolled (car diff-foo-tst) (unroll '()))) | |
394 | (not (diff-unrolled bar-unrolled (cdr diff-foo-tst))))))) | |
395 | ||
396 | (pass-if "list and non list object" | |
397 | (let* ((foo (list 1 2)) | |
398 | (foo-unrolled (unroll foo)) | |
399 | (bar (vector 3 4)) | |
400 | (bar-unrolled (unroll bar)) | |
401 | (tst (append! foo bar)) | |
402 | (tst-unrolled (unroll tst)) | |
403 | (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled))) | |
404 | (and (equal? tst '(1 2 . #(3 4))) | |
405 | (not (diff-unrolled (car diff-foo-tst) (unroll '()))) | |
406 | (not (diff-unrolled bar-unrolled (cdr diff-foo-tst)))))) | |
407 | ||
408 | (pass-if "several arbitrary lists" | |
409 | (equal? (append! (list 1 2) | |
410 | (list (list 3) 4) | |
411 | (list (list 5) (list 6)) | |
412 | (list 7 (cons 8 9)) | |
413 | (list 10 11) | |
414 | (list (cons 12 13) 14) | |
415 | (list (list))) | |
416 | (list 1 2 | |
417 | (list 3) 4 | |
418 | (list 5) (list 6) | |
419 | 7 (cons 8 9) | |
420 | 10 11 | |
421 | (cons 12 13) | |
422 | 14 (list)))) | |
423 | ||
424 | (pass-if "list to itself" | |
425 | (let* ((foo (list 1 2)) | |
426 | (foo-unrolled (unroll foo)) | |
427 | (tst (append! foo foo)) | |
428 | (tst-unrolled (unroll tst)) | |
429 | (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled))) | |
430 | (and (equal? (map (lambda (n x) (eqv? (list-ref tst n) x)) | |
431 | (iota 6) | |
432 | '(1 2 1 2 1 2)) | |
433 | '(#t #t #t #t #t #t)) | |
434 | (not (diff-unrolled (car diff-foo-tst) (unroll '()))) | |
435 | (eq? (caar (cdr diff-foo-tst)) circle-indicator) | |
436 | (eq? (cdar (cdr diff-foo-tst)) foo)))) | |
437 | ||
438 | ;; Are wrong type arguments detected correctly? | |
439 | ||
440 | (with-test-prefix "wrong argument" | |
441 | ||
226a56a3 | 442 | (pass-if-exception "improper list and empty list" |
6b4113af DH |
443 | exception:wrong-type-arg |
444 | (append! (cons 1 2) '())) | |
445 | ||
226a56a3 | 446 | (pass-if-exception "improper list and list" |
6b4113af DH |
447 | exception:wrong-type-arg |
448 | (append! (cons 1 2) (list 3 4))) | |
449 | ||
226a56a3 | 450 | (pass-if-exception "list, improper list and list" |
6b4113af DH |
451 | exception:wrong-type-arg |
452 | (append! (list 1 2) (cons 3 4) (list 5 6))) | |
de142bea DH |
453 | |
454 | (expect-fail "circular list and empty list" | |
455 | (let ((foo (list 1 2 3))) | |
456 | (set-cdr! (cddr foo) (cdr foo)) | |
457 | (catch #t | |
458 | (lambda () | |
459 | (catch 'wrong-type-arg | |
460 | (lambda () | |
461 | (append! foo '()) | |
462 | #f) | |
463 | (lambda (key . args) | |
464 | #t))) | |
465 | (lambda (key . args) | |
466 | #f)))) | |
467 | ||
468 | (expect-fail "circular list and list" | |
469 | (let ((foo (list 1 2 3))) | |
470 | (set-cdr! (cddr foo) (cdr foo)) | |
471 | (catch #t | |
472 | (lambda () | |
473 | (catch 'wrong-type-arg | |
474 | (lambda () | |
475 | (append! foo (list 4 5)) | |
476 | #f) | |
477 | (lambda (key . args) | |
478 | #t))) | |
479 | (lambda (key . args) | |
480 | #f)))) | |
481 | ||
482 | (expect-fail "list, circular list and list" | |
483 | (let ((foo (list 3 4 5))) | |
484 | (set-cdr! (cddr foo) (cdr foo)) | |
485 | (catch #t | |
486 | (lambda () | |
487 | (catch 'wrong-type-arg | |
488 | (lambda () | |
489 | (append! (list 1 2) foo (list 6 7)) | |
490 | #f) | |
491 | (lambda (key . args) | |
492 | #t))) | |
493 | (lambda (key . args) | |
494 | #f)))))) | |
495 | ||
496 | ||
497 | ;;; last-pair | |
498 | ||
499 | ||
500 | ;;; reverse | |
501 | ||
502 | ||
503 | ;;; reverse! | |
504 | ||
505 | ||
506 | ;;; list-ref | |
507 | ||
685c0d71 DH |
508 | (with-test-prefix "list-ref" |
509 | ||
5c96bc39 DH |
510 | (pass-if "documented?" |
511 | (documented? list-ref)) | |
685c0d71 DH |
512 | |
513 | (with-test-prefix "argument error" | |
514 | ||
515 | (with-test-prefix "non list argument" | |
516 | #t) | |
517 | ||
518 | (with-test-prefix "improper list argument" | |
519 | #t) | |
520 | ||
521 | (with-test-prefix "non integer index" | |
522 | #t) | |
523 | ||
524 | (with-test-prefix "index out of range" | |
525 | ||
526 | (with-test-prefix "empty list" | |
527 | ||
6b4113af DH |
528 | (pass-if-exception "index 0" |
529 | exception:out-of-range | |
530 | (list-ref '() 0)) | |
531 | ||
532 | (pass-if-exception "index > 0" | |
533 | exception:out-of-range | |
534 | (list-ref '() 1)) | |
535 | ||
536 | (pass-if-exception "index < 0" | |
537 | exception:out-of-range | |
538 | (list-ref '() -1))) | |
685c0d71 DH |
539 | |
540 | (with-test-prefix "non-empty list" | |
541 | ||
6b4113af DH |
542 | (pass-if-exception "index > length" |
543 | exception:out-of-range | |
544 | (list-ref '(1) 1)) | |
685c0d71 | 545 | |
6b4113af DH |
546 | (pass-if-exception "index < 0" |
547 | exception:out-of-range | |
548 | (list-ref '(1) -1)))))) | |
685c0d71 | 549 | |
de142bea DH |
550 | |
551 | ;;; list-set! | |
552 | ||
685c0d71 DH |
553 | (with-test-prefix "list-set!" |
554 | ||
5c96bc39 DH |
555 | (pass-if "documented?" |
556 | (documented? list-set!)) | |
685c0d71 DH |
557 | |
558 | (with-test-prefix "argument error" | |
559 | ||
560 | (with-test-prefix "non list argument" | |
561 | #t) | |
562 | ||
563 | (with-test-prefix "improper list argument" | |
564 | #t) | |
565 | ||
566 | (with-test-prefix "read-only list argument" | |
567 | #t) | |
568 | ||
569 | (with-test-prefix "non integer index" | |
570 | #t) | |
571 | ||
572 | (with-test-prefix "index out of range" | |
573 | ||
574 | (with-test-prefix "empty list" | |
575 | ||
6b4113af DH |
576 | (pass-if-exception "index 0" |
577 | exception:out-of-range | |
578 | (list-set! (list) 0 #t)) | |
579 | ||
580 | (pass-if-exception "index > 0" | |
581 | exception:out-of-range | |
582 | (list-set! (list) 1 #t)) | |
583 | ||
584 | (pass-if-exception "index < 0" | |
585 | exception:out-of-range | |
586 | (list-set! (list) -1 #t))) | |
685c0d71 DH |
587 | |
588 | (with-test-prefix "non-empty list" | |
589 | ||
6b4113af DH |
590 | (pass-if-exception "index > length" |
591 | exception:out-of-range | |
592 | (list-set! (list 1) 1 #t)) | |
685c0d71 | 593 | |
6b4113af DH |
594 | (pass-if-exception "index < 0" |
595 | exception:out-of-range | |
596 | (list-set! (list 1) -1 #t)))))) | |
685c0d71 | 597 | |
de142bea DH |
598 | |
599 | ;;; list-cdr-ref | |
600 | ||
601 | ||
602 | ;;; list-tail | |
603 | ||
604 | ||
605 | ;;; list-cdr-set! | |
606 | ||
685c0d71 DH |
607 | (with-test-prefix "list-cdr-set!" |
608 | ||
5c96bc39 DH |
609 | (pass-if "documented?" |
610 | (documented? list-cdr-set!)) | |
685c0d71 DH |
611 | |
612 | (with-test-prefix "argument error" | |
613 | ||
614 | (with-test-prefix "non list argument" | |
615 | #t) | |
616 | ||
617 | (with-test-prefix "improper list argument" | |
618 | #t) | |
619 | ||
620 | (with-test-prefix "read-only list argument" | |
621 | #t) | |
622 | ||
623 | (with-test-prefix "non integer index" | |
624 | #t) | |
625 | ||
626 | (with-test-prefix "index out of range" | |
627 | ||
628 | (with-test-prefix "empty list" | |
629 | ||
6b4113af DH |
630 | (pass-if-exception "index 0" |
631 | exception:out-of-range | |
632 | (list-cdr-set! (list) 0 #t)) | |
633 | ||
634 | (pass-if-exception "index > 0" | |
635 | exception:out-of-range | |
636 | (list-cdr-set! (list) 1 #t)) | |
637 | ||
638 | (pass-if-exception "index < 0" | |
639 | exception:out-of-range | |
640 | (list-cdr-set! (list) -1 #t))) | |
685c0d71 DH |
641 | |
642 | (with-test-prefix "non-empty list" | |
643 | ||
6b4113af DH |
644 | (pass-if-exception "index > length" |
645 | exception:out-of-range | |
646 | (list-cdr-set! (list 1) 1 #t)) | |
647 | ||
648 | (pass-if-exception "index < 0" | |
649 | exception:out-of-range | |
650 | (list-cdr-set! (list 1) -1 #t)))))) | |
685c0d71 | 651 | |
de142bea DH |
652 | |
653 | ;;; list-head | |
654 | ||
655 | ||
656 | ;;; list-copy | |
657 | ||
658 | ||
de142bea DH |
659 | ;;; memq |
660 | ||
6debc49e LC |
661 | (with-test-prefix/c&e "memq" |
662 | ||
663 | (pass-if "inline" | |
664 | ;; In this case `memq' is inlined and the loop is unrolled. | |
665 | (equal? '(b c d) (memq 'b '(a b c d)))) | |
666 | ||
667 | (pass-if "non inline" | |
668 | ;; In this case a real function call is generated. | |
669 | (equal? '(b c d) (memq 'b (list 'a 'b 'c 'd))))) | |
de142bea DH |
670 | |
671 | ;;; memv | |
672 | ||
6debc49e LC |
673 | (with-test-prefix/c&e "memv" |
674 | (pass-if "inline" | |
675 | ;; In this case `memv' is inlined and the loop is unrolled. | |
676 | (equal? '(b c d) (memv 'b '(a b c d)))) | |
677 | ||
678 | (pass-if "non inline" | |
679 | ;; In this case a real function call is generated. | |
680 | (equal? '(b c d) (memv 'b (list 'a 'b 'c 'd))))) | |
de142bea DH |
681 | |
682 | ;;; member | |
683 | ||
684 | ||
685 | ;;; delq! | |
686 | ||
687 | ||
688 | ;;; delv! | |
689 | ||
690 | ||
691 | ;;; delete! | |
692 | ||
693 | ||
694 | ;;; delq | |
695 | ||
696 | ||
697 | ;;; delv | |
698 | ||
699 | ||
700 | ;;; delete | |
701 | ||
702 | ||
703 | ;;; delq1! | |
704 | ||
705 | ||
706 | ;;; delv1! | |
707 | ||
708 | ||
709 | ;;; delete1! |