1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
|
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; Queues
; Richard's code with Jonathan's names.
;
; Richard's names: Jonathan's names (modified by popular demand):
; make-empty-queue make-queue
; add-to-queue! enqueue!
; remove-from-queue! dequeue!
(define-record-type queue :queue
(really-make-queue uid head tail)
queue?
(uid queue-uid)
(head queue-head set-queue-head!)
(tail queue-tail set-queue-tail!))
(define *queue-uid* 0)
(define (make-queue)
(let ((uid *queue-uid*))
(set! *queue-uid* (+ uid 1)) ;potential synchronization screw
(really-make-queue uid '() '())))
; The procedures for manipulating queues.
(define (queue-empty? q)
;; (debug-message "queue-empty?" (queue? q))
(null? (queue-head q)))
(define (enqueue! q v)
;; (debug-message "enqueue!" (queue? q))
(let ((p (cons v '())))
(if (null? (queue-head q)) ;(queue-empty? q)
(set-queue-head! q p)
(set-cdr! (queue-tail q) p))
(set-queue-tail! q p)))
(define (queue-front q)
;; (debug-message "queue-front" (queue? q))
(if (queue-empty? q)
(error "queue is empty" q)
(car (queue-head q))))
(define (dequeue! q)
;; (debug-message "dequeue!" (queue? q))
(let ((pair (queue-head q)))
(cond ((null? pair) ;(queue-empty? q)
(error "empty queue" q))
(else
(let ((value (car pair))
(next (cdr pair)))
(set-queue-head! q next)
(if (null? next)
(set-queue-tail! q '())) ; don't retain pointers
value)))))
; Same again, except that we return #F if the queue is empty.
; This is a simple way of avoiding a race condition if the queue is known
; not to contain #F.
(define (maybe-dequeue! q)
;; (debug-message "maybe-dequeue!" (queue? q))
(let ((pair (queue-head q)))
(cond ((null? pair) ;(queue-empty? q)
#f)
(else
(let ((value (car pair))
(next (cdr pair)))
(set-queue-head! q next)
(if (null? next)
(set-queue-tail! q '())) ; don't retain pointers
value)))))
(define (on-queue? v q)
;; (debug-message "on-queue!" (queue? q))
(memq v (queue-head q)))
; This removes the first occurrence of V from Q.
(define (delete-from-queue! q v)
(delete-from-queue-if! q (lambda (x) (eq? x v))))
(define (delete-from-queue-if! q pred)
;; (debug-message "delete-from-queue-if!" (queue? q))
(let ((list (queue-head q)))
(cond ((null? list)
#f)
((pred (car list))
(set-queue-head! q (cdr list))
(if (null? (cdr list))
(set-queue-tail! q '())) ; don't retain pointers
#t)
((null? (cdr list))
#f)
(else
(let loop ((list list))
(let ((tail (cdr list)))
(cond ((null? tail)
#f)
((pred (car tail))
(set-cdr! list (cdr tail))
(if (null? (cdr tail))
(set-queue-tail! q list))
#t)
(else
(loop tail)))))))))
(define (queue->list q) ;For debugging
(map (lambda (x) x)
(queue-head q)))
(define (queue-length q)
(length (queue-head q)))
|
