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

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

canon naming

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