(module fifo mzscheme
	(provide fifo
		 fifo?
		 empty-fifo!
		 fifo-empty?
		 fifo+
		 fifo-)

;FIFO functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;=head1 FIFO
;;;
;;;This module gives an implementation of a thread safe
;;;First In First Out queue. It is based upon the
;;;L<SICP|http://mitpress.mit.edu/sicp/full-text/book/book-Z-H-22.html#%_sec_3.3.2>
;;;implementation of a FIFO, but its setup is a littlebit different.
;;;Where the SICP implementation is based on a pair of pairs,
;;;this implementation uses a vector to get the same behaviour.
;;;The vector consists of a list and a pairs, where the pair points
;;;to the last element of the list. The rest of the vector elements
;;;represent semaphores. The first semaphore is used to implement
;;;a critical section. The second semaphore is used to implement
;;;a producer/consumer queue. The producer increases the semaphore
;;;for each new element in the queue. The consumer decreases the
;;;semaphore for each element taken from the queue. If the semaphore
;;;becomes 0, a consumer will block.
;;;
;;;=head2 Supportive macros
;;;
;;;These macros are not explained.
;;;
;;;=verbatim scm,8
(define-struct fifo-type (last-element lst sem depth)) 

(define-syntax last-fifo-element
  (syntax-rules ()
    ((_ fifo)
     (fifo-type-last-element fifo))))

(define-syntax last-fifo-element-set!
  (syntax-rules ()
    ((_ fifo item)
     (set-fifo-type-last-element! fifo item))))

(define-syntax fifo-list
  (syntax-rules ()
    ((_ fifo)
     (fifo-type-lst fifo))))

(define-syntax fifo-list-set!
  (syntax-rules ()
    ((_ fifo item)
     (set-fifo-type-lst! fifo item))))

(define-syntax protect
  (syntax-rules ()
    ((_ fifo body1 ...)
     (begin
       (semaphore-wait (fifo-type-sem fifo))
       (let ((result (begin
                       body1 ...)))
	 (semaphore-post (fifo-type-sem fifo))
         result)))))

(define-syntax inc-fifo-depth
  (syntax-rules ()
    ((_ fifo)
     (semaphore-post (fifo-type-depth fifo)))))

(define-syntax dec-fifo-depth
  (syntax-rules ()
    ((_ fifo)
     (semaphore-wait (fifo-type-depth fifo)))))
;;;=verbatim
;;;
;;;=head2 Interface
;;;
;;;=head3 C<(fifo-empty? fifo) : boolean>
;;;
;;;Returns #t, if fifo is empty, #f, otherwise.
;;;
;;;=verbatim scm,8
(define (fifo-empty? F)
  (null? (fifo-list F)))
;;;=verbatim
;;;
;;;=head3 C<(fifo+ fifo element) : fifo>
;;;
;;;Inserts a new element in the fifo. Returns fifo,
;;;but also alters the existing fifo.
;;;
;;;=verbatim scm,8
(define (fifo+ F element)
  (let ((item (cons element '())))
    (protect F
	     (inc-fifo-depth F)
	     (if (fifo-empty? F)
		 (begin
		   (fifo-list-set! F item)
		   (last-fifo-element-set! F item))
		 (begin
		   (set-cdr! (last-fifo-element F) item)
		   (last-fifo-element-set! F (cdr (last-fifo-element F))))))
    F))
;;;=verbatim
;;;
;;;=head3 C<(fifo- fifo) : scheme-object>
;;;
;;;Blocks if (fifo-empty?) is #t, until fifo+ is used
;;;to insert a new element. Takes an element from the
;;;fifo and returns it.
;;;
;;;=verbatim scm,8
(define (fifo- F)
  (dec-fifo-depth F)
  (protect F
	   (let ((element (car (fifo-list F))))
	     (fifo-list-set! F (cdr (fifo-list F)))
	     element)))
;;;=verbatim
;;;
;;;=head3 C<(fifo . elements) : fifo>
;;;
;;;Returns a new fifo, filled with all given arguments (elements).
;;;
;;;=verbatim scm,8
(define (fifo . elements)
  (let ((F (make-fifo-type (list) (list) (make-semaphore 1) (make-semaphore 0))))
  ;;;(let ((F (vector (list) (list) (make-semaphore 1) (make-semaphore 0) 'fifo)))
    (for-each
     (lambda (element)
       (fifo+ F element))
     elements)
    F))
;;;=verbatim
;;;
;;;=head3 C<(empty-fifo! fifo) : fifo>
;;;
;;;Empties fifo, i.e. removes all elements from fifo.
;;;This function actually creates a new fifo, and copies
;;;the vector elements to the existing fifo.
;;;
;;;=verbatim scm,8
(define (empty-fifo! F)
  (let ((F1 (fifo)))
    (last-fifo-element-set! F (last-fifo-element F1))
    (fifo-list-set! F (fifo-list F1))
    (set-fifo-type-sem! F (fifo-type-sem F1))
    (set-fifo-type-depth! F (fifo-type-depth F1))
    F))
;;;=verbatim
;;;
;;;=head3 C<(fifo? obj) : boolean>
;;;
;;;Determines if obj is a fifo. Returns #t if it does so,
;;;returns #f, otherwise. Note: All fifos are vectors.
;;;
;;;=verbatim scm,8
(define (fifo? F)
  (fifo-type? F))
;;;=verbatim
;;;
;;;=head2 Info
;;;
;;;S<C<Author(s):>> Hans Oesterholt-Dijkema (hansatelementalprogrammingdotorgextension).E<lb>
;;;S<C<Copyright:>> (c) 2005.E<lb>
;;;S<C<License  :>> L<Elemental Programming License|http://www.elemental-programming.org/epwiki/ep_license.html>.E<lb>
;;;S<C<File     :>> fifo.scm $Revision: 1.2 $
;;;
;;;=cut

)