From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Sun, 12 Jul 2015 22:42:00 +0000 (-0700)
Subject: Add with-thread-mutex-try-lock.
X-Git-Tag: mit-scheme-pucked-9.2.12~376^2~64
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d27718a05c0c188221c0d0c6fac815624d12df3b;p=mit-scheme.git

Add with-thread-mutex-try-lock.
---

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index e13a7c9ff..602a5a3ed 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -5074,6 +5074,7 @@ USA.
 	  with-thread-events-blocked
 	  with-thread-mutex-lock
 	  with-thread-mutex-locked
+	  with-thread-mutex-try-lock
 	  with-thread-mutex-unlocked
 	  with-thread-timer-stopped
 	  without-thread-mutex-lock
diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index feafed932..ca55b1089 100644
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -1122,6 +1122,17 @@ USA.
 		thunk
 		(lambda () (lock-thread-mutex mutex))))
 
+(define (with-thread-mutex-try-lock mutex locked not-locked)
+  (guarantee-thread-mutex mutex 'WITH-THREAD-MUTEX-TRY-LOCK)
+  (let ((locked?))
+    (dynamic-wind (lambda ()
+		    (set! locked? (try-lock-thread-mutex mutex)))
+		  (lambda ()
+		    (if locked? (locked) (not-locked)))
+		  (lambda ()
+		    (if locked? (unlock-thread-mutex mutex))
+		    (set! locked?)))))
+
 ;;; WITH-THREAD-MUTEX-LOCKED is retained for compatibility for old
 ;;; programs that require recursion.  For new programs, better to
 ;;; refactor into clearer invariants that do not require recursion if