# Patch bordeaux-threads to work with ABCL
#
# 20110318a
#  Changed condition variables implmentation to answer the following cricitisms 
#  from Martin Simmons
# 
#  1) If no other threads are trying to claim the lock, then condition-wait will
#     return immediately rather than waiting.
#
#  2) If two threads are waiting in condition-wait and two other threads call
#     condition-notify, then it is possible that only one thread will return from
#     condition-wait because the call to acquire-lock in one of them might return
#     nil causing it to wait again.
#
#  3) If condition-notify is called by one thread when a waiting thread is just
#     about to enter the threads:synchronized-on form (but before it gets
#     synchronized), then the notify will be lost.  This happens because the
#     underlying threading primitives have no "memory" of calls to notify when
#     nothing it waiting (which is also the expected semantics for POSIX condition
#     variables BTW).
# 
#   4) Also, I think condition-notify should be using threads:object-notify rather
#      than threads:object-notify-all.

diff --git a/bordeaux-threads.asd b/bordeaux-threads.asd
--- a/bordeaux-threads.asd
+++ b/bordeaux-threads.asd
@@ -50,9 +50,10 @@
                         #-thread-support                 "impl-null")
                  #+(and thread-support lispworks (not lispworks6))
                  (:file "impl-lispworks-condition-variables")
-                 #+(and thread-support (or armedbear digitool))
+                 #+(and thread-support digitool)
                  (:file "condition-variables")
                  (:file "default-implementations"))))
   :in-order-to ((asdf:test-op (asdf:load-op bordeaux-threads-test)))
   :perform (asdf:test-op :after (op c)
              (asdf:oos 'asdf:test-op :bordeaux-threads-test)))
+
diff --git a/src/impl-abcl.lisp b/src/impl-abcl.lisp
--- a/src/impl-abcl.lisp
+++ b/src/impl-abcl.lisp
@@ -3,6 +3,8 @@
 #|
 Copyright 2006, 2007 Greg Pfeil
 
+Reimplemented with java.util.concurrent.locks.ReentrantLock by Mark Evenson 2011.
+
 Distributed under the MIT license (see LICENSE file)
 |#
 
@@ -22,33 +24,94 @@
 (defun current-thread ()
   (threads:current-thread))
 
+(defun threadp (object)
+  (typep object 'thread))
+
 (defun thread-name (thread)
   (threads:thread-name thread))
 
-(defun threadp (object)
-  (typep object 'thread))
-
 ;;; Resource contention: locks and recursive locks
 
+(defstruct mutex name lock)
+(defstruct (mutex-recursive (:include mutex)))
+
+;; Making methods constants in this manner avoids the runtime expense of
+;; introspection involved in JCALL with string arguments.
+(defconstant +lock+ 
+  (jmethod "java.util.concurrent.locks.ReentrantLock" "lock"))
+(defconstant +try-lock+ 
+  (jmethod "java.util.concurrent.locks.ReentrantLock" "tryLock"))
+(defconstant +is-held-by-current-thread+ 
+  (jmethod "java.util.concurrent.locks.ReentrantLock" "isHeldByCurrentThread"))
+(defconstant +unlock+ 
+  (jmethod "java.util.concurrent.locks.ReentrantLock" "unlock"))
+(defconstant +get-hold-count+ 
+  (jmethod "java.util.concurrent.locks.ReentrantLock" "getHoldCount"))
+
 (defun make-lock (&optional name)
-  (declare (ignore name))
-  (threads:make-thread-lock))
+  (make-mutex 
+   :name (or name "Anonymous lock")
+   :lock (jnew "java.util.concurrent.locks.ReentrantLock")))
 
 (defun acquire-lock (lock &optional (wait-p t))
-  (declare (ignore wait-p))
-  (threads:thread-lock lock))
+  (check-type lock mutex)
+  (when (jcall +is-held-by-current-thread+ (mutex-lock lock))
+    (warn "Non-recursive lock being reacquired by owner."))
+  (if wait-p
+      (progn
+        (jcall +lock+ (mutex-lock lock))
+        t)
+      (jcall +try-lock+ (mutex-lock lock))))
 
 (defun release-lock (lock)
-  (threads:thread-unlock lock))
+  (check-type lock mutex)
+  (unless (jcall +is-held-by-current-thread+ (mutex-lock lock))
+    (error "Attempt to release lock not held by calling thread."))
+  (jcall +unlock+ (mutex-lock lock))
+  (values))
 
-(defmacro with-lock-held ((place) &body body)
-  `(threads:with-thread-lock (,place) ,@body))
+(defun make-recursive-lock (&optional name)
+  (make-mutex-recursive
+   :name (or name "Anonymous lock")
+   :lock (jnew "java.util.concurrent.locks.ReentrantLock")))
+
+(defun acquire-recursive-lock (lock &optional (wait-p t))
+  (check-type lock mutex-recursive)
+  (if wait-p
+      (progn
+        (jcall +lock+ (mutex-recursive-lock lock))
+        t)
+      (jcall +try-lock+ (mutex-recursive-lock lock))))
+
+(defun release-recursive-lock (lock)
+  (check-type lock mutex-recursive)
+  (unless (jcall +is-held-by-current-thread+ (mutex-lock lock))
+    (error "Attempt to release lock not held by calling thread."))
+  (when (> (jcall +get-hold-count+ (mutex-lock lock)) 1)
+    (do ()
+        ((= (jcall +get-hold-count+ (mutex-lock lock)) 1))
+      (jcall +unlock+ (mutex-lock lock))))
+  (jcall +unlock+ (mutex-lock lock))
+  (values))
 
 ;;; Resource contention: condition variables
 
 (defun thread-yield ()
   (sleep 0.01))
 
+(defstruct condition-variable
+  (name "Anonymous condition variable"))
+
+(defun condition-wait (condition lock)
+  (threads:synchronized-on condition
+    (release-lock lock)
+    (threads:object-wait condition))
+  (acquire-lock lock))
+
+(defun condition-notify (condition)
+  (threads:synchronized-on condition
+     (threads:object-notify condition)))
+
 ;;; Introspection/debugging
 
 (defun all-threads ()