[slime-cvs] CVS slime

[heller]

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

Modified Files:
	ChangeLog swank-scl.lisp 
Log Message:
* swank-scl.lisp (receive-if): Implemented.

--- /project/slime/cvsroot/slime/ChangeLog	2008/08/04 20:25:28	1.1385
+++ /project/slime/cvsroot/slime/ChangeLog	2008/08/04 20:25:33	1.1386
@@ -1,5 +1,7 @@
 2008-08-04  Helmut Eller  <heller at common-lisp.net>
 
+	* swank-scl.lisp (receive-if): Implemented.
+
 	* swank-cmucl.lisp (receive,receive-if): Test for new messages in
 	a loop.
 
--- /project/slime/cvsroot/slime/swank-scl.lisp	2008/04/17 14:56:43	1.19
+++ /project/slime/cvsroot/slime/swank-scl.lisp	2008/08/04 20:25:33	1.20
@@ -1994,6 +1994,20 @@
        (when winp
          (return message))))))
 
+(defimplementation receive-if (test)
+  (let ((mbox (mailbox thread:*thread*)))
+    (loop
+     (mp:process-wait "receive-if" 
+                      (lambda () (some test (mailbox-queue mbox))))
+     (sys:without-interrupts
+       (mp:with-lock-held ((mailbox-lock mbox))
+         (let* ((q (mailbox-queue mbox))
+                (tail (member-if test q)))
+           (when tail
+             (setf (mailbox-queue mbox) 
+                   (nconc (ldiff q tail) (cdr tail)))
+             (return (car tail)))))))))
+
 
 
 (defimplementation emacs-connected ())