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

Diff of /slime/swank-cmucl.lisp

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

revision 1.191 by heller, Sun Aug 31 11:58:01 2008 UTC revision 1.192 by heller, Thu Sep 11 10:31:35 2008 UTC
# Line 205  specific functions.") Line 205  specific functions.")
205  (defstruct (slime-output-stream  (defstruct (slime-output-stream
206               (:include lisp::lisp-stream               (:include lisp::lisp-stream
207                         (lisp::misc #'sos/misc)                         (lisp::misc #'sos/misc)
208                         (lisp::out #'sos/out)                         (lisp::out #'sos/write-char)
209                         (lisp::sout #'sos/sout))                         (lisp::sout #'sos/write-string))
210               (:conc-name sos.)               (:conc-name sos.)
211               (:print-function %print-slime-output-stream)               (:print-function %print-slime-output-stream)
212               (:constructor make-slime-output-stream (output-fn)))               (:constructor make-slime-output-stream (output-fn)))
213    (output-fn nil :type function)    (output-fn nil :type function)
214    (buffer (make-string 8000) :type string)    (buffer (make-string 4000) :type string)
215    (index 0 :type kernel:index)    (index 0 :type kernel:index)
216    (column 0 :type kernel:index)    (column 0 :type kernel:index))
   (last-flush-time (get-internal-real-time) :type unsigned-byte))  
217    
218  (defun %print-slime-output-stream (s stream d)  (defun %print-slime-output-stream (s stream d)
219    (declare (ignore d))    (declare (ignore d))
220    (print-unreadable-object (s stream :type t :identity t)))    (print-unreadable-object (s stream :type t :identity t)))
221    
222  (defun sos/out (stream char)  (defun sos/write-char (stream char)
223    (system:without-interrupts    (let ((pending-output nil))
224      (let ((buffer (sos.buffer stream))      (system:without-interrupts
225            (index (sos.index stream)))        (let ((buffer (sos.buffer stream))
226        (setf (schar buffer index) char)              (index (sos.index stream)))
227        (setf (sos.index stream) (1+ index))          (setf (schar buffer index) char)
228        (incf (sos.column stream))          (setf (sos.index stream) (1+ index))
229        (when (char= #\newline char)          (incf (sos.column stream))
230          (setf (sos.column stream) 0)          (when (char= #\newline char)
231          (force-output stream))            (setf (sos.column stream) 0)
232        (when (= index (1- (length buffer)))            #+(or)(setq pending-output (sos/reset-buffer stream))
233          (finish-output stream)))            )
234      char))          (when (= index (1- (length buffer)))
235              (setq pending-output (sos/reset-buffer stream)))))
236        (when pending-output
237          (funcall (sos.output-fn stream) pending-output)))
238      char)
239    
240    (defun sos/write-string (stream string start end)
241      (loop for i from start below end
242            do (sos/write-char stream (aref string i))))
243    
244    (defun sos/flush (stream)
245      (let ((string (sos/reset-buffer stream)))
246        (when string
247          (funcall (sos.output-fn stream) string))
248        nil))
249    
250  (defun sos/sout (stream string start end)  (defun sos/reset-buffer (stream)
251    (system:without-interrupts    (system:without-interrupts
252      (loop for i from start below end      (let ((end (sos.index stream)))
253            do (sos/out stream (aref string i)))))        (unless (zerop end)
254            (prog1 (subseq (sos.buffer stream) 0 end)
255              (setf (sos.index stream) 0))))))
256    
 (defun log-stream-op (stream operation)  
   stream operation  
   #+(or)  
   (progn  
     (format sys:*tty* "~S @ ~D ~A~%" operation  
             (sos.index stream)  
             (/ (- (get-internal-real-time) (sos.last-flush-time stream))  
              (coerce internal-time-units-per-second 'double-float)))  
     (finish-output sys:*tty*)))  
   
257  (defun sos/misc (stream operation &optional arg1 arg2)  (defun sos/misc (stream operation &optional arg1 arg2)
258    (declare (ignore arg1 arg2))    (declare (ignore arg1 arg2))
259    (case operation    (case operation
260      (:finish-output      ((:force-output :finish-output) (sos/flush stream))
      (log-stream-op stream operation)  
      (system:without-interrupts  
        (let ((end (sos.index stream)))  
          (unless (zerop end)  
            (let ((s (subseq (sos.buffer stream) 0 end)))  
              (setf (sos.index stream) 0)  
              (funcall (sos.output-fn stream) s))  
            (setf (sos.last-flush-time stream) (get-internal-real-time)))))  
      nil)  
     (:force-output  
      (log-stream-op stream operation)  
      (sos/misc-force-output stream)  
      nil)  
261      (:charpos (sos.column stream))      (:charpos (sos.column stream))
262      (:line-length 75)      (:line-length 75)
263      (:file-position nil)      (:file-position nil)
# Line 274  specific functions.") Line 266  specific functions.")
266      (:close nil)      (:close nil)
267      (t (format *terminal-io* "~&~Astream: ~S~%" stream operation))))      (t (format *terminal-io* "~&~Astream: ~S~%" stream operation))))
268    
 (defun sos/misc-force-output (stream)  
   (system:without-interrupts  
     (unless (or (zerop (sos.index stream))  
                 (loop with buffer = (sos.buffer stream)  
                       for i from 0 below (sos.index stream)  
                       always (char= (aref buffer i) #\newline)))  
       (let ((last (sos.last-flush-time stream))  
             (now (get-internal-real-time)))  
         (when (> (/ (- now last)  
                     (coerce internal-time-units-per-second 'double-float))  
                  0.1)  
           (finish-output stream))))))  
   
269  (defstruct (slime-input-stream  (defstruct (slime-input-stream
270               (:include string-stream               (:include string-stream
271                         (lisp::in #'sis/in)                         (lisp::in #'sis/in)

Legend:
Removed from v.1.191  
changed lines
  Added in v.1.192

  ViewVC Help
Powered by ViewVC 1.1.5