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

Last change on this file since 36012 was 36012, checked in by Kon Lovett, 15 months ago

C5 initial

File size: 2.2 KB
Line 
1;;;; inline-queue.scm
2;;;; Kon Lovett, Jun '10
3
4;;; Requires (include "chicken-primitive-object-inlines")
5
6;; Support
7
8(define-record-type-variant queue (unsafe unchecked inline)
9  (%%make-queue hd tl)
10  %queue?
11  (hd %queue-first-pair %queue-first-pair-set!)
12  (tl %queue-last-pair %queue-last-pair-set!) )
13
14(define-inline (%make-queue) (%%make-queue '() '()))
15
16(define-inline (%queue-empty? q) ($null? (%queue-first-pair q)))
17(define-inline (%queue-count q) ($length (%queue-first-pair q)))
18
19;; Operations
20
21(define-inline (%queue-last-pair-empty! q) (%queue-last-pair-set! q '()))
22
23(define-inline (%queue-add! q datum)
24  (let ((new-pair ($cons datum '())))
25    (if ($null? (%queue-first-pair q)) (%queue-first-pair-set! q new-pair)
26        ($set-cdr! (%queue-last-pair q) new-pair) )
27    (%queue-last-pair-set! q new-pair) ) )
28
29(define-inline (%queue-remove! q)
30  (let* ((first-pair (%queue-first-pair q))
31         (next-pair ($cdr first-pair)))
32    (%queue-first-pair-set! q next-pair)
33    (when ($null? next-pair) (%queue-last-pair-empty! q) )
34    ($car first-pair) ) )
35
36(define-inline (%queue-push-back! q item)
37  (let ((newlist ($cons item (%queue-first-pair q))))
38    (%queue-first-pair-set! q newlist)
39    (when ($null? (%queue-last-pair q)) (%queue-last-pair-set! q newlist) ) ) )
40
41(define-inline (%queue-push-back-list! q itemlist)
42  (let ((newlist ($append! ($list-copy itemlist) (%queue-first-pair q))))
43    (%queue-first-pair-set! q newlist)
44    (if ($null? newlist) (%queue-last-pair-empty! q)
45        (%queue-last-pair-set! q ($last-pair newlist) ) ) ) )
46
47(define-inline (%queue-extract-pair! q targ-pair)
48  ; Scan queue list until we find the item to remove
49  (let scanning ((this-pair (%queue-first-pair q)) (prev-pair '()))
50    ; Keep scanning until found
51    (if (not ($eq? this-pair targ-pair)) (scanning ($cdr this-pair) this-pair)
52        ;found so cut out the pair
53        (let ((next-pair ($cdr this-pair)))
54          ; At the head of the list, or in the body?
55          (if ($null? prev-pair) (%queue-first-pair-set! q next-pair)
56              ($set-cdr! prev-pair next-pair) )
57          ; When the cut pair is the last item update the last pair ref.
58          (when ($eq? this-pair (%queue-last-pair q)) (%queue-last-pair-set! q prev-pair)) ) ) ) )
Note: See TracBrowser for help on using the repository browser.