Index: swank-backend.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-backend.lisp,v
retrieving revision 1.97
diff -u -r1.97 swank-backend.lisp
--- swank-backend.lisp	22 Mar 2006 16:40:01 -0000	1.97
+++ swank-backend.lisp	30 Mar 2006 16:29:10 -0000
@@ -836,6 +836,24 @@
             (type function function))
    (funcall function))
 
+(definterface make-recursive-lock (&key name)
+  "Make a lock for thread synchronization.
+Only one thread may hold the lock (via CALL-WITH-RECURSIVE-LOCK-HELD)
+at a time, but that thread may hold it more than once."
+  (cons nil (make-lock :name name)))
+
+(definterface call-with-recursive-lock-held (lock function)
+  "Call FUNCTION with LOCK held, queueing if necessary."
+  (if (eql (car lock) (current-thread))
+      (funcall function)
+      (call-with-lock-held (cdr lock)
+                           (lambda ()
+                             (unwind-protect
+                                  (progn
+                                    (setf (car lock) (current-thread))
+                                    (funcall function))
+                               (setf (car lock) nil))))))
+
 (definterface current-thread ()
   "Return the currently executing thread."
   0)
Index: swank-gray.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-gray.lisp,v
retrieving revision 1.9
diff -u -r1.9 swank-gray.lisp
--- swank-gray.lisp	22 Sep 2005 20:15:11 -0000	1.9
+++ swank-gray.lisp	30 Mar 2006 16:29:11 -0000
@@ -15,86 +15,115 @@
    (buffer :initform (make-string 8000))
    (fill-pointer :initform 0)
    (column :initform 0)
