From b9450a3aecb3a84dbf3905b276d00f6822b1831c Mon Sep 17 00:00:00 2001
From: Martin Gasbichler <gasbichl@informatik.uni-tuebingen.de>
Date: Tue, 28 Jan 2003 12:48:57 +0000
Subject: [PATCH] Added two small utilities for threads

---
 s48/concurrency/interfaces.scm |  8 +++++++
 s48/concurrency/packages.scm   | 11 +++++++++
 s48/concurrency/semaphore.scm  | 41 ++++++++++++++++++++++++++++++++++
 s48/concurrency/with-lock.scm  | 13 +++++++++++
 4 files changed, 73 insertions(+)
 create mode 100644 s48/concurrency/interfaces.scm
 create mode 100644 s48/concurrency/packages.scm
 create mode 100644 s48/concurrency/semaphore.scm
 create mode 100644 s48/concurrency/with-lock.scm

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