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

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

add limited-cursor

File size: 18.0 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  (%queue-unlimited-add! q v)
78  #; ;why bother
79  (let ((newlist (cons v (%queue-unlimited-first-pair q))))
80    (%queue-unlimited-first-pair-set! q newlist)
81    (when (null? (%queue-unlimited-last-pair q))
82      (%queue-unlimited-last-pair-set! q newlist) )
83    (%queue-unlimited-count-add! q 1) ) )
84
85(define-inline (%queue-unlimited-push-back-list! q ls)
86  (for-each (lambda (v) (%queue-unlimited-add! q v)) (reverse ls))
87  #; ;why bother
88  (let ((newlist (append! (list-copy ls) (%queue-unlimited-first-pair q))))
89    (%queue-unlimited-first-pair-set! q newlist)
90    (if (null? newlist)
91      (%queue-unlimited-last-pair-set! q '())
92      (%queue-unlimited-last-pair-set! q (last-pair newlist) ) )
93    (%queue-unlimited-count-add! q (length ls)) ) )
94
95(define-inline (%make-queue-unlimited-cursor) (cons '() #f))
96(define-inline (%queue-unlimited-cursor? c) (pair? c))
97(define-inline (%queue-unlimited-cursor-next-pair c) (car c))
98(define-inline (%queue-unlimited-cursor-next-pair-set! c v) (set-car! c v))
99(define-inline (%queue-unlimited-cursor-prev-pair c) (cdr c))
100(define-inline (%queue-unlimited-cursor-prev-pair-set! c v) (set-cdr! c v))
101
102(define-inline (%queue-unlimited-cursor-winding? q c)
103  (%->boolean (%queue-unlimited-cursor-prev-pair c)) )
104
105(define-inline (%queue-unlimited-cursor-unwound? q c)
106  (null? (%queue-unlimited-cursor-next-pair c)) )
107
108(define-inline (%queue-unlimited-cursor-start! q c)
109  ;(%queue-unlimited-cursor-prev-pair-set! c #f)
110  (%queue-unlimited-cursor-next-pair-set! c (%queue-unlimited-first-pair q)) )
111
112;#!eof | *
113(define-inline (%queue-unlimited-cursor-next! q c)
114  (let ((curr-pair (%queue-unlimited-cursor-next-pair c)))
115    ;anything next?
116    (if (null? curr-pair)
117      #!eof
118      ;then peek into the queue for the next item
119      (let ((item (car curr-pair)))
120        (%queue-unlimited-cursor-prev-pair-set! c curr-pair)
121        (%queue-unlimited-cursor-next-pair-set! c (cdr curr-pair))
122        item ) ) ) )
123
124(define-inline (%queue-unlimited-cursor-continue! q c)
125  ;NOTE assumes 1 next item, so prev-pair is still correct
126  (%queue-unlimited-cursor-next-pair-set! c (%queue-unlimited-last-pair q)) )
127
128(define-inline (%queue-unlimited-cursor-rewind! q c)
129  (%queue-unlimited-cursor-prev-pair-set! c #f)
130  (%queue-unlimited-cursor-next-pair-set! c '()) )
131
132(define-inline (%queue-unlimited-cursor-extract! q c)
133  ;unless 'mailbox-cursor-next' has been called don't remove
134  (and-let* ((prev-pair (%queue-unlimited-cursor-prev-pair c)))
135    (%queue-unlimited-extract-pair! q prev-pair) ) )
136
137;; Queue Limited
138
139;the identifier needs to be defined by somebody
140(define queue-limited 'queue-limited)
141(define-record-type-variant queue-limited (unsafe unchecked inline)
142  (%make-queue-limited vc st ed)
143  (%queue-limited?)
144  (vc %queue-limited-vector %queue-limited-vector-set!)
145  (st %queue-limited-start %queue-limited-start-set!)
146  (ed %queue-limited-end %queue-limited-end-set!) )
147
148(define-inline (%make-empty-queue-limited lm)
149  (%make-queue-limited (make-vector (fx+ lm 1) (void)) 0 0) )
150
151;circular buffer: vec[n] s <= e: s = e -> empty, s < e -> some, |e - s| = n -> full
152;
153; inc i: (i + 1)      mod n
154; dec i: (i + (n-1))  mod n
155
156(define-inline (%queue-limited-peek q i)    (vector-ref (%queue-limited-vector q) i))
157(define-inline (%queue-limited-poke! q i v) (vector-set! (%queue-limited-vector q) i v))
158
159(define-inline (%queue-limited-limit q)
160  (fx- (vector-length (%queue-limited-vector q)) 1) )
161
162(define-inline (%queue-limited-index-inc q i)
163  (fxmod (fx+ i 1) (%queue-limited-limit q)) )
164
165(define-inline (%queue-limited-index-dec q i)
166  (fxmod (fx+ i (fx- (vector-length (%queue-limited-vector q)) 2)) (%queue-limited-limit q)) )
167
168(define-inline (%queue-limited-limit-set! q v)
169  (error '%queue-limited-limit-set! "immutable" v) )
170
171(define-inline (fxabs n) (if (< n 0) (fxneg n) n))
172
173(define-inline (%queue-limited-count q)
174  (fxabs (fx- (%queue-limited-end q) (%queue-limited-start q))) )
175
176(define-inline (%queue-limited-count-set! q v)
177  (error '%queue-limited-count-set! "immutable" v) )
178
179(define-inline (%queue-limited-room q)
180  (fx- (%queue-limited-limit q) (%queue-limited-count q)) )
181
182(define-inline (%queue-limited-empty? q #!optional (n 0))
183  (fx<= (fx- (%queue-limited-count q) n) 0) )
184
185(define-inline (%queue-limited-full? q #!optional (n 0))
186  (fx>= (fx+ (%queue-limited-count q) n) (%queue-limited-limit q)) )
187
188(define-inline (%queue-limited-add! q v)
189  (%queue-limited-poke! q (%queue-limited-end q) v)
190  (%queue-limited-end-set! q (%queue-limited-index-inc q (%queue-limited-end q))) )
191
192(define-inline (%queue-limited-remove! q)
193  (let ((v (%queue-limited-peek q (%queue-limited-start q))))
194    (%queue-limited-start-set! q (%queue-limited-index-inc q (%queue-limited-start q)))
195    v ) )
196
197(define-inline (%queue-limited-push-back! q v)
198  (%queue-limited-add! q v) )
199
200(define-inline (%queue-limited-push-back-list! q ls)
201  (for-each (lambda (v) (%queue-limited-add! q v)) (reverse ls)) )
202
203;index
204(define-inline (%make-queue-limited-cursor) (cons -1 (void)))
205(define-inline (%queue-limited-cursor? c) (pair? c))
206(define-inline (%queue-limited-index c) (car c))
207(define-inline (%queue-limited-index-set! c v) (set-car! c v))
208
209(define-inline (%queue-limited-cursor-winding? q c)
210  (fx<= 0 (%queue-limited-index c)) )
211
212(define-inline (%queue-limited-cursor-unwound? q c)
213  (fx= (%queue-limited-end q) (%queue-limited-index c)) )
214
215(define-inline (%queue-limited-cursor-start! q c)
216  (%queue-limited-index-set! c (%queue-limited-start q)) )
217
218;#!eof | *
219(define-inline (%queue-limited-cursor-next! q c)
220  (cond
221    ((%queue-limited-cursor-unwound? q c)  #!eof)
222    (else
223      (let ((v (%queue-limited-peek q (%queue-limited-index c))))
224        (%queue-limited-index-set! c (%queue-limited-index-inc q (%queue-limited-index c)))
225        v ) ) ) )
226
227(define-inline (%queue-limited-cursor-continue! q c)
228  #; ;assert index is end - 1
229  (%queue-limited-index-set! c (%queue-limited-index-dec q (%queue-limited-end q)))
230  (void) )
231
232(define-inline (%queue-limited-cursor-rewind! q c)
233  (%queue-limited-index-set! c -1) )
234
235(define-inline (%queue-limited-cursor-extract! q c)
236  ;unless 'mailbox-cursor-next' has been called don't remove
237  (when (%queue-limited-cursor-winding? q c)
238    ;move "up" from i-1 to i until i = start
239    (let loop ((i (%queue-limited-index-dec q (%queue-limited-index c))))
240      (let ((i-1 (%queue-limited-index-dec q i)))
241        (%queue-limited-poke! q i (%queue-limited-peek q i-1))
242        (if (fx= (%queue-limited-start q) i-1)
243          (%queue-limited-start-set! q i)
244          (loop i-1) ) ) ) ) )
245
246;; Queue Unbuffered
247
248;the identifier needs to be defined by somebody
249(define queue-unbuffered 'queue-unbuffered)
250(define-record-type-variant queue-unbuffered (unsafe unchecked inline)
251  (%make-queue-unbuffered vd vl)
252  (%queue-unbuffered?)
253  (vd %queue-unbuffered-maybe? %queue-unbuffered-maybe-set!)
254  (vl %queue-unbuffered-value %queue-unbuffered-value-set!) )
255
256(define-inline (%make-empty-queue-unbuffered)
257  (%make-queue-unbuffered #f (void)) )
258
259(define-inline (%queue-unbuffered-limit q) 1)
260
261(define-inline (%queue-unbuffered-limit-set! q v)
262  (error '%queue-unbuffered-limit-set! "immutable" v) )
263
264(define-inline (%queue-unbuffered-count q)
265  (if (%queue-unbuffered-maybe? q) 1 0) )
266
267(define-inline (%queue-unbuffered-count-set! q v)
268  (error '%queue-unbuffered-count-set! "immutable" v) )
269
270(define-inline (%queue-unbuffered-room q)
271  (if (%queue-unbuffered-maybe? q) 0 1) )
272
273(define-inline (%queue-unbuffered-add! q v)
274  (%queue-unbuffered-maybe-set! q #t)
275  (%queue-unbuffered-value-set! q v) )
276
277(define-inline (%queue-unbuffered-remove! q)
278  (let ((v (%queue-unbuffered-value q)))
279    (%queue-unbuffered-maybe-set! q #f)
280    (%queue-unbuffered-value-set! q (void))
281    v ) )
282
283(define-inline (%queue-unbuffered-push-back! q v)
284  (%queue-unbuffered-add! q v) )
285
286(define-inline (%queue-unbuffered-push-back-list! q ls)
287  (for-each (lambda (v) (%queue-unbuffered-add! q v)) (reverse ls)) )
288
289(define-inline (%make-queue-unbuffered-cursor) (cons -1 (void)))
290(define-inline (%queue-unbuffered-cursor? c) (pair? c))
291(define-inline (%queue-unbuffered-index c) (car c))
292(define-inline (%queue-unbuffered-index-set! c v) (set-car! c v))
293
294(define-inline (%queue-unbuffered-cursor-winding? q c)
295  (fx<= 0 (%queue-unbuffered-index c)) )
296
297(define-inline (%queue-unbuffered-cursor-unwound? q c)
298  (fx= 1 (%queue-unbuffered-index c)) )
299
300(define-inline (%queue-unbuffered-cursor-start! q c)
301  (%queue-unbuffered-index-set! c 0) )
302
303;#!eof | *
304(define-inline (%queue-unbuffered-cursor-next! q c)
305  (cond
306    ((%queue-unbuffered-cursor-unwound? q c)  #!eof)
307    ((not (%queue-unbuffered-maybe? q))       #!eof)
308    (else
309      (%queue-unbuffered-index-set! c 1)
310      (%queue-unbuffered-value q) ) ) )
311
312(define-inline (%queue-unbuffered-cursor-continue! q c)
313  (%queue-unbuffered-index-set! c 0) )
314
315(define-inline (%queue-unbuffered-cursor-rewind! q c)
316  (%queue-unbuffered-index-set! c -1) )
317
318(define-inline (%queue-unbuffered-cursor-extract! q c)
319  ;unless 'mailbox-cursor-next' has been called don't remove
320  (when (%queue-unbuffered-cursor-winding? q c)
321    (%queue-unbuffered-maybe-set! q #f) ) )
322
323;; Queue Generic
324
325(define-inline (%valid-queue-limit? lm)
326  (or (boolean? lm) (and (fixnum? lm) (positive? lm))) )
327
328(define-inline (%make-empty-queue lm)
329  ;(assert (%valid-queue-limit? lm))
330  (cond
331    ((not lm)       (%make-empty-queue-unlimited))
332    ((fixnum? lm)   (%make-empty-queue-limited lm))
333    (else           (%make-empty-queue-unbuffered)) ) )
334
335(define-inline (%queue? x)
336  (or
337    (%queue-unlimited? x)
338    (%queue-limited? x)
339    (%queue-unbuffered? x) ) )
340
341(define-inline (%queue-limit q)
342  (cond
343    ((%queue-unlimited? q)  (%queue-unlimited-limit q))
344    ((%queue-limited? q)    (%queue-limited-limit q))
345    (else                   (%queue-unbuffered-limit q)) ) )
346
347(define-inline (%queue-limit-set! q v)
348  (cond
349    ((%queue-unlimited? q)  (%queue-unlimited-limit-set! q v))
350    ((%queue-limited? q)    (%queue-limited-limit-set! q v))
351    (else                   (%queue-unbuffered-limit-set! q v)) ) )
352
353(define-inline (%queue-count q)
354  (cond
355    ((%queue-unlimited? q)  (%queue-unlimited-count q))
356    ((%queue-limited? q)    (%queue-limited-count q))
357    (else                   (%queue-unbuffered-count q)) ) )
358
359(define-inline (%queue-count-set! q v)
360  (cond
361    ((%queue-unlimited? q)  (%queue-unlimited-count-set! q v))
362    ((%queue-limited? q)    (%queue-limited-count-set! q v))
363    (else                   (%queue-unbuffered-count-set! q v)) ) )
364
365(define-inline (%queue-room q)
366  (cond
367    ((%queue-unlimited? q)  (%queue-unlimited-room q))
368    ((%queue-limited? q)    (%queue-limited-room q))
369    (else                   (%queue-unbuffered-room q)) ) )
370
371(define-inline (%queue-empty? q #!optional (n 0))
372  (fx<= (fx- (%queue-count q) n) 0) )
373
374(define-inline (%queue-full? q #!optional (n 0))
375  (fx>= (fx+ (%queue-count q) n) (%queue-limit q)) )
376
377(define (queue-empty-error loc q) (error loc "queue empty" q))
378(define (queue-full-error loc q v) (error loc "queue full" q v))
379
380(define-inline (%queue-add!? q v)
381  (if (%queue-full? q)
382    (values #f (void))
383    (values #t
384      (cond
385        ((%queue-unlimited? q)  (%queue-unlimited-add! q v))
386        ((%queue-limited? q)    (%queue-limited-add! q v))
387        (else                   (%queue-unbuffered-add! q v)))) ) )
388
389(define-inline (%queue-remove!? q)
390  (if (%queue-empty? q)
391    (values #f (void))
392    (values #t
393      (cond
394        ((%queue-unlimited? q)  (%queue-unlimited-remove! q))
395        ((%queue-limited? q)    (%queue-limited-remove! q))
396        (else                   (%queue-unbuffered-remove! q)))) ) )
397
398(define-inline (%queue-push-back!? q v)
399  (if (%queue-full? q)
400    (values #f (void))
401    (values #t
402      (cond
403        ((%queue-unlimited? q)  (%queue-unlimited-push-back! q v))
404        ((%queue-limited? q)    (%queue-limited-push-back! q v))
405        (else                   (%queue-unbuffered-push-back! q v)))) ) )
406
407(define-inline (%queue-push-back-list!? q ls)
408  (if (%queue-full? q (length ls))
409    (values #f (void))
410    (values #t
411      (cond
412        ((%queue-unlimited? q)  (%queue-unlimited-push-back-list! q ls))
413        ((%queue-limited? q)    (%queue-limited-push-back-list! q ls))
414        (else                   (%queue-unbuffered-push-back-list! q ls)))) ) )
415
416(define-inline (%queue-add! q v
417                  #!optional
418                  (on-full (lambda () (queue-full-error '%queue-add! q v))))
419  (let loop ()
420    (let-values (((succ? val) (%queue-add!? q v)))
421      (unless succ?
422        (on-full)
423        (loop) )
424      val ) ) )
425
426(define-inline (%queue-remove! q
427                  #!optional
428                  (on-empty (lambda () (queue-empty-error '%queue-remove! q))))
429  (let loop ()
430    (let-values (((succ? val) (%queue-remove!? q)))
431      (unless succ?
432        (on-empty)
433        (loop) )
434      val ) ) )
435
436(define-inline (%queue-push-back! q v
437                  #!optional
438                  (on-full (lambda () (queue-full-error '%queue-push-back! q v))))
439  (let loop ()
440    (let-values (((succ? val) (%queue-push-back!? q v)))
441      (unless succ?
442        (on-full)
443        (loop) )
444      val ) ) )
445
446(define-inline (%queue-push-back-list! q ls
447                  #!optional
448                  (on-full (lambda () (queue-full-error '%queue-push-back-list! q ls))))
449  (let loop ()
450    (let-values (((succ? val) (%queue-push-back-list!? q ls)))
451      (unless succ?
452        (on-full)
453        (loop) )
454      val ) ) )
455
456(define-inline (%make-queue-cursor q)
457  (cond
458    ((%queue-unlimited? q)  (%make-queue-unlimited-cursor))
459    ((%queue-limited? q)    (%make-queue-limited-cursor))
460    (else                   (%make-queue-unbuffered-cursor)) ) )
461
462(define-inline (%queue-cursor-winding? q c)
463  (cond
464    ((%queue-unlimited? q)  (%queue-unlimited-cursor-winding? q c))
465    ((%queue-limited? q)    (%queue-limited-cursor-winding? q c))
466    (else                   (%queue-unbuffered-cursor-winding? q c)) ) )
467
468(define-inline (%queue-cursor-unwound? q c)
469  (cond
470    ((%queue-unlimited? q)  (%queue-unlimited-cursor-unwound? q c))
471    ((%queue-limited? q)    (%queue-limited-cursor-unwound? q c))
472    (else                   (%queue-unbuffered-cursor-unwound? q c)) ) )
473
474(define-inline (%queue-cursor-rewind! q c)
475  (cond
476    ((%queue-unlimited? q)  (%queue-unlimited-cursor-rewind! q c))
477    ((%queue-limited? q)    (%queue-limited-cursor-rewind! q c))
478    (else                   (%queue-unbuffered-cursor-rewind! q c)) ) )
479
480(define-inline (%queue-cursor-start! q c)
481  (cond
482    ((%queue-unlimited? q)  (%queue-unlimited-cursor-start! q c))
483    ((%queue-limited? q)    (%queue-limited-cursor-start! q c))
484    (else                   (%queue-unbuffered-cursor-start! q c)) ))
485
486;#!eof | *
487(define-inline (%queue-cursor-next! q c)
488 (cond
489    ((%queue-unlimited? q)  (%queue-unlimited-cursor-next! q c))
490    ((%queue-limited? q)    (%queue-limited-cursor-next! q c))
491    (else                   (%queue-unbuffered-cursor-next! q c)) ))
492
493(define-inline (%queue-cursor-continue! q c)
494 (cond
495    ((%queue-unlimited? q)  (%queue-unlimited-cursor-continue! q c))
496    ((%queue-limited? q)    (%queue-limited-cursor-continue! q c))
497    (else                   (%queue-unbuffered-cursor-continue! q c)) ))
498
499(define-inline (%queue-cursor-extract! q c)
500  (cond
501    ((%queue-unlimited? q)  (%queue-unlimited-cursor-extract! q c))
502    ((%queue-limited? q)    (%queue-limited-cursor-extract! q c))
503    (else                   (%queue-unbuffered-cursor-extract! q c)) ) )
Note: See TracBrowser for help on using the repository browser.