[slime-cvs] CVS update: slime/swank-sbcl.lisp slime/swank-openmcl.lisp

[Helmut Eller]

Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv21956

Modified Files:
	swank-sbcl.lisp swank-openmcl.lisp 
Log Message:
Gray stream based input redirection from Emacs.

Date: Fri Oct 31 11:58:37 2003
Author: heller

Index: slime/swank-sbcl.lisp
diff -u slime/swank-sbcl.lisp:1.15 slime/swank-sbcl.lisp:1.16
--- slime/swank-sbcl.lisp:1.15	Wed Oct 29 18:53:55 2003
+++ slime/swank-sbcl.lisp	Fri Oct 31 11:58:37 2003
@@ -68,7 +68,10 @@
   "Accept one Swank TCP connection on SOCKET and then close it."
   (let* ((socket (sb-bsd-sockets:socket-accept server-socket))
 	 (stream (sb-bsd-sockets:socket-make-stream 
-		  socket :input t :output t :element-type 'base-char)))
+		  socket :input t :output t :element-type 'base-char))
+         (out (make-instance 'slime-output-stream))
+         (in (make-instance 'slime-input-stream))
+         (io (make-two-way-stream in out)))
     (sb-sys:invalidate-descriptor (sb-bsd-sockets:socket-file-descriptor
                                    server-socket))
     (sb-bsd-sockets:socket-close server-socket)
@@ -76,22 +79,18 @@
      (sb-bsd-sockets:socket-file-descriptor socket)
      :input (lambda (fd) 
 	      (declare (ignore fd))
-	      (serve-request stream)))))
+	      (serve-request stream out in io)))))
 
-(defun serve-request (*emacs-io*)
+(defun serve-request (*emacs-io* *slime-output* *slime-input* *slime-io*)
   "Read and process a request from a SWANK client.
 The request is read from the socket as a sexp and then evaluated."
   (catch 'slime-toplevel
-    (let* ((*slime-output* (make-instance 'slime-output-stream))
-           (*slime-input* *standard-input*)
-           (*slime-io* (make-two-way-stream *slime-input* *slime-output*)))
-      (handler-case (read-from-emacs)
-        (slime-read-error (e)
-          (when *swank-debug-p*
-            (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e))
-          (sb-sys:invalidate-descriptor (sb-sys:fd-stream-fd *emacs-io*))
-          (close *emacs-io*))))))
-
+    (handler-case (read-from-emacs)
+      (slime-read-error (e)
+        (when *swank-debug-p*
+          (format *debug-io* "~&;; Connection to Emacs lost.~%;; [~A]~%" e))
+        (sb-sys:invalidate-descriptor (sb-sys:fd-stream-fd *emacs-io*))
+        (close *emacs-io*)))))
 
 #|
 
@@ -176,6 +175,18 @@
   (send-to-emacs `(:read-output ,(get-output-stream-string
                                   (slime-output-stream-buffer stream))))
   (setf (slime-output-stream-buffer stream) (make-string-output-stream)))
+
+(defclass slime-input-stream (sb-gray:fundamental-character-input-stream)
+  ((buffered-char :initform nil)))
+
+(defmethod sb-gray:stream-read-char ((s slime-input-stream))
+  (with-slots (buffered-char) s
+    (cond (buffered-char (prog1 buffered-char (setf buffered-char nil)))
+          (t (slime-read-char)))))
+
+(defmethod sb-gray:stream-unread-char ((s slime-input-stream) char)
+  (setf (slot-value s 'buffered-char) char)
+  nil)
 
 ;;; Utilities
 


Index: slime/swank-openmcl.lisp
diff -u slime/swank-openmcl.lisp:1.14 slime/swank-openmcl.lisp:1.15
--- slime/swank-openmcl.lisp:1.14	Wed Oct 29 18:54:36 2003
+++ slime/swank-openmcl.lisp	Fri Oct 31 11:58:37 2003
@@ -13,7 +13,7 @@
 ;;; The LLGPL is also available online at
 ;;; http://opensource.franz.com/preamble.html
 ;;;
-;;;   $Id: swank-openmcl.lisp,v 1.14 2003/10/29 23:54:36 heller Exp $
+;;;   $Id: swank-openmcl.lisp,v 1.15 2003/10/31 16:58:37 heller Exp $
 ;;;
 
 ;;;
@@ -85,7 +85,7 @@
 until the remote Emacs goes away."
   (unwind-protect
        (let* ((*slime-output* (make-instance 'slime-output-stream))
-              (*slime-input* *standard-input*)
+              (*slime-input* (make-instance 'slime-input-stream))
               (*slime-io* (make-two-way-stream *slime-input* *slime-output*)))
          (loop
             (catch 'slime-toplevel
@@ -117,6 +117,18 @@
   (send-to-emacs `(:read-output ,(get-output-stream-string
                                   (slime-output-stream-buffer stream))))
   (setf (slime-output-stream-buffer stream) (make-string-output-stream)))
+
+(defclass slime-input-stream (ccl::fundamental-character-input-stream)
+  ((buffered-char :initform nil)))
+
+(defmethod ccl:stream-read-char ((s slime-input-stream))
+  (with-slots (buffered-char) s
+    (cond (buffered-char (prog1 buffered-char (setf buffered-char nil)))
+          (t (slime-read-char)))))
+
+(defmethod ccl:stream-unread-char ((s slime-input-stream) char)
+  (setf (slot-value s 'buffered-char) char)
+  nil)
 
 ;;; Evaluation