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
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
; Copyright (c) 1993-2008 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!
;
; Now using optimistic concurrency. We really need two sets of procedures to
; allow those who don't care to avoid the cost of the concurrency checks.
(define-synchronized-record-type queue :queue
(really-make-queue uid head tail)
(head tail) ; synchronize on these
queue?
(uid queue-uid)
(head real-queue-head set-queue-head!)
(tail queue-tail set-queue-tail!))
(define queue-uid (list 0))
(define (next-uid)
(atomically
(let ((uid (provisional-car queue-uid)))
(provisional-set-car! queue-uid (+ uid 1))
uid)))
(define (make-queue)
(really-make-queue (next-uid) '() '()))
; The procedures for manipulating queues.
(define (queue-empty? q)
(null? (real-queue-head q)))
(define (enqueue! q v)
(ensure-atomicity!
(let ((p (cons v '())))
(cond ((null? (real-queue-head q))
(set-queue-head! q p))
((null? (queue-tail q)) ; someone got in first
(invalidate-current-proposal!))
(else
(provisional-set-cdr! (queue-tail q) p)))
(set-queue-tail! q p))))
(define (queue-head q)
(ensure-atomicity
(if (queue-empty? q)
(error "queue is empty" q)
(car (real-queue-head q)))))
(define (dequeue! q)
(ensure-atomicity
(let ((pair (real-queue-head q)))
(cond ((null? pair) ;(queue-empty? q)
(error "empty queue" q))
(else
(queue-tail q) ; touch
(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)
(ensure-atomicity
(let ((pair (real-queue-head q)))
(cond ((null? pair) ;(queue-empty? q)
#f)
(else
(queue-tail q) ; touch
(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 (empty-queue! q)
(ensure-atomicity
(set-queue-head! q '())
(set-queue-tail! q '())))
(define (on-queue? q v)
(ensure-atomicity
(memq v (real-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)
(ensure-atomicity
(let ((head (real-queue-head q)))
(cond ((null? head)
#f)
((pred (car head))
(set-queue-head! q (cdr head))
;; force proposal check
(set-queue-tail! q (if (null? (cdr head))
'()
(let ((p (queue-tail q)))
(cons (car p) (cdr p)))))
#t)
((null? (cdr head))
#f)
(else
(let loop ((list head))
(let ((tail (cdr list)))
(cond ((null? tail)
#f)
((pred (car tail))
(provisional-set-cdr! list (cdr tail))
;; force proposal check
(set-queue-head! q (cons (car head) (cdr head)))
(set-queue-tail! q (if (null? (cdr tail))
list
(let ((p (queue-tail q)))
(cons (car p) (cdr p)))))
#t)
(else
(loop tail))))))))))
(define (queue->list q)
(ensure-atomicity
(map (lambda (x) x)
(real-queue-head q))))
(define (list->queue list)
(if (null? list)
(make-queue)
(let ((head (cons (car list) '())))
(let loop ((rest (cdr list)) (tail head))
(if (null? rest)
(really-make-queue (next-uid) head tail)
(begin
(let ((next (cons (car rest) '())))
(set-cdr! tail next)
(loop (cdr rest) next))))))))
(define (queue-length q)
(ensure-atomicity
(length (real-queue-head q))))
|
