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

Last change on this file since 36562 was 36562, checked in by kon, 10 months ago

remove condition-utils & check-errors dependencies

File size: 2.3 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-record-type-variant queue (unsafe unchecked inline)
14  (%%make-queue hd tl)
15  %queue?
16  (hd %queue-first-pair %queue-first-pair-set!)
17  (tl %queue-last-pair %queue-last-pair-set!) )
18
19(define-inline (%make-queue) (%%make-queue '() '()))
20
21(define-inline (%queue-empty? q) ($null? (%queue-first-pair q)))
22(define-inline (%queue-count q) ($length (%queue-first-pair q)))
23
24;; Operations
25
26(define-inline (%queue-last-pair-empty! q) (%queue-last-pair-set! q '()))
27
28(define-inline (%queue-add! q datum)
29  (let ((new-pair ($cons datum '())))
30    (if ($null? (%queue-first-pair q))
31      (%queue-first-pair-set! q new-pair)
32      ($set-cdr! (%queue-last-pair q) new-pair) )
33    (%queue-last-pair-set! q new-pair) ) )
34
35(define-inline (%queue-remove! q)
36  (let* ((first-pair (%queue-first-pair q))
37         (next-pair ($cdr first-pair)))
38    (%queue-first-pair-set! q next-pair)
39    (when ($null? next-pair) (%queue-last-pair-empty! q) )
40    ($car first-pair) ) )
41
42(define-inline (%queue-push-back! q item)
43  (let ((newlist ($cons item (%queue-first-pair q))))
44    (%queue-first-pair-set! q newlist)
45    (when ($null? (%queue-last-pair q)) (%queue-last-pair-set! q newlist) ) ) )
46
47(define-inline (%queue-push-back-list! q itemlist)
48  (let ((newlist ($append! ($list-copy itemlist) (%queue-first-pair q))))
49    (%queue-first-pair-set! q newlist)
50    (if ($null? newlist)
51      (%queue-last-pair-empty! q)
52      (%queue-last-pair-set! q ($last-pair newlist) ) ) ) )
53
54(define-inline (%queue-extract-pair! q targ-pair)
55  ;scan queue list until we find the item to remove
56  (let scanning ((this-pair (%queue-first-pair q)) (prev-pair '()))
57    ;keep scanning until found
58    (if (not ($eq? this-pair targ-pair))
59      ;not found
60      (scanning ($cdr this-pair) this-pair)
61      ;found so cut out the pair
62      (let ((next-pair ($cdr this-pair)))
63        ;at the head of the list, or in the body?
64        (if ($null? prev-pair)
65          (%queue-first-pair-set! q next-pair)
66          ($set-cdr! prev-pair next-pair) )
67        ;when the cut pair is the last item update the last pair ref.
68        (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.