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
  11   (define (make-fifo)
  12     (define (cell val prev next)
  13       (list val prev next))
  14     (define cell-val car)
  15     (define cell-prev cadr)
  16     (define cell-next caddr)
  17     (define (set-cell-prev! cell prev-cell)
  18       (set-car! (cdr cell) prev-cell))
  19     (define (set-cell-next! cell next-cell)
  20       (set-car! (cddr cell) next-cell))
  21
  22     (let ((head '())
  23           (tail '()))
  24       (lambda (cmd . args)
  25         (case cmd
  26           ((push)
  27            (if (not (null? head))
  28                (let ((old-head head))
  29                  (set! head (cell (car args) '() old-head))
  30                  (set-cell-prev! old-head head))
  31                (begin
  32                  ;; Initialize list
  33                  (set! head (cell (car args) '() '()))
  34                  (set! tail head))))
  35           ((pop)
  36            (let ((old-tail tail))
  37              (set! tail (cell-prev old-tail))
  38              (if (null? tail)
  39                  (set! head '())
  40                  (set-cell-next! tail '()))
  41              (cell-val old-tail)))
  42           ((empty?) (null? head))
  43           ((->list)
  44            (let loop ((this-cell head))
  45              (if (null? this-cell)
  46                  '()
  47                  (cons (cell-val this-cell)
  48                        (loop (cell-next this-cell))))))))))
  49
  50   (define (fifo-push fifo x)
  51     (fifo 'push x))
  52
  53   (define (fifo-pop fifo)
  54     (fifo 'pop))
  55
  56   (define (fifo-empty? fifo)
  57     (fifo 'empty?))
  58
  59   (define (fifo->list fifo)
  60     (fifo '->list)))