Added two small utilities for threads

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

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

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

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