[slime-cvs] CVS slime

[heller]

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv18810

Modified Files:
	ChangeLog swank-allegro.lisp swank-openmcl.lisp 
Log Message:
* swank-openmcl.lisp (receive-if): Support timeout argument.
* swank-allegro.lisp (receive-if): Ditto.

--- /project/slime/cvsroot/slime/ChangeLog	2008/08/11 07:39:28	1.1438
+++ /project/slime/cvsroot/slime/ChangeLog	2008/08/11 07:40:23	1.1439
@@ -1,5 +1,10 @@
 2008-08-11  Helmut Eller  <heller at common-lisp.net>
 
+	* swank-openmcl.lisp (receive-if): Support timeout argument.
+	* swank-allegro.lisp (receive-if): Ditto.
+
+2008-08-11  Helmut Eller  <heller at common-lisp.net>
+
 	* swank.lisp (*global-debugger*): Change default back to t.
 
 2008-08-10  Helmut Eller  <heller at common-lisp.net>
--- /project/slime/cvsroot/slime/swank-allegro.lisp	2008/08/08 13:43:33	1.109
+++ /project/slime/cvsroot/slime/swank-allegro.lisp	2008/08/11 07:40:23	1.110
@@ -676,11 +676,9 @@
             (nconc (mailbox.queue mbox) (list message)))
       (mp:open-gate (mailbox.gate mbox)))))
 
-(defimplementation receive ()
-  (receive-if (constantly t)))
-
-(defimplementation receive-if (test)
+(defimplementation receive-if (test &optional timeout)
   (let ((mbox (mailbox mp:*current-process*)))
+    (assert (or (not timeout) (eq timeout t)))
     (loop
      (check-slime-interrupts)
      (mp:with-process-lock ((mailbox.lock mbox))
@@ -690,8 +688,9 @@
            (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
            (return (car tail)))
          (mp:close-gate (mailbox.gate mbox))))
-    (mp:process-wait-with-timeout "receive-if" 0.5
-                                  #'mp:gate-open-p (mailbox.gate mbox)))))
+     (when (eq timeout t) (return (values nil t)))
+     (mp:process-wait-with-timeout "receive-if" 0.5
+                                   #'mp:gate-open-p (mailbox.gate mbox)))))
 
 (defimplementation quit-lisp ()
   (excl:exit 0 :quiet t))
--- /project/slime/cvsroot/slime/swank-openmcl.lisp	2008/08/08 13:43:33	1.131
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp	2008/08/11 07:40:23	1.132
@@ -953,12 +953,10 @@
             (nconc (mailbox.queue mbox) (list message)))
       (ccl:signal-semaphore (mailbox.semaphore mbox)))))
 
-(defimplementation receive ()
-  (receive-if (constantly t)))
-
-(defimplementation receive-if (test)
+(defimplementation receive-if (test &optional timeout)
   (let* ((mbox (mailbox ccl:*current-process*))
          (mutex (mailbox.mutex mbox)))
+    (assert (or (not timeout) (eq timeout t)))
     (loop
      (check-slime-interrupts)
      (ccl:with-lock-grabbed (mutex)
@@ -968,6 +966,7 @@
            (setf (mailbox.queue mbox) 
                  (nconc (ldiff q tail) (cdr tail)))
            (return (car tail)))))
+     (when (eq timeout t) (return (values nil t)))
      (ccl:timed-wait-on-semaphore (mailbox.semaphore mbox) 0.2))))
 
 (defimplementation quit-lisp ()