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

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

queue keeps explicit count

File size: 3.0 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 ln hd tl)
17  (%queue?)
18  (ln %queue-count %queue-count-set!)
19  (hd %queue-first-pair %queue-first-pair-set!)
20  (tl %queue-last-pair %queue-last-pair-set!) )
21
22(define-inline (%queue-count-inc! q) (%queue-count-set! q (add1 (%queue-count q))))
23(define-inline (%queue-count-dec! q) (%queue-count-set! q (sub1 (%queue-count q))))
24
25(define-inline (%make-empty-queue) (%make-queue 0 '() '()))
26
27(define-inline (%queue-empty? q) (zero? (%queue-count q)))
28
29;; Operations
30
31(define-inline (%queue-last-pair-empty! q) (%queue-last-pair-set! q '()))
32
33(define-inline (%queue-add! q datum)
34  (let ((new-pair (cons datum '())))
35    (if (null? (%queue-first-pair q))
36      (%queue-first-pair-set! q new-pair)
37      (set-cdr! (%queue-last-pair q) new-pair) )
38    (%queue-last-pair-set! q new-pair) )
39  (%queue-count-inc! q) )
40
41(define-inline (%queue-remove! q)
42  (let* ((first-pair (%queue-first-pair q))
43         (next-pair (cdr first-pair)))
44    (%queue-first-pair-set! q next-pair)
45    (when (null? next-pair) (%queue-last-pair-empty! q))
46    (%queue-count-dec! q)
47    (car first-pair) ) )
48
49(define-inline (%queue-push-back! q item)
50  (let ((newlist (cons item (%queue-first-pair q))))
51    (%queue-first-pair-set! q newlist)
52    (when (null? (%queue-last-pair q)) (%queue-last-pair-set! q newlist) ) )
53  (%queue-count-inc! q) )
54
55(define-inline (%queue-push-back-list! q itemlist)
56  (let ((newlist (append! (list-copy itemlist) (%queue-first-pair q))))
57    (%queue-first-pair-set! q newlist)
58    (if (null? newlist)
59      (%queue-last-pair-empty! q)
60      (%queue-last-pair-set! q (last-pair newlist) ) ) )
61  (%queue-count-set! q (+ (length itemlist) (%queue-count q))) )
62
63(define-inline (%queue-extract-pair! q targ-pair)
64  ;scan queue list until we find the item to remove
65  (let scanning ((this-pair (%queue-first-pair q)) (prev-pair '()))
66    ;keep scanning until found
67    (cond
68      ;should not happen but no infinite loops
69      ((null? this-pair)
70        ;note that the pair to extract is in fact gone so ...
71        (warning "cannot find queue pair to extract; simultaneous operations?"))
72      ;found?
73      ((eq? this-pair targ-pair)
74        ;so cut out the pair
75        (let ((next-pair (cdr this-pair)))
76          ;at the head of the list, or in the body?
77          (if (null? prev-pair)
78            (%queue-first-pair-set! q next-pair)
79            (set-cdr! prev-pair next-pair) )
80          ;when the cut pair is the last item update the last pair ref.
81          (when (eq? this-pair (%queue-last-pair q))
82            (%queue-last-pair-set! q prev-pair)) )
83        (%queue-count-dec! q) )
84      ;not found
85      (else
86        (scanning (cdr this-pair) this-pair) ) ) ) )
Note: See TracBrowser for help on using the repository browser.