; ----------------------
; --- Semaphore-Lock ---
; ----------------------

; Semaphore-locks for a DNS-Server based on the RFCs: 1034 / 1035

; This file is part of the Scheme Untergrund Networking package

; Copyright (c) 2005/2006 by Norbert Freudemann 
;                            <nofreude@informatik.uni-tuebingen.de>
; For copyright information, see the file COPYING which comes with
; the distribution.

; Wait on the semaphore-lock if the semaphore-counter reaches 0

; Interface:

; (make-semaphore initial-value)

; (set-semaphore! new-value)

; (semaphore-post semaphore)

; (semaphore-wait semaphore)


(define-record-type semaphore :semaphore
  (really-make-semaphore value i waiting-list mutex-lock)
  semaphore?
  (value get-semaphore-value set-semaphore-value!)
  (i get-semaphore-counter set-semaphore-counter!)
  (waiting-list get-semaphore-waiting set-semaphore-waiting!)
  (mutex-lock get-semaphore-lock))

(define (make-semaphore i)
  (really-make-semaphore i i '() (make-lock)))

;; Reset the internal semaphore-counter.
(define (set-semaphore! sem new-value)
  (if (semaphore? sem)
      (begin
	(obtain-lock (get-semaphore-lock sem))
	(let* ((old-value (get-semaphore-value sem))
	       (diff (- new-value old-value)))
	  (set-semaphore-value! sem new-value)
	  (set-semaphore-counter! sem (+ (get-semaphore-counter sem) diff))
	  (release-lock (get-semaphore-lock sem))))
      (error "Not a semaphore.")))
  

;; Release a lock, if one is held or add 1 to the counter.
(define (semaphore-post sem)
  (if (semaphore? sem)
      (begin
	(obtain-lock (get-semaphore-lock sem))
	(let ((waiting-list (get-semaphore-waiting sem)))
	  (if (null? waiting-list)
	      (begin
		(set-semaphore-counter! sem (+ 1 (get-semaphore-counter sem)))
		(release-lock (get-semaphore-lock sem)))
	      (let ((locked-thread (car waiting-list)))
		(set-semaphore-waiting! sem (cdr waiting-list))
		(release-lock locked-thread)
		(release-lock (get-semaphore-lock sem))))))
      (error "Not a semaphore.")))


;; Wait on the semaphore if the counter is 0
(define (semaphore-wait sem)
  (if (semaphore? sem)
      (begin
	(obtain-lock (get-semaphore-lock sem))      
	(if (> (get-semaphore-counter sem) 0)
	    (begin
	      (set-semaphore-counter! sem (- (get-semaphore-counter sem) 1))
	      (release-lock (get-semaphore-lock sem)))
	    (let ((lock (make-lock)))
	      (set-semaphore-waiting! sem 
				      (cons lock (get-semaphore-waiting sem)))
	      (obtain-lock lock)
	      (release-lock (get-semaphore-lock sem))
	      (obtain-lock lock))))
      (error "Not a semaphore.")))