[slime-cvs] CVS slime

[CVS User heller]

Update of /project/slime/cvsroot/slime
In directory tiger.common-lisp.net:/tmp/cvs-serv4990

Modified Files:
	ChangeLog swank-sbcl.lisp 
Log Message:
* swank-sbcl.lisp (condition-timed-wait): Use the :timeout
argument of sb-thread:condition-wait if supported.

--- /project/slime/cvsroot/slime/ChangeLog	2012/05/06 16:16:13	1.2333
+++ /project/slime/cvsroot/slime/ChangeLog	2012/05/06 16:16:24	1.2334
@@ -1,5 +1,10 @@
 2012-05-06  Helmut Eller  <heller at common-lisp.net>
 
+	* swank-sbcl.lisp (condition-timed-wait): Use the :timeout
+	argument of sb-thread:condition-wait if supported.
+
+2012-05-06  Helmut Eller  <heller at common-lisp.net>
+
 	* swank-sbcl.lisp (with-definition-source): Forgot to commit this
 	one.
 
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2012/05/06 16:16:13	1.316
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2012/05/06 16:16:24	1.317
@@ -1623,21 +1623,26 @@
         (setf (mailbox.queue mbox)
               (nconc (mailbox.queue mbox) (list message)))
         (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
-  #-sb-lutex
-  (defun condition-timed-wait (waitqueue mutex timeout)
-    (handler-case 
-        (let ((*break-on-signals* nil))
-          (sb-sys:with-deadline (:seconds timeout :override t)
-            (sb-thread:condition-wait waitqueue mutex) t))
-      (sb-ext:timeout ()
-        nil)))
 
-  ;; FIXME: with-timeout doesn't work properly on Darwin
-  #+sb-lutex
   (defun condition-timed-wait (waitqueue mutex timeout)
-    (declare (ignore timeout))
-    (sb-thread:condition-wait waitqueue mutex   ))
-  
+    (macrolet ((foo ()
+                 (cond ((> (length (sb-introspect:function-arglist
+                                    #'sb-thread:condition-wait))
+                           2)
+                        '(sb-thread:condition-wait waitqueue mutex
+                          :timeout timeout))
+                       ((member :sb-lutex *features*) ; Darwin
+                        '(sb-thread:condition-wait waitqueue mutex))
+                       (t
+                        '(handler-case
+                          (let ((*break-on-signals* nil))
+                            (sb-sys:with-deadline (:seconds timeout
+                                                            :override t)
+                              (sb-thread:condition-wait waitqueue mutex) t))
+                          (sb-ext:timeout ()
+                           nil))))))
+      (foo)))
+
   (defimplementation receive-if (test &optional timeout)
     (let* ((mbox (mailbox (current-thread)))
            (mutex (mailbox.mutex mbox))