[slime-cvs] CVS slime

[heller]

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

Modified Files:
	ChangeLog swank-cmucl.lisp 
Log Message:
* swank-cmucl.lisp (receive,receive-if): Test for new messages in
a loop.

--- /project/slime/cvsroot/slime/ChangeLog	2008/08/04 20:25:23	1.1384
+++ /project/slime/cvsroot/slime/ChangeLog	2008/08/04 20:25:28	1.1385
@@ -1,5 +1,8 @@
 2008-08-04  Helmut Eller  <heller at common-lisp.net>
 
+	* swank-cmucl.lisp (receive,receive-if): Test for new messages in
+	a loop.
+
 	* swank.lisp (eval-for-emacs): Don't flush streams here as that
 	may now block.
 
--- /project/slime/cvsroot/slime/swank-cmucl.lisp	2008/08/03 18:23:10	1.182
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp	2008/08/04 20:25:28	1.183
@@ -2097,31 +2097,35 @@
                 (make-mailbox)))))
   
   (defimplementation send (thread message)
-    (let* ((mbox (mailbox thread))
-           (mutex (mailbox.mutex mbox)))
-      (mp:with-lock-held (mutex)
-        (setf (mailbox.queue mbox)
-              (nconc (mailbox.queue mbox) (list message))))))
+    (let* ((mbox (mailbox thread)))
+      (sys:without-interrupts
+        (mp:with-lock-held ((mailbox.mutex mbox))
+          (setf (mailbox.queue mbox)
+                (nconc (mailbox.queue mbox) (list message)))))))
   
   (defimplementation receive ()
-    (let* ((mbox (mailbox mp:*current-process*))
-           (mutex (mailbox.mutex mbox)))
-      (mp:process-wait "receive" #'mailbox.queue mbox)
-      (mp:with-lock-held (mutex)
-        (pop (mailbox.queue mbox)))))
+    (let* ((mbox (mailbox mp:*current-process*)))
+      (loop
+       (mp:process-wait "receive" #'mailbox.queue mbox)
+       (sys:without-interrupts
+         (mp:with-lock-held ((mailbox.mutex mbox))
+           (when (mailbox.queue mbox)
+             (return (pop (mailbox.queue mbox)))))))))
 
   (defimplementation receive-if (test)
     (let ((mbox (mailbox mp:*current-process*)))
-      (mp:process-wait "receive-if" 
-                       (lambda (mbox test)
-                         (some test (mailbox.queue mbox)))
-                       mbox test)
-      (mp:with-lock-held ((mailbox.mutex mbox))
-        (let* ((q (mailbox.queue mbox))
-               (tail (member-if test q)))
-          (assert tail)
-          (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
-          (car tail)))))
+      (loop
+       (mp:process-wait "receive-if" 
+                        (lambda () (some test (mailbox.queue mbox))))
+       (sys:without-interrupts
+         (mp:with-lock-held ((mailbox.mutex 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)))))))))
+                   
 
   ) ;; #+mp