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

Diff of /slime/swank-sbcl.lisp

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

revision 1.177 by nsiivola, Thu Apr 12 19:00:09 2007 UTC revision 1.178 by mbaringer, Wed May 23 14:22:06 2007 UTC
# Line 1193  stack." Line 1193  stack."
1193                                                mutex))))))))                                                mutex))))))))
1194    
1195    
1196  ;;; Auto-flush streams    ;; Auto-flush streams
1197    
1198    ;; XXX race conditions    (defvar *auto-flush-interval* 0.15
1199    (defvar *auto-flush-streams* '())      "How often to flush interactive streams. This valu is passed
1200        directly to cl:sleep.")
1201    
1202      (defvar *auto-flush-lock* (make-recursive-lock :name "auto flush"))
1203    
1204    (defvar *auto-flush-thread* nil)    (defvar *auto-flush-thread* nil)
1205    
1206      (defvar *auto-flush-streams* '())
1207    
1208    (defimplementation make-stream-interactive (stream)    (defimplementation make-stream-interactive (stream)
1209      (setq *auto-flush-streams* (adjoin stream *auto-flush-streams*))      (call-with-recursive-lock-held
1210      (unless *auto-flush-thread*       *auto-flush-lock*
1211        (setq *auto-flush-thread*       (lambda ()
1212              (sb-thread:make-thread #'flush-streams         (pushnew stream *auto-flush-streams*)
1213                                     :name "auto-flush-thread"))))         (unless *auto-flush-thread*
1214             (setq *auto-flush-thread*
1215                   (sb-thread:make-thread #'flush-streams
1216                                          :name "auto-flush-thread"))))))
1217    
1218    (defun flush-streams ()    (defun flush-streams ()
1219      (loop      (loop
1220       (setq *auto-flush-streams*       (call-with-recursive-lock-held
1221             (remove-if (lambda (x)        *auto-flush-lock*
1222                          (not (and (open-stream-p x)        (lambda ()
1223                                    (output-stream-p x))))          (setq *auto-flush-streams*
1224                        *auto-flush-streams*))                (remove-if (lambda (x)
1225       (mapc #'finish-output *auto-flush-streams*)                             (not (and (open-stream-p x)
1226       (sleep 0.15)))                                       (output-stream-p x))))
1227                             *auto-flush-streams*))
1228            (mapc #'finish-output *auto-flush-streams*)))
1229         (sleep *auto-flush-interval*)))
1230    
1231    )    )
1232    

Legend:
Removed from v.1.177  
changed lines
  Added in v.1.178

  ViewVC Help
Powered by ViewVC 1.1.5