Add with-thread-mutex-try-lock.

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index e13a7c9ff0b7ac6d465bdd273844b14707c4b62e..602a5a3ed0b75834b708c301a1b819410db417d5 100644 (file)
--- 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 feafed9322a2062d37a898a1e5fbb2adfb2edb0e..ca55b10892c601a0c482837e92aad422f7cf6ce4 100644 (file)
--- 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