source: project/release/4/queues/tests/run.scm @ 31138

Last change on this file since 31138 was 31138, checked in by felix, 5 years ago

added preliminary eggs for extraction from core libraries

File size: 3.5 KB
Line 
1(use queues)
2
3
4
5(define-syntax assert-error
6  (syntax-rules ()
7    ((_ expr)
8     (assert (handle-exceptions _ #t expr #f)))))
9
10
11;; Queues.
12
13;; These are tested extensively (and probably still not enough)
14;; because of the strange dealings with the front and end lists stored
15;; internally.  If we run into errors, add more regression tests here.
16
17(let ((q (make-queue)))
18  (assert (queue? q))
19  (assert (queue-empty? q))
20  (assert (= 0 (queue-length q)))
21  (assert (null? (queue->list q)))
22  (assert-error (queue-first q))
23  (assert-error (queue-last q))
24  (assert-error (queue-remove! q))
25
26  (queue-add! q 'foo)
27  (assert (eq? 'foo (queue-first q)))
28  (assert (eq? 'foo (queue-last q)))
29  (assert (not (queue-empty? q)))
30  (assert (= (queue-length q) 1))
31  (let ((l1 (queue->list q))
32        (l2 (queue->list q)))
33    (assert (equal? l1 '(foo)))
34    (assert (equal? l2 '(foo)))
35    (assert (not (eq? l1 l2)))          ; Do not share memory
36
37    (queue-add! q 'end)
38
39    (queue-push-back! q 'front)
40
41    (assert (equal? l1 '(foo))))      ; Does not share memory w/ queue
42  (assert (equal? (queue->list q) '(front foo end)))
43
44  (assert (eq? 'front (queue-remove! q)))
45  (assert (eq? 'foo (queue-first q)))
46  (assert (eq? 'end (queue-last q)))
47
48  (queue-push-back-list! q '(one two))
49  (assert (equal? (queue->list q) '(one two foo end)))
50  (assert (= 4 (queue-length q)))
51
52  (assert (eq? 'one (queue-remove! q)))
53  (assert (eq? 'two (queue-remove! q)))
54  (assert (= 2 (queue-length q)))
55  (assert (eq? 'foo (queue-first q)))
56  (assert (eq? 'end (queue-last q)))
57  (assert (not (queue-empty? q)))
58
59  (assert (eq? 'foo (queue-remove! q)))
60  (assert (eq? 'end (queue-first q)))
61  (assert (eq? 'end (queue-last q)))
62  (assert (= (queue-length q) 1))
63  (assert (not (queue-empty? q)))
64
65  (assert (eq? 'end (queue-remove! q)))
66  (assert (queue-empty? q))
67  (assert (= (queue-length q) 0))
68  (assert-error (queue-first q))
69  (assert-error (queue-last q))
70  (assert-error (queue-remove! q)))
71
72(let ((q (list->queue (list 'one 'two))))
73  (assert (queue? q))
74  (assert (not (queue-empty? q)))
75  (assert (= (queue-length q) 2))
76  (assert (eq? 'one (queue-first q)))
77  (assert (eq? 'two (queue-last q)))
78
79  (assert (eq? 'one (queue-remove! q)))
80  (assert (eq? 'two (queue-first q)))
81  (assert (eq? 'two (queue-last q)))
82  (assert (= (queue-length q) 1))
83  (assert (not (queue-empty? q)))
84
85  (assert (eq? 'two (queue-remove! q)))
86  (assert-error (queue-first q))
87  (assert-error (queue-last q))
88  (assert (= (queue-length q) 0))
89  (assert (queue-empty? q)))
90
91(let ((q (list->queue (list 'one))))
92  (assert (queue? q))
93  (assert (not (queue-empty? q)))
94  (assert (= (queue-length q) 1))
95  (assert (eq? 'one (queue-first q)))
96  (assert (eq? 'one (queue-last q)))
97
98  (queue-push-back! q 'zero)
99  (assert (eq? 'zero (queue-first q)))
100  (assert (eq? 'one (queue-last q)))
101
102  (queue-add! q 'two)
103  (assert (eq? 'zero (queue-first q)))
104  (assert (eq? 'two (queue-last q)))
105
106  (queue-add! q 'three)
107  (assert (eq? 'zero (queue-first q)))
108  (assert (eq? 'three (queue-last q)))
109  (assert (equal? '(zero one two three) (queue->list q)))
110
111  (assert (eq? 'zero (queue-remove! q)))
112  (assert (eq? 'one (queue-first q)))
113  (assert (eq? 'three (queue-last q)))
114  (assert (= (queue-length q) 3))
115  (assert (not (queue-empty? q)))
116
117  (assert (eq? 'one (queue-remove! q)))
118  (assert (eq? 'two (queue-remove! q)))
119  (assert (eq? 'three (queue-remove! q)))
120  (assert-error (queue-first q))
121  (assert-error (queue-last q))
122  (assert (= (queue-length q) 0))
123  (assert (queue-empty? q)))
Note: See TracBrowser for help on using the repository browser.