1 | ; Support for queues |
---|
2 | ; |
---|
3 | ; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992. |
---|
4 | ; |
---|
5 | ; This code is in the public domain. |
---|
6 | ; |
---|
7 | ; (heavily adapated for use with CHICKEN by felix) |
---|
8 | ; |
---|
9 | |
---|
10 | |
---|
11 | (module queues (make-queue |
---|
12 | queue? |
---|
13 | queue-length |
---|
14 | queue-empty? |
---|
15 | queue-first |
---|
16 | queue-last |
---|
17 | queue-add! |
---|
18 | queue-remove! |
---|
19 | queue->list |
---|
20 | list->queue |
---|
21 | queue-push-back! |
---|
22 | queue-push-back-list!) |
---|
23 | |
---|
24 | (import scheme chicken) |
---|
25 | |
---|
26 | ; Elements in a queue are stored in a list. The last pair in the list |
---|
27 | ; is stored in the queue type so that datums can be added in constant |
---|
28 | ; time. |
---|
29 | |
---|
30 | (define (make-queue) (##sys#make-structure 'queue '() '() 0)) |
---|
31 | (define (queue? x) (##sys#structure? x 'queue)) |
---|
32 | |
---|
33 | (define (queue-length q) ; thread-safe |
---|
34 | (##sys#check-structure q 'queue 'queue-length) |
---|
35 | (##sys#slot q 3)) |
---|
36 | |
---|
37 | (define (queue-empty? q) ; thread-safe |
---|
38 | (##sys#check-structure q 'queue 'queue-empty?) |
---|
39 | (eq? '() (##sys#slot q 1)) ) |
---|
40 | |
---|
41 | (define queue-first ; thread-safe |
---|
42 | (lambda (q) |
---|
43 | (##sys#check-structure q 'queue 'queue-first) |
---|
44 | (let ((first-pair (##sys#slot q 1))) |
---|
45 | (when (eq? '() first-pair) |
---|
46 | (##sys#error 'queue-first "queue is empty" q)) |
---|
47 | (##sys#slot first-pair 0) ) ) ) |
---|
48 | |
---|
49 | (define queue-last ; thread-safe |
---|
50 | (lambda (q) |
---|
51 | (##sys#check-structure q 'queue 'queue-last) |
---|
52 | (let ((last-pair (##sys#slot q 2))) |
---|
53 | (when (eq? '() last-pair) |
---|
54 | (##sys#error 'queue-last "queue is empty" q)) |
---|
55 | (##sys#slot last-pair 0) ) ) ) |
---|
56 | |
---|
57 | (define (queue-add! q datum) ; thread-safe |
---|
58 | (##sys#check-structure q 'queue 'queue-add!) |
---|
59 | (let ((new-pair (cons datum '()))) |
---|
60 | (cond ((eq? '() (##sys#slot q 1)) (##sys#setslot q 1 new-pair)) |
---|
61 | (else (##sys#setslot (##sys#slot q 2) 1 new-pair)) ) |
---|
62 | (##sys#setslot q 2 new-pair) |
---|
63 | (##sys#setislot q 3 (fx+ (##sys#slot q 3) 1)) |
---|
64 | (##core#undefined) ) ) |
---|
65 | |
---|
66 | (define queue-remove! ; thread-safe |
---|
67 | (lambda (q) |
---|
68 | (##sys#check-structure q 'queue 'queue-remove!) |
---|
69 | (let ((first-pair (##sys#slot q 1))) |
---|
70 | (when (eq? '() first-pair) |
---|
71 | (##sys#error 'queue-remove! "queue is empty" q) ) |
---|
72 | (let ((first-cdr (##sys#slot first-pair 1))) |
---|
73 | (##sys#setslot q 1 first-cdr) |
---|
74 | (if (eq? '() first-cdr) |
---|
75 | (##sys#setslot q 2 '()) ) |
---|
76 | (##sys#setislot q 3 (fx- (##sys#slot q 3) 1)) |
---|
77 | (##sys#slot first-pair 0) ) ) ) ) |
---|
78 | |
---|
79 | (define (queue->list q) |
---|
80 | (##sys#check-structure q 'queue 'queue->list) |
---|
81 | (let loop ((lst (##sys#slot q 1)) (lst2 '())) |
---|
82 | (if (null? lst) |
---|
83 | (##sys#fast-reverse lst2) |
---|
84 | (loop (##sys#slot lst 1) (cons (##sys#slot lst 0) lst2))))) |
---|
85 | |
---|
86 | (define (list->queue lst0) |
---|
87 | (##sys#check-list lst0 'list->queue) |
---|
88 | (##sys#make-structure |
---|
89 | 'queue lst0 |
---|
90 | (if (eq? lst0 '()) |
---|
91 | '() |
---|
92 | (do ((lst lst0 (##sys#slot lst 1))) |
---|
93 | ((eq? (##sys#slot lst 1) '()) lst) |
---|
94 | (if (or (not (##core#inline "C_blockp" lst)) |
---|
95 | (not (##core#inline "C_pairp" lst)) ) |
---|
96 | (##sys#error-not-a-proper-list lst0 'list->queue) ) ) ) |
---|
97 | (##sys#length lst0)) ) |
---|
98 | |
---|
99 | |
---|
100 | ; (queue-push-back! queue item) |
---|
101 | ; Pushes an item into the first position of a queue. |
---|
102 | |
---|
103 | (define (queue-push-back! q item) ; thread-safe |
---|
104 | (##sys#check-structure q 'queue 'queue-push-back!) |
---|
105 | (let ((newlist (cons item (##sys#slot q 1)))) |
---|
106 | (##sys#setslot q 1 newlist) |
---|
107 | (if (eq? '() (##sys#slot q 2)) |
---|
108 | (##sys#setslot q 2 newlist)) |
---|
109 | (##sys#setislot q 3 (fx+ (##sys#slot q 3) 1)))) |
---|
110 | |
---|
111 | ; (queue-push-back-list! queue item-list) |
---|
112 | ; Pushes the items in item-list back onto the queue, |
---|
113 | ; so that (car item-list) becomes the next removable item. |
---|
114 | |
---|
115 | (define-inline (last-pair lst0) |
---|
116 | (do ((lst lst0 (##sys#slot lst 1))) |
---|
117 | ((eq? (##sys#slot lst 1) '()) lst))) |
---|
118 | |
---|
119 | (define (queue-push-back-list! q itemlist) |
---|
120 | (##sys#check-structure q 'queue 'queue-push-back-list!) |
---|
121 | (##sys#check-list itemlist 'queue-push-back-list!) |
---|
122 | (let* ((newlist (append itemlist (##sys#slot q 1))) |
---|
123 | (newtail (if (eq? newlist '()) |
---|
124 | '() |
---|
125 | (last-pair newlist)))) |
---|
126 | (##sys#setslot q 1 newlist) |
---|
127 | (##sys#setslot q 2 newtail) |
---|
128 | (##sys#setislot q 3 (fx+ (##sys#slot q 3) (##core#inline "C_i_length" itemlist))))) |
---|
129 | |
---|
130 | ) |
---|