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

Last change on this file since 39733 was 39733, checked in by Kon Lovett, 3 months ago

set limited-cursor in cont

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