From 9e66180733588860a32db479d2283b4d73d598ab Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=B6rg=20F=2E=20Wittenberger?=
 <address@hidden>
Date: Wed, 19 Dec 2018 12:24:29 +0100
Subject: [PATCH 1/2] Add test cases and make test effective.

---
 tests/mutex-test.scm | 63 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 63 insertions(+)

diff --git a/tests/mutex-test.scm b/tests/mutex-test.scm
index 9c7f1e6..d052abb 100644
--- a/tests/mutex-test.scm
+++ b/tests/mutex-test.scm
@@ -57,6 +57,29 @@ Slot  Type                           Meaning
      (print "Got " mux1 " state " (mutex-state mux1) " expected " owner1 "\n")
      (test-exit 1)))))
 
+(let ((m1 (make-mutex)))
+  ;; This fails if we manage to sort primorial before t1 and unleash
+  ;; both in one turn.
+  (define (sys-thread-sleep! limit)
+    ;; a copy from srfi-18 which expects pre-computed goal time.
+    (##sys#call-with-current-continuation
+     (lambda (return)
+       (let ((ct ##sys#current-thread))
+	 (##sys#setslot ct 1 (lambda () (return (##core#undefined))))
+	 (##sys#thread-block-for-timeout! ct limit)
+	 (##sys#schedule) ) ) ) )
+  #;(print "mutex state changes atomically wrt. blocking queues")
+  (mutex-lock! m1)
+  (let ((t1 (thread-start! (lambda () (mutex-lock! m1 0.1)))))
+    #;(print "have t1 it wait for m1")
+    (thread-yield!)
+    (let* ((to (##sys#slot t1 4))
+	   (hit (- to 0.0001)))
+      #;(print "waiting ever so slightly less than to " to " i.e. " hit "\n")
+      (sys-thread-sleep! hit))
+    ;; catch inconsistent state
+    (mutex-unlock! m1)))
+
 (set! mux1 (make-mutex 'unlock-leaves-no-memory-leak))
 (mutex-lock! mux1)
 (mutex-unlock! mux1)
@@ -65,6 +88,27 @@ Slot  Type                           Meaning
  (test-error "thread still held in mutex after unlock: " mux1))
 
 ;;============
+(let* ((cv (make-condition-variable))
+       (m (begin
+	    (condition-variable-specific-set! cv #f)
+	    (make-mutex)))
+       (t (thread-start!
+	   (lambda ()
+	     (do ()
+		 ((condition-variable-specific cv))
+	       (mutex-unlock! m cv))))))
+  (thread-yield!)
+  (when
+   (not (eq? (##sys#slot t 3) 'sleeping))
+   (test-error "thread not sleeping " t))
+  (condition-variable-specific-set! cv #t)
+  (condition-variable-signal! cv)
+  (thread-yield!)
+  (when
+   (not (eq? (##sys#slot t 3) 'dead))
+   (test-error "thread not completed " t)))
+
+;;============
 ; Make a locked mutex
 (define mux (make-mutex 'foo))
 (mutex-lock! mux #f #f)
@@ -110,6 +154,23 @@ Slot  Type                           Meaning
   (print "Abandoned Mutex not abandoned " mux "\n")
   (test-exit 1))
 
+(unless (eq? (mutex-state mux) (current-thread))
+  (print "Mutex " mux " locked/not-owned but left in state " (mutex-state mux) "\n")
+  (test-exit 1))
+
+;; repeat with owned mutex
+(set! mux (make-mutex 'foobar))
+(thread-start!  (lambda () (mutex-lock! mux)))
+(thread-yield!)
+
+(when (not (handle-exceptions ex (abandoned-mutex-exception? ex) (and (mutex-lock! mux) #f)))
+  (print "Abandoned Mutex not abandoned " mux "\n")
+  (test-exit 1))
+
+(unless (eq? (mutex-state mux) (current-thread))
+  (print "Mutex " mux " not assigned to " (current-thread) " but left in state " (mutex-state mux) "\n")
+  (test-exit 1))
+
 (mutex-unlock! mux)
 
 (mutex-lock! mux)
@@ -189,3 +250,5 @@ Slot  Type                           Meaning
 
 (thread-sleep! 3)
 ;(tprint 'exit)
+
+(if test-has-failed (exit 1) (exit 0))
-- 
2.11.0