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

Last change on this file since 37684 was 37684, checked in by Kon Lovett, 2 years ago

fix tag identifier

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