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)))