[slime-cvs] CVS slime

[heller]

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

Modified Files:
	ChangeLog swank-gray.lisp swank-lispworks.lisp swank-sbcl.lisp 
Log Message:
* swank-gray.lisp (slime-output-stream): Add a slot
"interactive-p" which should be true for streams which are flushed
periodically by the Lisp system.  Update the relevant accordingly.

--- /project/slime/cvsroot/slime/ChangeLog	2008/08/04 20:25:33	1.1386
+++ /project/slime/cvsroot/slime/ChangeLog	2008/08/04 20:25:37	1.1387
@@ -1,5 +1,9 @@
 2008-08-04  Helmut Eller  <heller at common-lisp.net>
 
+	* swank-gray.lisp (slime-output-stream): Add a slot
+	"interactive-p" which should be true for streams which are flushed
+	periodically by the Lisp system.  Update the relevant accordingly.
+
 	* swank-scl.lisp (receive-if): Implemented.
 
 	* swank-cmucl.lisp (receive,receive-if): Test for new messages in
--- /project/slime/cvsroot/slime/swank-gray.lisp	2006/04/12 08:43:55	1.10
+++ /project/slime/cvsroot/slime/swank-gray.lisp	2008/08/04 20:25:38	1.11
@@ -15,7 +15,8 @@
    (buffer :initform (make-string 8000))
    (fill-pointer :initform 0)
    (column :initform 0)
-   (last-flush-time :initform (get-internal-real-time))
+   ;; true if the Lisp system flushes this stream periodically
+   (interactive-p :initform nil) 
    (lock :initform (make-recursive-lock :name "buffer write lock"))))
 
 (defmethod stream-write-char ((stream slime-output-stream) char)
@@ -43,27 +44,19 @@
   75)
 
 (defmethod stream-finish-output ((stream slime-output-stream))
-  (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)))))
+  (with-slots (buffer lock fill-pointer output-fn) stream
+    (call-with-recursive-lock-held
+     lock
+     (lambda ()
+       (unless (zerop fill-pointer)
+         (funcall output-fn (subseq buffer 0 fill-pointer))
+         (setf fill-pointer 0)))))
   nil)
 
 (defmethod stream-force-output ((stream slime-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))))))
+  (with-slots (interactive-p) stream
+    (unless interactive-p
+      (stream-finish-output stream)))
   nil)
 
 (defmethod stream-fresh-line ((stream slime-output-stream))
--- /project/slime/cvsroot/slime/swank-lispworks.lisp	2008/08/04 09:13:06	1.102
+++ /project/slime/cvsroot/slime/swank-lispworks.lisp	2008/08/04 20:25:38	1.103
@@ -800,7 +800,9 @@
                        nil)
     (let ((lw:*handle-warn-on-redefinition* :warn))
       (defmethod stream:stream-soft-force-output  ((o (eql stream)))
-        (force-output o)))))
+        (force-output o))
+      (when (typep stream 'slime-output-stream)
+        (setf (slot-value stream 'interactive-p) t)))))
 
 (defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args)
   (apply (swank-sym :y-or-n-p-in-emacs) msg args))
--- /project/slime/cvsroot/slime/swank-sbcl.lisp	2008/08/03 18:23:10	1.202
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp	2008/08/04 20:25:38	1.203
@@ -1328,7 +1328,9 @@
        (unless *auto-flush-thread*
          (setq *auto-flush-thread*
                (sb-thread:make-thread #'flush-streams
-                                      :name "auto-flush-thread"))))))
+                                      :name "auto-flush-thread")))))
+    (when (typep stream 'slime-output-stream)
+      (setf (slot-value stream 'interactive-p) t)))
 
   (defun flush-streams ()
     (loop