source: project/release/5/mailbox/trunk/inline-queue.scm @ 39725

Last change on this file since 39725 was 39725, checked in by Kon Lovett, 8 weeks ago

add unbuffered-cursor

File size: 17.1 KB
Line 
1;;;; inline-queue.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jun '10
3
4;; Issues
5;;
6;; - Uses (chicken fixnum) & (only record-variants define-record-type-variant)
7
8;; Queue Unlimited
9
10;the identifier needs to be defined by somebody
11(define queue-unlimited 'queue-unlimited)
12(define-record-type-variant queue-unlimited (unsafe unchecked inline)
13  (%make-queue-unlimited ln hd tl)
14  (%queue-unlimited?)
15  (ln %queue-unlimited-count %queue-unlimited-count-set!)
16  (hd %queue-unlimited-first-pair %queue-unlimited-first-pair-set!)
17  (tl %queue-unlimited-last-pair %queue-unlimited-last-pair-set!) )
18
19(define-inline (%make-empty-queue-unlimited)
20  (%make-queue-unlimited 0 '() '()) )
21
22(define-inline (%queue-unlimited-limit q) most-positive-fixnum)
23
24(define-inline (%queue-unlimited-room q) (%queue-unlimited-limit q))
25
26(define-inline (%queue-unlimited-limit-set! q v)
27  (error '%queue-unlimited-limit-set! "immutable" v))
28
29(define-inline (%queue-unlimited-count-add! q n)
30  (%queue-unlimited-count-set! q (fx+ (%queue-unlimited-count q) n)) )
31
32(define-inline (%queue-unlimited-count-sub! q n)
33  (%queue-unlimited-count-set! q (fx- (%queue-unlimited-count q) n)) )
34
35(define-inline (%queue-unlimited-extract-pair! q targ-pair)
36  ;scan queue list until we find the item to remove
37  (let scanning ((this-pair (%queue-unlimited-first-pair q)) (prev-pair '()))
38    ;keep scanning until found
39    (cond
40      ;should not happen but no infinite loops
41      ((null? this-pair)
42        ;note that the pair to extract is in fact gone so ...
43        (error "cannot find queue pair to extract; simultaneous operations?"))
44      ;found?
45      ((eq? this-pair targ-pair)
46        ;so cut out the pair
47        (let ((next-pair (cdr this-pair)))
48          ;at the head of the list, or in the body?
49          (if (null? prev-pair)
50            (%queue-unlimited-first-pair-set! q next-pair)
51            (set-cdr! prev-pair next-pair) )
52          ;when the cut pair is the last item update the last pair ref.
53          (when (eq? this-pair (%queue-unlimited-last-pair q))
54            (%queue-unlimited-last-pair-set! q prev-pair) )
55          (%queue-unlimited-count-sub! q 1) ) )
56      ;not found
57      (else
58        (scanning (cdr this-pair) this-pair) ) ) ) )
59
60(define-inline (%queue-unlimited-add! q v)
61  (let ((new-pair (cons v '())))
62    (if (null? (%queue-unlimited-first-pair q))
63      (%queue-unlimited-first-pair-set! q new-pair)
64      (set-cdr! (%queue-unlimited-last-pair q) new-pair) )
65    (%queue-unlimited-last-pair-set! q new-pair)
66    (%queue-unlimited-count-add! q 1)) )
67
68(define-inline (%queue-unlimited-remove! q)
69  (let* ((first-pair (%queue-unlimited-first-pair q))
70         (next-pair (cdr first-pair)))
71    (%queue-unlimited-first-pair-set! q next-pair)
72    (when (null? next-pair) (%queue-unlimited-last-pair-set! q '()))
73    (%queue-unlimited-count-sub! q 1)
74    (car first-pair) ) )
75
76(define-inline (%queue-unlimited-push-back! q v)
77  (let ((newlist (cons v (%queue-unlimited-first-pair q))))
78    (%queue-unlimited-first-pair-set! q newlist)
79    (when (null? (%queue-unlimited-last-pair q))
80      (%queue-unlimited-last-pair-set! q newlist) )
81    (%queue-unlimited-count-add! q 1) ) )
82
83(define-inline (%queue-unlimited-push-back-list! q ls)
84  (let ((newlist (append! (list-copy ls) (%queue-unlimited-first-pair q))))
85    (%queue-unlimited-first-pair-set! q newlist)
86    (if (null? newlist)
87      (%queue-unlimited-last-pair-set! q '())
88      (%queue-unlimited-last-pair-set! q (last-pair newlist) ) )
89    (%queue-unlimited-count-add! q (length ls)) ) )
90
91(define-inline (%make-queue-unlimited-cursor) (cons '() #f))
92(define-inline (%queue-unlimited-cursor? c) (pair? c))
93(define-inline (%queue-unlimited-cursor-next-pair c) (car c))
94(define-inline (%queue-unlimited-cursor-next-pair-set! c v) (set-car! c v))
95(define-inline (%queue-unlimited-cursor-prev-pair c) (cdr c))
96(define-inline (%queue-unlimited-cursor-prev-pair-set! c v) (set-cdr! c v))
97
98(define-inline (%queue-unlimited-cursor-winding? q c)
99  (%->boolean (%queue-unlimited-cursor-prev-pair c)) )
100
101(define-inline (%queue-unlimited-cursor-unwound? q c)
102  (null? (%queue-unlimited-cursor-next-pair c)) )
103
104(define-inline (%queue-unlimited-cursor-start! q c)
105  ;(%queue-unlimited-cursor-prev-pair-set! c #f)
106  (%queue-unlimited-cursor-next-pair-set! c (%queue-unlimited-first-pair q)) )
107
108;#!eof | *
109(define-inline (%queue-unlimited-cursor-next! q c)
110  (let ((curr-pair (%queue-unlimited-cursor-next-pair c)))
111    ;anything next?
112    (if (null? curr-pair)
113      #!eof
114      ;then peek into the queue for the next item
115      (let ((item (car curr-pair)))
116        (%queue-unlimited-cursor-prev-pair-set! c curr-pair)
117        (%queue-unlimited-cursor-next-pair-set! c (cdr curr-pair))
118        item ) ) ) )
119
120(define-inline (%queue-unlimited-cursor-continue! q c)
121  ;NOTE assumes 1 next item, so prev-pair is still correct
122  (%queue-unlimited-cursor-next-pair-set! c (%queue-unlimited-last-pair q)) )
123
124(define-inline (%queue-unlimited-cursor-rewind! q c)
125  (%queue-unlimited-cursor-prev-pair-set! c #f)
126  (%queue-unlimited-cursor-next-pair-set! c '()) )
127
128(define-inline (%queue-unlimited-cursor-extract! q c)
129  ;unless 'mailbox-cursor-next' has been called don't remove
130  (and-let* ((prev-pair (%queue-unlimited-cursor-prev-pair c)))
131    (%queue-unlimited-extract-pair! q prev-pair) ) )
132
133;; Queue Limited
134
135;the identifier needs to be defined by somebody
136(define queue-limited 'queue-limited)
137(define-record-type-variant queue-limited (unsafe unchecked inline)
138  (%make-queue-limited vc st ed)
139  (%queue-limited?)
140  (vc %queue-limited-vector %queue-limited-vector-set!)
141  (st %queue-limited-start %queue-limited-start-set!)
142  (ed %queue-limited-end %queue-limited-end-set!) )
143
144(define-inline (%make-empty-queue-limited lm)
145  (%make-queue-limited (make-vector (fx+ lm 1) (void)) 0 0) )
146
147;circular buffer: vec[n] s <= e: s = e -> empty, s < e -> some, |e - s| = n -> full
148;
149; inc i: (i + 1)      mod n
150; dec i: (i + (n-1))  mod n
151
152(define-inline (%queue-limited-peek q i)
153  (vector-ref (%queue-limited-vector q) i) )
154
155(define-inline (%queue-limited-poke! q i v)
156  (vector-set! (%queue-limited-vector q) i v) )
157
158(define-inline (%queue-limited-limit q)
159  (vector-length (%queue-limited-vector q)) )
160
161(define-inline (%queue-limited-index-add1 q i)
162  (fxmod (fx+ i 1) (%queue-limited-limit q)) )
163
164(define-inline (%queue-limited-limit-set! q v)
165  (error '%queue-limited-limit-set! "immutable" v) )
166
167(define-inline (fxabs n) (if (< n 0) (fxneg n) n))
168
169(define-inline (%queue-limited-count q)
170  (fxabs (fx- (%queue-limited-end q) (%queue-limited-start q))) )
171
172(define-inline (%queue-limited-count-set! q v)
173  (error '%queue-limited-count-set! "immutable" v) )
174
175(define-inline (%queue-limited-room q)
176  (fx- (%queue-limited-limit q) (%queue-limited-count q)) )
177
178(define-inline (%queue-limited-empty? q #!optional (n 0))
179  (fx<= (fx- (%queue-limited-count q) n) 0) )
180
181(define-inline (%queue-limited-full? q #!optional (n 0))
182  (fx>= (fx+ (%queue-limited-count q) n) (%queue-limited-limit q)) )
183
184(define-inline (%queue-limited-add! q v)
185  (%queue-limited-poke! q (%queue-limited-end q) v)
186  (%queue-limited-end-set! q (%queue-limited-index-add1 q (%queue-limited-end q))) )
187
188(define-inline (%queue-limited-remove! q)
189  (let ((v (%queue-limited-peek q (%queue-limited-start q))))
190    (%queue-limited-start-set! q (%queue-limited-index-add1 q (%queue-limited-start q)))
191    v ) )
192
193(define-inline (%queue-limited-push-back! q v)
194  (error '%queue-limited-push-back! "unsupported" q v) )
195
196(define-inline (%queue-limited-push-back-list! q ls)
197  (error '%queue-limited-push-back-list! "unsupported" q ls) )
198
199;index
200(define-inline (%make-queue-limited-cursor) (void))
201(define-inline (%queue-limited-cursor? c) #f)
202
203(define-inline (%queue-limited-cursor-winding? q c)
204  (error '%queue-limited-cursor-winding? "unsupported" q c) )
205
206(define-inline (%queue-limited-cursor-unwound? q c)
207  (error '%queue-limited-cursor-unwound? "unsupported" q c) )
208
209(define-inline (%queue-limited-cursor-start! q c)
210  (error '%queue-limited-cursor-start! "unsupported" q c) )
211
212;#!eof | *
213(define-inline (%queue-limited-cursor-next! q c)
214  (error '%queue-limited-cursor-next! "unsupported" q c) )
215
216(define-inline (%queue-limited-cursor-continue! q c)
217  (error '%queue-limited-cursor-continue! "unsupported" q c) )
218
219(define-inline (%queue-limited-cursor-rewind! q c)
220  (error '%queue-limited-cursor-rewind! "unsupported" q c) )
221
222(define-inline (%queue-limited-cursor-extract! q c)
223  (error '%queue-limited-cursor-extract! "unsupported" q c) )
224
225;; Queue Unbuffered
226
227;the identifier needs to be defined by somebody
228(define queue-unbuffered 'queue-unbuffered)
229(define-record-type-variant queue-unbuffered (unsafe unchecked inline)
230  (%make-queue-unbuffered vd vl)
231  (%queue-unbuffered?)
232  (vd %queue-unbuffered-maybe? %queue-unbuffered-maybe-set!)
233  (vl %queue-unbuffered-value %queue-unbuffered-value-set!) )
234
235(define-inline (%make-empty-queue-unbuffered)
236  (%make-queue-unbuffered #f (void)) )
237
238(define-inline (%queue-unbuffered-limit q) 1)
239
240(define-inline (%queue-unbuffered-limit-set! q v)
241  (error '%queue-unbuffered-limit-set! "immutable" v) )
242
243(define-inline (%queue-unbuffered-count q)
244  (if (%queue-unbuffered-maybe? q) 1 0) )
245
246(define-inline (%queue-unbuffered-count-set! q v)
247  (error '%queue-unbuffered-count-set! "immutable" v) )
248
249(define-inline (%queue-unbuffered-room q)
250  (if (%queue-unbuffered-maybe? q) 0 1) )
251
252(define-inline (%queue-unbuffered-add! q v)
253  (%queue-unbuffered-maybe-set! q #t)
254  (%queue-unbuffered-value-set! q v) )
255
256(define-inline (%queue-unbuffered-remove! q)
257  (let ((v (%queue-unbuffered-value q)))
258    (%queue-unbuffered-maybe-set! q #f)
259    (%queue-unbuffered-value-set! q (void))
260    v ) )
261
262(define-inline (%queue-unbuffered-push-back! q v)
263  (%queue-unbuffered-add! q v) )
264
265(define-inline (%queue-unbuffered-push-back-list! q ls)
266  (%queue-unbuffered-add! q (car ls)) )
267
268(define-inline (%make-queue-unbuffered-cursor) (cons -1 (void)))
269(define-inline (%queue-unbuffered-cursor? c) (pair c))
270(define-inline (%queue-unbuffered-index c) (car c))
271(define-inline (%queue-unbuffered-index-set! c v) (set-car! c v))
272
273(define-inline (%queue-unbuffered-cursor-winding? q c)
274  (fx<= 0 (%queue-unbuffered-index c)) )
275
276(define-inline (%queue-unbuffered-cursor-unwound? q c)
277  (fx= 1 (%queue-unbuffered-index c)) )
278
279(define-inline (%queue-unbuffered-cursor-start! q c)
280  (%queue-unbuffered-index-set! c 0) )
281
282;#!eof | *
283(define-inline (%queue-unbuffered-cursor-next! q c)
284  (cond
285    ((%queue-unbuffered-cursor-unwound? q c)  #!eof)
286    ((not (%queue-unbuffered-maybe? q))       #!eof)
287    (else
288      (%queue-unbuffered-index-set! c 1)
289      (%queue-unbuffered-value q) ) ) )
290
291(define-inline (%queue-unbuffered-cursor-continue! q c)
292  (%queue-unbuffered-index-set! c 0) )
293
294(define-inline (%queue-unbuffered-cursor-rewind! q c)
295  (%queue-unbuffered-index-set! c -1) )
296
297(define-inline (%queue-unbuffered-cursor-extract! q c)
298  ;unless 'mailbox-cursor-next' has been called don't remove
299  (when (%queue-unbuffered-cursor-winding? q c)
300    (%queue-unbuffered-maybe-set! q #f) ) )
301
302;; Queue Generic
303
304(define-inline (%valid-queue-limit? lm)
305  (or (boolean? lm) (and (fixnum? lm) (positive? lm))) )
306
307(define-inline (%make-empty-queue lm)
308  ;(assert (%valid-queue-limit? lm))
309  (cond
310    ((not lm)       (%make-empty-queue-unlimited))
311    ((fixnum? lm)   (%make-empty-queue-limited lm))
312    (else           (%make-empty-queue-unbuffered)) ) )
313
314(define-inline (%queue? x)
315  (or
316    (%queue-unlimited? x)
317    (%queue-limited? x)
318    (%queue-unbuffered? x) ) )
319
320(define-inline (%queue-limit q)
321  (cond
322    ((%queue-unlimited? q)  (%queue-unlimited-limit q))
323    ((%queue-limited? q)    (%queue-limited-limit q))
324    (else                   (%queue-unbuffered-limit q)) ) )
325
326(define-inline (%queue-limit-set! q v)
327  (cond
328    ((%queue-unlimited? q)  (%queue-unlimited-limit-set! q v))
329    ((%queue-limited? q)    (%queue-limited-limit-set! q v))
330    (else                   (%queue-unbuffered-limit-set! q v)) ) )
331
332(define-inline (%queue-count q)
333  (cond
334    ((%queue-unlimited? q)  (%queue-unlimited-count q))
335    ((%queue-limited? q)    (%queue-limited-count q))
336    (else                   (%queue-unbuffered-count q)) ) )
337
338(define-inline (%queue-count-set! q v)
339  (cond
340    ((%queue-unlimited? q)  (%queue-unlimited-count-set! q v))
341    ((%queue-limited? q)    (%queue-limited-count-set! q v))
342    (else                   (%queue-unbuffered-count-set! q v)) ) )
343
344(define-inline (%queue-room q)
345  (cond
346    ((%queue-unlimited? q)  (%queue-unlimited-room q))
347    ((%queue-limited? q)    (%queue-limited-room q))
348    (else                   (%queue-unbuffered-room q)) ) )
349
350(define-inline (%queue-empty? q #!optional (n 0))
351  (fx<= (fx- (%queue-count q) n) 0) )
352
353(define-inline (%queue-full? q #!optional (n 0))
354  (fx>= (fx+ (%queue-count q) n) (%queue-limit q)) )
355
356(define (queue-empty-error loc q) (error loc "queue empty" q))
357(define (queue-full-error loc q v) (error loc "queue full" q v))
358
359(define-inline (%queue-add!? q v)
360  (if (%queue-full? q)
361    (values #f (void))
362    (values #t
363      (cond
364        ((%queue-unlimited? q)  (%queue-unlimited-add! q v))
365        ((%queue-limited? q)    (%queue-limited-add! q v))
366        (else                   (%queue-unbuffered-add! q v)))) ) )
367
368(define-inline (%queue-remove!? q)
369  (if (%queue-empty? q)
370    (values #f (void))
371    (values #t
372      (cond
373        ((%queue-unlimited? q)  (%queue-unlimited-remove! q))
374        ((%queue-limited? q)    (%queue-limited-remove! q))
375        (else                   (%queue-unbuffered-remove! q)))) ) )
376
377(define-inline (%queue-push-back!? q v)
378  (if (%queue-full? q)
379    (values #f (void))
380    (values #t
381      (cond
382        ((%queue-unlimited? q)  (%queue-unlimited-push-back! q v))
383        ((%queue-limited? q)    (%queue-limited-push-back! q v))
384        (else                   (%queue-unbuffered-push-back! q v)))) ) )
385
386(define-inline (%queue-push-back-list!? q ls)
387  (if (%queue-full? q (length ls))
388    (values #f (void))
389    (values #t
390      (cond
391        ((%queue-unlimited? q)  (%queue-unlimited-push-back-list! q ls))
392        ((%queue-limited? q)    (%queue-limited-push-back-list! q ls))
393        (else                   (%queue-unbuffered-push-back-list! q ls)))) ) )
394
395(define-inline (%queue-add! q v
396                  #!optional
397                  (on-full (lambda () (queue-full-error '%queue-add! q v))))
398  (let loop ()
399    (let-values (((succ? val) (%queue-add!? q v)))
400      (unless succ?
401        (on-full)
402        (loop) )
403      val ) ) )
404
405(define-inline (%queue-remove! q
406                  #!optional
407                  (on-empty (lambda () (queue-empty-error '%queue-remove! q))))
408  (let loop ()
409    (let-values (((succ? val) (%queue-remove!? q)))
410      (unless succ?
411        (on-empty)
412        (loop) )
413      val ) ) )
414
415(define-inline (%queue-push-back! q v
416                  #!optional
417                  (on-full (lambda () (queue-full-error '%queue-push-back! q v))))
418  (let loop ()
419    (let-values (((succ? val) (%queue-push-back!? q v)))
420      (unless succ?
421        (on-full)
422        (loop) )
423      val ) ) )
424
425(define-inline (%queue-push-back-list! q ls
426                  #!optional
427                  (on-full (lambda () (queue-full-error '%queue-push-back-list! q ls))))
428  (let loop ()
429    (let-values (((succ? val) (%queue-push-back-list!? q ls)))
430      (unless succ?
431        (on-full)
432        (loop) )
433      val ) ) )
434
435(define-inline (%make-queue-cursor q)
436  (cond
437    ((%queue-unlimited? q)  (%make-queue-unlimited-cursor))
438    ((%queue-limited? q)    (%make-queue-limited-cursor))
439    (else                   (%make-queue-unbuffered-cursor)) ) )
440
441(define-inline (%queue-cursor-winding? q c)
442  (cond
443    ((%queue-unlimited? q)  (%queue-unlimited-cursor-winding? q c))
444    ((%queue-limited? q)    (%queue-limited-cursor-winding? q c))
445    (else                   (%queue-unbuffered-cursor-winding? q c)) ) )
446
447(define-inline (%queue-cursor-unwound? q c)
448  (cond
449    ((%queue-unlimited? q)  (%queue-unlimited-cursor-unwound? q c))
450    ((%queue-limited? q)    (%queue-limited-cursor-unwound? q c))
451    (else                   (%queue-unbuffered-cursor-unwound? q c)) ) )
452
453(define-inline (%queue-cursor-rewind! q c)
454  (cond
455    ((%queue-unlimited? q)  (%queue-unlimited-cursor-rewind! q c))
456    ((%queue-limited? q)    (%queue-limited-cursor-rewind! q c))
457    (else                   (%queue-unbuffered-cursor-rewind! q c)) ) )
458
459(define-inline (%queue-cursor-start! q c)
460  (cond
461    ((%queue-unlimited? q)  (%queue-unlimited-cursor-start! q c))
462    ((%queue-limited? q)    (%queue-limited-cursor-start! q c))
463    (else                   (%queue-unbuffered-cursor-start! q c)) ))
464
465;#!eof | *
466(define-inline (%queue-cursor-next! q c)
467 (cond
468    ((%queue-unlimited? q)  (%queue-unlimited-cursor-next! q c))
469    ((%queue-limited? q)    (%queue-limited-cursor-next! q c))
470    (else                   (%queue-unbuffered-cursor-next! q c)) ))
471
472(define-inline (%queue-cursor-continue! q c)
473 (cond
474    ((%queue-unlimited? q)  (%queue-unlimited-cursor-continue! q c))
475    ((%queue-limited? q)    (%queue-limited-cursor-continue! q c))
476    (else                   (%queue-unbuffered-cursor-continue! q c)) ))
477
478(define-inline (%queue-cursor-extract! q c)
479  (cond
480    ((%queue-unlimited? q)  (%queue-unlimited-cursor-extract! q c))
481    ((%queue-limited? q)    (%queue-limited-cursor-extract! q c))
482    (else                   (%queue-unbuffered-cursor-extract! q c)) ) )
Note: See TracBrowser for help on using the repository browser.