fifo.scm

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