84 lines
2.5 KiB
Scheme
84 lines
2.5 KiB
Scheme
|
; ----------------------
|
||
|
|
; --- 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.")))
|