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

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

added preliminary eggs for extraction from core libraries

File size: 3.9 KB
Line 
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)
Note: See TracBrowser for help on using the repository browser.