/[slime]/slime/swank-gray.lisp
ViewVC logotype

Diff of /slime/swank-gray.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.11 by heller, Mon Aug 4 20:25:38 2008 UTC revision 1.12 by heller, Mon Aug 4 21:38:07 2008 UTC
# Line 15  Line 15 
15     (buffer :initform (make-string 8000))     (buffer :initform (make-string 8000))
16     (fill-pointer :initform 0)     (fill-pointer :initform 0)
17     (column :initform 0)     (column :initform 0)
    ;; true if the Lisp system flushes this stream periodically  
    (interactive-p :initform nil)  
18     (lock :initform (make-recursive-lock :name "buffer write lock"))))     (lock :initform (make-recursive-lock :name "buffer write lock"))))
19    
20    (defmacro with-slime-output-stream (stream &body body)
21      `(with-slots (lock output-fn buffer fill-pointer column) ,stream
22         (call-with-recursive-lock-held lock (lambda () ,@body))))
23    
24  (defmethod stream-write-char ((stream slime-output-stream) char)  (defmethod stream-write-char ((stream slime-output-stream) char)
25    (call-with-recursive-lock-held    (with-slime-output-stream stream
26     (slot-value stream 'lock)      (setf (schar buffer fill-pointer) char)
27     (lambda ()      (incf fill-pointer)
28       (with-slots (buffer fill-pointer column) stream      (incf column)
29         (setf (schar buffer fill-pointer) char)      (when (char= #\newline char)
30         (incf fill-pointer)        (setf column 0))
31         (incf column)      (when (= fill-pointer (length buffer))
32         (when (char= #\newline char)        (finish-output stream)))
          (setf column 0)  
          (force-output stream))  
        (when (= fill-pointer (length buffer))  
          (finish-output stream)))))  
33    char)    char)
34    
35  (defmethod stream-line-column ((stream slime-output-stream))  (defmethod stream-line-column ((stream slime-output-stream))
36    (call-with-recursive-lock-held    (with-slime-output-stream stream column))
    (slot-value stream 'lock)  
    (lambda ()  
      (slot-value stream 'column))))  
37    
38  (defmethod stream-line-length ((stream slime-output-stream))  (defmethod stream-line-length ((stream slime-output-stream))
39    75)    75)
40    
41  (defmethod stream-finish-output ((stream slime-output-stream))  (defmethod stream-finish-output ((stream slime-output-stream))
42    (with-slots (buffer lock fill-pointer output-fn) stream    (with-slime-output-stream stream
43      (call-with-recursive-lock-held      (unless (zerop fill-pointer)
44       lock        (funcall output-fn (subseq buffer 0 fill-pointer))
45       (lambda ()        (setf fill-pointer 0)))
        (unless (zerop fill-pointer)  
          (funcall output-fn (subseq buffer 0 fill-pointer))  
          (setf fill-pointer 0)))))  
46    nil)    nil)
47    
48  (defmethod stream-force-output ((stream slime-output-stream))  (defmethod stream-force-output ((stream slime-output-stream))
49    (with-slots (interactive-p) stream    (stream-finish-output stream))
     (unless interactive-p  
       (stream-finish-output stream)))  
   nil)  
50    
51  (defmethod stream-fresh-line ((stream slime-output-stream))  (defmethod stream-fresh-line ((stream slime-output-stream))
52    (call-with-recursive-lock-held    (with-slime-output-stream stream
53     (slot-value stream 'lock)      (cond ((zerop column) nil)
54     (lambda ()            (t (terpri stream) t))))
      (with-slots (column) stream  
        (cond ((zerop column) nil)  
              (t (terpri stream) t))))))  
55    
56  (defclass slime-input-stream (fundamental-character-input-stream)  (defclass slime-input-stream (fundamental-character-input-stream)
57    ((output-stream :initarg :output-stream)    ((output-stream :initarg :output-stream)

Legend:
Removed from v.1.11  
changed lines
  Added in v.1.12

  ViewVC Help
Powered by ViewVC 1.1.5