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

Last change on this file since 39716 was 39716, checked in by Kon Lovett, 7 months ago

queue depth limit (wip)

File size: 3.9 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;the identifier needs to be defined by somebody
14(define queue 'queue)
15(define-record-type-variant queue (unsafe unchecked inline)
16  (%make-queue lm ln hd tl)
17  (%queue?)
18  (lm %queue-limit %queue-limit-set!)
19  (ln %queue-count %queue-count-set!)
20  (hd %queue-first-pair %queue-first-pair-set!)
21  (tl %queue-last-pair %queue-last-pair-set!) )
22
23(define-constant QUEUE-UNLIMITED -1)
24(define-constant QUEUE-UNBUFFERED 0)
25
26(define-inline (%queue-count-inc! q) (%queue-count-set! q (fx+ 1 (%queue-count q))))
27(define-inline (%queue-count-dec! q) (%queue-count-set! q (fx- 1 (%queue-count q))))
28
29(define-inline (%make-empty-queue #!optional (lm QUEUE-UNLIMITED))
30  (%make-queue lm 0 '() '()) )
31
32(define-inline (%queue-room q)
33  (fx- (%queue-limit q) (%queue-count q)) )
34
35(define-inline (%queue-full? q)
36  (and
37    (not (fx= QUEUE-UNLIMITED (%queue-limit q)))
38    (if (fx= QUEUE-UNBUFFERED (%queue-limit q))
39      (fx= (%queue-count q) 1)
40      (fx= (%queue-count q) (%queue-limit q)) ) ) )
41
42(define-inline (%queue-room? q rq)
43  (or
44    (fx= QUEUE-UNLIMITED (%queue-limit q))
45    (if (fx= QUEUE-UNBUFFERED (%queue-limit q))
46      (and (fx= (%queue-count q) 0) (fx= rq 1))
47      (fx<= rq (%queue-room q)) ) ) )
48
49(define-inline (%queue-empty? q)
50  (fx= 0 (%queue-count q)) )
51
52;; Operations
53
54(define-inline (%queue-add! q item)
55  (if (%queue-full? q)
56    (warning 'queue-add! "queue full")
57    (let ((new-pair (cons item '())))
58      (if (null? (%queue-first-pair q))
59        (%queue-first-pair-set! q new-pair)
60        (set-cdr! (%queue-last-pair q) new-pair) )
61      (%queue-last-pair-set! q new-pair)
62      (%queue-count-inc! q) ) ) )
63
64(define-inline (%queue-remove! q)
65  (if (%queue-empty? q)
66    (warning 'queue-remove! "queue empty")
67    (let* ((first-pair (%queue-first-pair q))
68           (next-pair (cdr first-pair)))
69      (%queue-first-pair-set! q next-pair)
70      (when (null? next-pair) (%queue-last-pair-set! q '()))
71      (%queue-count-dec! q)
72      (car first-pair) ) ) )
73
74(define-inline (%queue-push-back! q item)
75  (if (%queue-full? q)
76    (warning 'queue-push-back! "queue full")
77    (let ((newlist (cons item (%queue-first-pair q))))
78      (%queue-first-pair-set! q newlist)
79      (when (null? (%queue-last-pair q)) (%queue-last-pair-set! q newlist) )
80      (%queue-count-inc! q) ) ) )
81
82(define-inline (%queue-push-back-list! q itemlist)
83  (if (not (%queue-room? q (length itemlist)))
84    (warning 'queue-push-back-list! "queue short" (%queue-room q))
85    (let ((newlist (append! (list-copy itemlist) (%queue-first-pair q))))
86      (%queue-first-pair-set! q newlist)
87      (if (null? newlist)
88        (%queue-last-pair-set! q '())
89        (%queue-last-pair-set! q (last-pair newlist) ) )
90      (%queue-count-set! q (+ (length itemlist) (%queue-count q))) ) ) )
91
92(define-inline (%queue-extract-pair! q targ-pair)
93  ;scan queue list until we find the item to remove
94  (let scanning ((this-pair (%queue-first-pair q)) (prev-pair '()))
95    ;keep scanning until found
96    (cond
97      ;should not happen but no infinite loops
98      ((null? this-pair)
99        ;note that the pair to extract is in fact gone so ...
100        (warning "cannot find queue pair to extract; simultaneous operations?"))
101      ;found?
102      ((eq? this-pair targ-pair)
103        ;so cut out the pair
104        (let ((next-pair (cdr this-pair)))
105          ;at the head of the list, or in the body?
106          (if (null? prev-pair)
107            (%queue-first-pair-set! q next-pair)
108            (set-cdr! prev-pair next-pair) )
109          ;when the cut pair is the last item update the last pair ref.
110          (when (eq? this-pair (%queue-last-pair q)) (%queue-last-pair-set! q prev-pair))
111          (%queue-count-dec! q) ) )
112      ;not found
113      (else
114        (scanning (cdr this-pair) this-pair) ) ) ) )
Note: See TracBrowser for help on using the repository browser.