[slime-cvs] CVS slime

[heller]

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

Modified Files:
	ChangeLog swank-abcl.lisp 
Log Message:
* swank-abcl.lisp (preferred-communication-style): Return nil
until we implement receive-if.

--- /project/slime/cvsroot/slime/ChangeLog	2008/08/11 07:40:23	1.1439
+++ /project/slime/cvsroot/slime/ChangeLog	2008/08/11 17:41:47	1.1440
@@ -1,5 +1,8 @@
 2008-08-11  Helmut Eller  <heller at common-lisp.net>
 
+	* swank-abcl.lisp (preferred-communication-style): Return nil
+	until we implement receive-if.
+
 	* swank-openmcl.lisp (receive-if): Support timeout argument.
 	* swank-allegro.lisp (receive-if): Ditto.
 
--- /project/slime/cvsroot/slime/swank-abcl.lisp	2008/08/08 13:43:33	1.50
+++ /project/slime/cvsroot/slime/swank-abcl.lisp	2008/08/11 17:41:47	1.51
@@ -117,14 +117,11 @@
 
 
 (defimplementation preferred-communication-style ()
-  :spawn)
-
-
+  nil)
 
 (defimplementation create-socket (host port)
   (ext:make-server-socket port))
 
-
 (defimplementation local-port (socket)
   (java:jcall (java:jmethod "java.net.ServerSocket" "getLocalPort") socket))
 
@@ -511,18 +508,39 @@
 (defimplementation kill-thread (thread)
   (ext:destroy-thread thread))
 
+(defstruct mailbox 
+  (mutex (ext:make-mutex))
+  (queue '()))
+
 (defun mailbox (thread)
   "Return THREAD's mailbox."
   (ext:with-thread-lock (*thread-props-lock*)
     (or (getf (gethash thread *thread-props*) 'mailbox)
         (setf (getf (gethash thread *thread-props*) 'mailbox)
-              (ext:make-mailbox)))))
+              (make-mailbox)))))
 
 (defimplementation send (thread object)
-  (ext:mailbox-send (mailbox thread) object))
-
-(defimplementation receive ()
-  (ext:mailbox-read (mailbox (ext:current-thread))))
+  (let ((mbox (mailbox thread)))
+    (ext:with-mutex ((mailbox-mutex mbox))
+      (setf (mailbox-queue mbox) 
+            (nconc (mailbox-queue mbox) (list message))))))
+
+#+(or)
+(defimplementation receive-if (thread &optional timeout)
+  (let* ((mbox (mailbox (current-thread))))
+    (assert (or (not timeout) (eq timeout t)))
+    (loop
+     (check-slime-interrupts)
+     (ext:with-mutex ((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))))
+       (when (eq timeout t) (return (values nil t)))
+       ;;(java:jcall (java:jmethod "java.lang.Object" "wait") 
+       ;;            (mailbox-mutex mbox) 1000)
+       ))))
 
 (defimplementation quit-lisp ()
   (ext:exit))