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

Last change on this file since 39717 was 39717, checked in by Kon Lovett, 5 months ago

queue depth limit by type (wip)

File size: 4.6 KB
Line 
1;;;; inline-queue.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jun '10
3
4;; Issues
5;;
6;; - Requires (only record-variants define-record-type-variant)
7;; & (include "chicken-primitive-object-inlines")
8
9;; Support
10
11;;
12
13(define-constant QUEUE-UNLIMITED -1)
14(define-constant QUEUE-UNBUFFERED 0)
15
16;the identifier needs to be defined by somebody
17(define queue 'queue)
18(define-record-type-variant queue (unsafe unchecked inline)
19  (%make-queue lm ln hd tl)
20  (%queue?)
21  (lm %queue-limit %queue-limit-set!)
22  (ln %queue-count %queue-count-set!)
23  (hd %queue-first-pair %queue-first-pair-set!)
24  (tl %queue-last-pair %queue-last-pair-set!) )
25
26(define-inline (%make-queue-limited lm) (%make-queue lm 0 '() '()))
27(define-inline (%make-queue-unlimited)  (%make-queue-limited QUEUE-UNLIMITED))
28(define-inline (%make-queue-unbuffered) (%make-queue-limited QUEUE-UNBUFFERED))
29
30(define-inline (%queue-unlimited? q)  (fx= QUEUE-UNLIMITED (%queue-limit q)) )
31(define-inline (%queue-unbuffered? q) (fx= QUEUE-UNBUFFERED (%queue-limit q)) )
32(define-inline (%queue-limited? q)    (not (or (%queue-unbuffered? q) (%queue-unlimited? q))) )
33
34(define-inline (%make-limited-queue lm)
35  (cond
36    ((not lm)       (%make-queue-unlimited))
37    ((boolean? lm)  (%make-queue-unbuffered))
38    ((fixnum? lm)   (%make-queue-limited lm))
39    (else
40      (error '%make-limited-queue "invalid limit" lm))) )
41
42;nominal `size' of the queue, not literal
43(define-inline (%queue-size q)
44  (cond
45    ((%queue-unbuffered? q) 0)
46    ((%queue-unlimited? q)  most-positive-fixnum)
47    (else                   (%queue-limit q)) ) )
48
49(define-inline (%queue-empty? q)  (fx= (%queue-count q) 0))
50(define-inline (%queue-full? q)   (fx>= (%queue-count q) (%queue-size q)))
51
52(define-inline (%queue-limited-room q)
53  (if (%queue-unbuffered? q)
54    (if (fx= 0 (%queue-count q)) 1 0)
55    (fx- (%queue-limit q) (%queue-count q)) ) )
56
57(define-inline (%queue-room q)
58  (if (%queue-unlimited? q)
59    most-positive-fixnum
60    (%queue-limited-room q) ) )
61
62(define-inline (%queue-room? q rq) (fx<= rq (%queue-room q)))
63
64(define-inline (%queue-count-inc! q) (%queue-count-set! q (fx+ 1 (%queue-count q))))
65(define-inline (%queue-count-dec! q) (%queue-count-set! q (fx- 1 (%queue-count q))))
66
67;; Operations
68
69(define-inline (%queue-add! q item)
70  (if (%queue-full? q)
71    (error '%queue-add! "queue full")
72    (let ((new-pair (cons item '())))
73      (if (null? (%queue-first-pair q))
74        (%queue-first-pair-set! q new-pair)
75        (set-cdr! (%queue-last-pair q) new-pair) )
76      (%queue-last-pair-set! q new-pair)
77      (%queue-count-inc! q) ) ) )
78
79(define-inline (%queue-remove! q)
80  (if (%queue-empty? q)
81    (error '%queue-remove! "queue empty")
82    (let* ((first-pair (%queue-first-pair q))
83           (next-pair (cdr first-pair)))
84      (%queue-first-pair-set! q next-pair)
85      (when (null? next-pair) (%queue-last-pair-set! q '()))
86      (%queue-count-dec! q)
87      (car first-pair) ) ) )
88
89(define-inline (%queue-push-back! q item)
90  (if (%queue-full? q)
91    (error '%queue-push-back! "queue full")
92    (let ((newlist (cons item (%queue-first-pair q))))
93      (%queue-first-pair-set! q newlist)
94      (when (null? (%queue-last-pair q)) (%queue-last-pair-set! q newlist) )
95      (%queue-count-inc! q) ) ) )
96
97(define-inline (%queue-push-back-list! q itemlist)
98  (if (not (%queue-room? q (length itemlist)))
99    (error '%queue-push-back-list! "queue short" (%queue-limited-room q))
100    (let ((newlist (append! (list-copy itemlist) (%queue-first-pair q))))
101      (%queue-first-pair-set! q newlist)
102      (if (null? newlist)
103        (%queue-last-pair-set! q '())
104        (%queue-last-pair-set! q (last-pair newlist) ) )
105      (%queue-count-set! q (+ (length itemlist) (%queue-count q))) ) ) )
106
107(define-inline (%queue-extract-pair! q targ-pair)
108  ;scan queue list until we find the item to remove
109  (let scanning ((this-pair (%queue-first-pair q)) (prev-pair '()))
110    ;keep scanning until found
111    (cond
112      ;should not happen but no infinite loops
113      ((null? this-pair)
114        ;note that the pair to extract is in fact gone so ...
115        (error "cannot find queue pair to extract; simultaneous operations?"))
116      ;found?
117      ((eq? this-pair targ-pair)
118        ;so cut out the pair
119        (let ((next-pair (cdr this-pair)))
120          ;at the head of the list, or in the body?
121          (if (null? prev-pair)
122            (%queue-first-pair-set! q next-pair)
123            (set-cdr! prev-pair next-pair) )
124          ;when the cut pair is the last item update the last pair ref.
125          (when (eq? this-pair (%queue-last-pair q)) (%queue-last-pair-set! q prev-pair))
126          (%queue-count-dec! q) ) )
127      ;not found
128      (else
129        (scanning (cdr this-pair) this-pair) ) ) ) )
Note: See TracBrowser for help on using the repository browser.