From: Taylor R Campbell <campbell@mumble.net>
Date: Thu, 13 Nov 2014 22:45:03 +0000 (+0000)
Subject: Add GUARANTEE-THREAD-MUTEX-OWNED.
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7b912b89c1ec365470ba29929b59b92260947607;p=mit-scheme.git

Add GUARANTEE-THREAD-MUTEX-OWNED.
---

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 47b1729bc..cb91b13e0 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4992,6 +4992,7 @@ USA.
 	  deregister-timer-event
 	  detach-thread
 	  exit-current-thread
+	  guarantee-thread-mutex-owned
 	  join-thread
 	  lock-thread-mutex
 	  make-thread-mutex
diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index 9ba3ff885..e88751ad1 100644
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -1039,6 +1039,13 @@ USA.
   (if (not (thread-mutex? mutex))
       (error:wrong-type-argument mutex "thread-mutex" procedure)))
 
+(define (guarantee-thread-mutex-owned mutex #!optional caller)
+  (guarantee-thread-mutex mutex 'GUARANTEE-THREAD-MUTEX-OWNED)
+  (if (not (eq? (current-thread) (thread-mutex/owner mutex)))
+      (if (default-object? caller)
+	  (error "Don't own mutex:" mutex)
+	  (error "Don't own mutex:" mutex caller))))
+
 (define (thread-mutex-owner mutex)
   (guarantee-thread-mutex mutex 'THREAD-MUTEX-OWNER)
   (thread-mutex/owner mutex))