fifo.scm

   1 (module fifo
   2     (make-fifo
   3      fifo-push
   4      fifo-pop
   5      fifo-empty?
   6      fifo->list)
   7
   8   (import scheme
   9           (chicken base)
  10           srfi-18)
  11
  12   (define (make-fifo)
  13     (define (cell val prev next)
  14       (list val prev next))
  15     (define cell-val car)
  16     (define cell-prev cadr)
  17     (define cell-next caddr)
  18     (define (set-cell-prev! cell prev-cell)
  19       (set-car! (cdr cell) prev-cell))
  20     (define (set-cell-next! cell next-cell)
  21       (set-car! (cddr cell) next-cell))
  22
  23     (let ((head '())
  24           (tail '())
  25           (pop-mutex (make-mutex)))
  26       (mutex-lock! pop-mutex #f #f)
  27       (lambda (cmd . args)
  28         (case cmd
  29           ((empty?) (null? head))
  30           ((push)
  31            (if (not (null? head))
  32                (let ((old-head head))
  33                  (set! head (cell (car args) '() old-head))
  34                  (set-cell-prev! old-head head))
  35                (begin
  36                  ;; Initialize list
  37                  (set! head (cell (car args) '() '()))
  38                  (set! tail head)
  39                  (mutex-unlock! pop-mutex))))
  40           ((pop)
  41            (mutex-lock! pop-mutex #f #f)
  42            (if (null? head)
  43                (error "FIFO empty.")
  44                (let ((old-tail tail))
  45                  (set! tail (cell-prev old-tail))
  46                  (if (null? tail)
  47                      (set! head '())
  48                      (begin
  49                        (set-cell-next! tail '())
  50                        (mutex-unlock! pop-mutex #f #f)))
  51                  (cell-val old-tail)))))
  52         ((->list) (if (not (= (length args) 0))
  53                       (error "Wrong number of arguments to ->list.")
  54                       (let loop ((this-cell head))
  55                         (if (null? this-cell)
  56                             '()
  57                             (cons (cell-val this-cell)
  58                                   (loop (cell-next this-cell))))))))))
  59
  60
  61   (define (fifo-push fifo x)
  62     (fifo 'push x))
  63
  64   (define (fifo-pop fifo)
  65     (fifo 'pop))
  66
  67   (define (fifo-empty? fifo)
  68     (fifo 'empty?))
  69
  70   (define (fifo->list fifo)
  71     (fifo '->list)))