ca5634fac28bd1e07ec63d750a229783c6aab4ec
[sam.git] / fifo.scm
1 ;;; A basic FIFO queue module.
2 ;;;
3
4 (module fifo
5     (make-fifo
6      fifo-push
7      fifo-pop
8      fifo-empty?
9      fifo->list)
10
11   (import scheme
12           (chicken base))
13
14   (define (make-fifo)
15     (define (cell val prev next)
16       (list val prev next))
17     (define cell-val car)
18     (define cell-prev cadr)
19     (define cell-next caddr)
20     (define (set-cell-prev! cell prev-cell)
21       (set-car! (cdr cell) prev-cell))
22     (define (set-cell-next! cell next-cell)
23       (set-car! (cddr cell) next-cell))
24
25     (let ((head '())
26           (tail '()))
27       (lambda (cmd . args)
28         (case cmd
29           ((push)
30            (if (not (null? head))
31                (let ((old-head head))
32                  (set! head (cell (car args) '() old-head))
33                  (set-cell-prev! old-head head))
34                (begin
35                  ;; Initialize list
36                  (set! head (cell (car args) '() '()))
37                  (set! tail head))))
38           ((pop)
39            (let ((old-tail tail))
40              (set! tail (cell-prev old-tail))
41              (if (null? tail)
42                  (set! head '())
43                  (set-cell-next! tail '()))
44              (cell-val old-tail)))
45           ((empty?) (null? head))
46           ((->list)
47            (let loop ((this-cell head))
48              (if (null? this-cell)
49                  '()
50                  (cons (cell-val this-cell)
51                        (loop (cell-next this-cell))))))))))
52   
53   (define (fifo-push fifo x)
54     (fifo 'push x))
55
56   (define (fifo-pop fifo)
57     (fifo 'pop))
58
59   (define (fifo-empty? fifo)
60     (fifo 'empty?))
61
62   (define (fifo->list fifo)
63     (fifo '->list)))