>From f22e258a3e6858f6397d949b85f288cc53f98191 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=B6rg=20F=2E=20Wittenberger?=
 <address@hidden>
Date: Mon, 23 Nov 2015 17:20:47 +0100
Subject: [PATCH] Change (mutex-lock! #f #f) not make the mutex not owned by
 the locking thread.

(Bevor it would own it when it had to wait.)
---
 srfi-18.scm          | 55 ++++++++++++++++++++++++++--------------------------
 tests/mutex-test.scm | 38 ++++++++++++++++++++++++++++++++++++
 2 files changed, 65 insertions(+), 28 deletions(-)

diff --git a/srfi-18.scm b/srfi-18.scm
index 2ae489d..740cdba 100644
--- a/srfi-18.scm
+++ b/srfi-18.scm
@@ -276,45 +276,44 @@
 	     (##sys#schedule) )
 	   (define (check)
 	     (when (##sys#slot mutex 4)	; abandoned
-	       (return
-		(##sys#signal
-		 (##sys#make-structure 'condition '(abandoned-mutex-exception) '()))) ) )
-	   (dbg ct ": locking " (mutex-name mutex))
+	       (return (##sys#signal (##sys#make-structure 'condition '(abandoned-mutex-exception) (list (##sys#slot mutex 1))))) ) )
+	   (define (assign)
+	     (check)
+	     (if (and threadsup (not thread))
+		 (begin
+		   (##sys#setislot mutex 2 #f)
+		   (##sys#setislot mutex 5 #t) )
+		 (let* ([t (or thread ct)]
+			[ts (##sys#slot t 3)] )
+		   (if (or (eq? 'terminated ts) (eq? 'dead ts))
+		       (begin
+			 (##sys#setislot mutex 2 #f)
+			 (##sys#setislot mutex 5 #f)
+			 (##sys#setislot mutex 4 #t))
+		       (begin
+			 (##sys#setslot mutex 2 t)
+			 (##sys#setislot mutex 5 #t)
+			 (##sys#setslot t 8 (cons mutex (##sys#slot t 8))) ) ) ) )
+	     (return #t))
+	   (dbg ct ": locking " mutex)
 	   (cond [(not (##sys#slot mutex 5))
-		  (if (and threadsup (not thread))
-		      (begin
-			(##sys#setislot mutex 2 #f)
-			(##sys#setislot mutex 5 #t) )
-		      (let* ([t (or thread ct)]
-			     [ts (##sys#slot t 3)] )
-			(if (or (eq? 'terminated ts) (eq? 'dead ts))
-			    (##sys#setislot mutex 4 #t)
-			    (begin
-			      (##sys#setislot mutex 5 #t)
-			      (##sys#setslot t 8 (cons mutex (##sys#slot t 8)))
-			      (##sys#setslot t 11 mutex)
-			      (##sys#setslot mutex 2 t) ) ) ) )
-		  (check)
-		  (return #t) ]
+		  (assign) ]
 		 [limit
 		  (check)
 		  (##sys#setslot
 		   ct 1 
 		   (lambda ()
-		     (##sys#setslot mutex 3 (##sys#delq ct (##sys#slot mutex 3)))
-		     (unless (##sys#slot ct 13)  ; not unblocked by timeout
-		       (##sys#remove-from-timeout-list ct))
-		     (check)
-		     (##sys#setslot ct 8 (cons mutex (##sys#slot ct 8)))
-		     (##sys#setslot ct 11 #f)
-		     (##sys#setslot mutex 2 thread)
-		     (return #f) ))
+		     (if (##sys#slot ct 13)  ; unblocked by timeout
+			 (return #f)
+			 (begin
+			   (##sys#remove-from-timeout-list ct)
+			   (assign))) ))
 		  (##sys#thread-block-for-timeout! ct limit)
 		  (switch) ]
 		 [else
 		  (##sys#setslot ct 3 'sleeping)
 		  (##sys#setslot ct 11 mutex)
-		  (##sys#setslot ct 1 (lambda () (check) (return #t)))
+		  (##sys#setslot ct 1 assign)
 		  (switch) ] ) ) ) ) ) ) )
 
 (define mutex-unlock!
diff --git a/tests/mutex-test.scm b/tests/mutex-test.scm
index 8962a1e..30292a7 100644
--- a/tests/mutex-test.scm
+++ b/tests/mutex-test.scm
@@ -3,6 +3,44 @@
 
 (require-extension srfi-18)
 
+; Make a locked mutex
+(define mux (make-mutex 'foo))
+(mutex-lock! mux #f #f)
+
+;; Have a thread waiting for it.
+
+(define t1
+  (thread-start!
+   (lambda ()
+    (mutex-lock! mux #f #f)
+    (when (not (eq? (mutex-state mux) 'not-owned))
+      (print "Got " mux " state " (mutex-state mux) " expected " 'not-owned "\n")
+      (exit 1)))))
+
+;; Give it time to actually wait.
+
+(thread-yield!)
+
+;; Let it lock the mux
+
+(mutex-unlock! mux)
+
+(thread-yield!)
+
+;; check that it is properly abandoned
+
+(when (not (handle-exceptions ex (abandoned-mutex-exception? ex) (and (mutex-lock! mux) #f)))
+  (print "Abandoned Mutex not abandoned " mux "\n")
+  (exit 1))
+
+(mutex-unlock! mux)
+
+(mutex-lock! mux)
+
+(when (not (eq? (mutex-state mux) (current-thread)))
+  (print "Got " mux " state " (mutex-state mux) " expected " (current-thread) "\n")
+  (exit 1))
+
 (cond-expand (dribble
 (define-for-syntax count 0)
 (define-syntax trail
-- 
2.6.2