diff --git a/s48/concurrency/interfaces.scm b/s48/concurrency/interfaces.scm new file mode 100644 index 0000000..9bc9f90 --- /dev/null +++ b/s48/concurrency/interfaces.scm @@ -0,0 +1,8 @@ +(define-interface semaphores-interface + (export make-semaphore + semaphore-post + semaphore-wait + with-semaphore-posted)) + +(define-interface with-lock-interface + (export with-lock)) \ No newline at end of file diff --git a/s48/concurrency/packages.scm b/s48/concurrency/packages.scm new file mode 100644 index 0000000..d167740 --- /dev/null +++ b/s48/concurrency/packages.scm @@ -0,0 +1,11 @@ +(define-structure semaphores + (open scheme + locks + with-lock + define-record-types) + (files semaphore)) + +(define-structure with-lock with-lock-interface + (open scheme + locks) + (files with-lock)) \ No newline at end of file diff --git a/s48/concurrency/semaphore.scm b/s48/concurrency/semaphore.scm new file mode 100644 index 0000000..67acebf --- /dev/null +++ b/s48/concurrency/semaphore.scm @@ -0,0 +1,41 @@ +;;; This file is part of the Scheme Untergrund Library. + +;;; Copyright (c) 2002-2003 by Martin Gasbichler. +;;; For copyright information, see the file COPYING which comes with +;;; the distribution. + +(define-record-type semaphore :semaphore + (really-make-semaphore sync-lock waiting free) + (sync-lock semaphore-sync-lock) + (waiting semaphore-waiting set-semaphore-waiting!) + (free semaphore-free set-semaphore-free!)) + +(define (make-semaphore init-free) + (really-make-semaphore (make-lock) '() init-free)) + +(define (semaphore-post sem) + (with-lock (semaphore-sync-lock sem) + (lambda () + (let ((waiting (semaphore-waiting sem))) + (if (null? waiting) + (set-semaphore-free! sem (+ (semaphore-free sem) 1)) + (let ((runnable (car waiting))) + (set-semaphore-waiting! sem (cdr waiting)) + (release-lock runnable))))))) + +(define (semaphore-wait sem) + (obtain-lock (semaphore-sync-lock sem)) + (if (> (semaphore-free sem) 0) + (begin + (set-semaphore-free! sem (- (semaphore-free sem) 1)) + (release-lock (semaphore-sync-lock sem))) + (let ((my-lock (make-lock))) + (set-semaphore-waiting! sem (cons my-lock (semaphore-waiting sem))) + (obtain-lock my-lock) + (release-lock (semaphore-sync-lock sem)) + (obtain-lock my-lock)))) +(define (with-semaphore-posted sem thunk) + (dynamic-wind + (lambda () (semaphore-wait sem)) + thunk + (lambda () (semaphore-post sem)))) \ No newline at end of file diff --git a/s48/concurrency/with-lock.scm b/s48/concurrency/with-lock.scm new file mode 100644 index 0000000..c525d72 --- /dev/null +++ b/s48/concurrency/with-lock.scm @@ -0,0 +1,13 @@ +;;; This file is part of the Scheme Untergrund Library. + +;;; Copyright (c) 2002-2003 by Martin Gasbichler. +;;; For copyright information, see the file COPYING which comes with +;;; the distribution. + +(define (with-lock lock thunk) + (dynamic-wind + (lambda () + (release-lock lock)) + thunk + (lambda () + (release-lock lock))))