-   (last-flush-time :initform (get-internal-real-time))))
+   (last-flush-time :initform (get-internal-real-time))
+   (lock :initform (make-recursive-lock :name "buffer write lock"))))
 
 (defmethod stream-write-char ((stream slime-output-stream) char)
-  (with-slots (buffer fill-pointer column) stream
-    (setf (schar buffer fill-pointer) char)
-    (incf fill-pointer)
-    (incf column)
-    (when (char= #\newline char)
-      (setf column 0)
-      (force-output stream))
-    (when (= fill-pointer (length buffer))
-      (finish-output stream)))
+  (call-with-recursive-lock-held
+   (slot-value stream 'lock)
+   (lambda ()
+     (with-slots (buffer fill-pointer column) stream
+       (setf (schar buffer fill-pointer) char)
+       (incf fill-pointer)
+       (incf column)
+       (when (char= #\newline char)
+         (setf column 0)
+         (force-output stream))
+       (when (= fill-pointer (length buffer))
+         (finish-output stream)))))
   char)
 
 (defmethod stream-line-column ((stream slime-output-stream))
-  (slot-value stream 'column))
+  (call-with-recursive-lock-held
+   (slot-value stream 'lock)
+   (lambda ()
+     (slot-value stream 'column))))
 
 (defmethod stream-line-length ((stream slime-output-stream))
   75)
 
 (defmethod stream-finish-output ((stream slime-output-stream))
-  (with-slots (buffer fill-pointer output-fn last-flush-time) stream
-    (let ((end fill-pointer))
-      (unless (zerop end)
-        (funcall output-fn (subseq buffer 0 end))
-        (setf fill-pointer 0)))
-    (setf last-flush-time (get-internal-real-time)))
+  (call-with-recursive-lock-held
+   (slot-value stream 'lock)
+   (lambda ()
+     (with-slots (buffer fill-pointer output-fn last-flush-time) stream
+       (let ((end fill-pointer))
+         (unless (zerop end)
+           (funcall output-fn (subseq buffer 0 end))
+           (setf fill-pointer 0)))
+       (setf last-flush-time (get-internal-real-time)))))
   nil)
 
 (defmethod stream-force-output ((stream slime-output-stream))
-  (with-slots (last-flush-time fill-pointer) stream
-    (let ((now (get-internal-real-time)))
-      (when (> (/ (- now last-flush-time)
-                  (coerce internal-time-units-per-second 'double-float))
-               0.2)
-        (finish-output stream))))
+  (call-with-recursive-lock-held
+   (slot-value stream 'lock)
+   (lambda ()
+     (with-slots (last-flush-time fill-pointer) stream
+       (let ((now (get-internal-real-time)))
+         (when (> (/ (- now last-flush-time)
+                     (coerce internal-time-units-per-second 'double-float))
+                  0.2)
+           (finish-output stream))))))
   nil)
 
 (defmethod stream-fresh-line ((stream slime-output-stream))
-  (with-slots (column) stream
-    (cond ((zerop column) nil)
-          (t (terpri stream) t))))
+  (call-with-recursive-lock-held
+   (slot-value stream 'lock)
+   (lambda ()
+     (with-slots (column) stream
+       (cond ((zerop column) nil)
+             (t (terpri stream) t))))))
 
 (defclass slime-input-stream (fundamental-character-input-stream)
   ((output-stream :initarg :output-stream)
    (input-fn :initarg :input-fn)
-   (buffer :initform "") (index :initform 0)))
+   (buffer :initform "") (index :initform 0)
+   (lock :initform (make-lock :name "buffer read lock"))))
 
 (defmethod stream-read-char ((s slime-input-stream))
-  (with-slots (buffer index output-stream input-fn) s
-    (when (= index (length buffer))
-      (when output-stream
-        (finish-output output-stream))
-      (let ((string (funcall input-fn)))
-        (cond ((zerop (length string))
-               (return-from stream-read-char :eof))
-              (t
-               (setf buffer string)
-               (setf index 0)))))
-    (assert (plusp (length buffer)))
-    (prog1 (aref buffer index) (incf index))))
+  (call-with-lock-held
+   (slot-value s 'lock)
+   (lambda ()
+     (with-slots (buffer index output-stream input-fn) s
+       (when (= index (length buffer))
+         (when output-stream
+           (finish-output output-stream))
+         (let ((string (funcall input-fn)))
+           (cond ((zerop (length string))
+                  (return-from stream-read-char :eof))
+                 (t
+                  (setf buffer string)
+                  (setf index 0)))))
+       (assert (plusp (length buffer)))
+       (prog1 (aref buffer index) (incf index))))))
 
 (defmethod stream-listen ((s slime-input-stream))
-  (with-slots (buffer index) s
-    (< index (length buffer))))
+  (call-with-lock-held
+   (slot-value s 'lock)
+   (lambda ()
+     (with-slots (buffer index) s
+       (< index (length buffer))))))
 
 (defmethod stream-unread-char ((s slime-input-stream) char)
-  (with-slots (buffer index) s
-    (decf index)
-    (cond ((eql (aref buffer index) char)
-           (setf (aref buffer index) char))
-          (t
-           (warn "stream-unread-char: ignoring ~S (expected ~S)"
-                 char (aref buffer index)))))
+  (call-with-lock-held
+   (slot-value s 'lock)
+   (lambda ()
+     (with-slots (buffer index) s
+       (decf index)
+       (cond ((eql (aref buffer index) char)
+              (setf (aref buffer index) char))
+             (t
+              (warn "stream-unread-char: ignoring ~S (expected ~S)"
+                    char (aref buffer index)))))))
   nil)
 
 (defmethod stream-clear-input ((s slime-input-stream))
-  (with-slots (buffer index) s 
-    (setf buffer ""  
-	  index 0))
+  (call-with-lock-held
+   (slot-value s 'lock)
+   (lambda ()
+     (with-slots (buffer index) s 
+       (setf buffer ""  
+             index 0))))
   nil)
 
 (defmethod stream-line-column ((s slime-input-stream))
@@ -113,9 +142,12 @@
 ;; We could make do with either of the two methods below.
 
 (defmethod stream-read-char-no-hang ((s slime-input-stream))
-  (with-slots (buffer index) s
-    (when (< index (length buffer))
-      (prog1 (aref buffer index) (incf index)))))
+  (call-with-lock-held
+   (slot-value s 'lock)
+   (lambda ()
+     (with-slots (buffer index) s
+       (when (< index (length buffer))
+         (prog1 (aref buffer index) (incf index)))))))
 
 ;; This CLISP extension is what listen_char actually calls.  The
 ;; default method would call STREAM-READ-CHAR-NO-HANG, so it is a bit
Index: swank-sbcl.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-sbcl.lisp,v
retrieving revision 1.153
diff -u -r1.153 swank-sbcl.lisp
--- swank-sbcl.lisp	22 Mar 2006 16:40:01 -0000	1.153
+++ swank-sbcl.lisp	30 Mar 2006 16:29:11 -0000
@@ -1136,6 +1136,13 @@
     (declare (type function function))
     (sb-thread:with-mutex (lock) (funcall function)))
 
+  (defimplementation make-recursive-lock (&key name)
+    (sb-thread:make-mutex :name name))
+
+  (defimplementation call-with-recursive-lock-held (lock function)
+    (declare (type function function))
+    (sb-thread:with-recursive-lock (lock) (funcall function)))
+
   (defimplementation current-thread ()
     sb-thread:*current-thread*)