slynk-gray.lisp (7042B)
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 ;;; 3 ;;; slynk-gray.lisp --- Gray stream based IO redirection. 4 ;;; 5 ;;; Created 2003 6 ;;; 7 ;;; This code has been placed in the Public Domain. All warranties 8 ;;; are disclaimed. 9 ;;; 10 11 (in-package slynk-backend) 12 13 #.(progn 14 (defvar *gray-stream-symbols* 15 '(fundamental-character-output-stream 16 stream-write-char 17 stream-write-string 18 stream-fresh-line 19 stream-force-output 20 stream-finish-output 21 22 fundamental-character-input-stream 23 stream-read-char 24 stream-peek-char 25 stream-read-line 26 stream-listen 27 stream-unread-char 28 stream-clear-input 29 stream-line-column 30 stream-read-char-no-hang)) 31 nil) 32 33 (defpackage slynk-gray 34 (:use cl slynk-backend) 35 (:import-from #.(gray-package-name) . #.*gray-stream-symbols*) 36 (:export . #.*gray-stream-symbols*)) 37 38 (in-package slynk-gray) 39 40 (defclass sly-output-stream (fundamental-character-output-stream) 41 ((output-fn :initarg :output-fn) 42 (buffer :initform (make-string 8000)) 43 (fill-pointer :initform 0) 44 (column :initform 0) 45 (lock :initform (make-lock :name "buffer write lock")) 46 (flush-thread :initarg :flush-thread 47 :initform nil 48 :accessor flush-thread) 49 (flush-scheduled :initarg :flush-scheduled 50 :initform nil 51 :accessor flush-scheduled))) 52 53 (defun maybe-schedule-flush (stream) 54 (when (and (flush-thread stream) 55 (not (flush-scheduled stream))) 56 (setf (flush-scheduled stream) t) 57 (send (flush-thread stream) t))) 58 59 (defmacro with-sly-output-stream (stream &body body) 60 `(with-slots (lock output-fn buffer fill-pointer column) ,stream 61 (call-with-lock-held lock (lambda () ,@body)))) 62 63 (defmethod stream-write-char ((stream sly-output-stream) char) 64 (with-sly-output-stream stream 65 (setf (schar buffer fill-pointer) char) 66 (incf fill-pointer) 67 (incf column) 68 (when (char= #\newline char) 69 (setf column 0)) 70 (if (= fill-pointer (length buffer)) 71 (finish-output stream) 72 (maybe-schedule-flush stream))) 73 char) 74 75 (defmethod stream-write-string ((stream sly-output-stream) string 76 &optional start end) 77 (with-sly-output-stream stream 78 (let* ((start (or start 0)) 79 (end (or end (length string))) 80 (len (length buffer)) 81 (count (- end start)) 82 (free (- len fill-pointer))) 83 (when (>= count free) 84 (stream-finish-output stream)) 85 (cond ((< count len) 86 (replace buffer string :start1 fill-pointer 87 :start2 start :end2 end) 88 (incf fill-pointer count) 89 (maybe-schedule-flush stream)) 90 (t 91 (funcall output-fn (subseq string start end)))) 92 (let ((last-newline (position #\newline string :from-end t 93 :start start :end end))) 94 (setf column (if last-newline 95 (- end last-newline 1) 96 (+ column count)))))) 97 string) 98 99 (defmethod stream-line-column ((stream sly-output-stream)) 100 (with-sly-output-stream stream column)) 101 102 (defmethod reset-stream-line-column ((stream sly-output-stream)) 103 (with-sly-output-stream stream (setf column 0))) 104 105 #+sbcl 106 (defmethod reset-stream-line-column ((stream sb-sys:fd-stream)) 107 (with-slots (sb-impl::output-column) stream 108 (setf sb-impl::output-column 0))) 109 110 #+cmucl 111 (defmethod reset-stream-line-column ((stream system:fd-stream)) 112 (with-slots (lisp::char-pos) stream 113 (setf lisp::char-pos 0))) 114 115 (defmethod stream-finish-output ((stream sly-output-stream)) 116 (with-sly-output-stream stream 117 (unless (zerop fill-pointer) 118 (funcall output-fn (subseq buffer 0 fill-pointer)) 119 (setf fill-pointer 0)) 120 (setf (flush-scheduled stream) nil)) 121 nil) 122 123 #+(and sbcl sb-thread) 124 (defmethod stream-force-output :around ((stream sly-output-stream)) 125 ;; Workaround for deadlocks between the world-lock and auto-flush-thread 126 ;; buffer write lock. 127 ;; 128 ;; Another alternative would be to grab the world-lock here, but that's less 129 ;; future-proof, and could introduce other lock-ordering issues in the 130 ;; future. 131 (handler-case 132 (sb-sys:with-deadline (:seconds 0.1) 133 (call-next-method)) 134 (sb-sys:deadline-timeout () 135 nil))) 136 137 (defmethod stream-force-output ((stream sly-output-stream)) 138 (stream-finish-output stream)) 139 140 (defmethod stream-fresh-line ((stream sly-output-stream)) 141 (with-sly-output-stream stream 142 (cond ((zerop column) nil) 143 (t (terpri stream) t)))) 144 145 (defclass sly-input-stream (fundamental-character-input-stream) 146 ((input-fn :initarg :input-fn) 147 (buffer :initform "") (index :initform 0) 148 (lock :initform (make-lock :name "buffer read lock")))) 149 150 (defmethod stream-read-char ((s sly-input-stream)) 151 (call-with-lock-held 152 (slot-value s 'lock) 153 (lambda () 154 (with-slots (buffer index input-fn) s 155 (when (= index (length buffer)) 156 (let ((string (funcall input-fn))) 157 (cond ((zerop (length string)) 158 (return-from stream-read-char :eof)) 159 (t 160 (setf buffer string) 161 (setf index 0))))) 162 (assert (plusp (length buffer))) 163 (prog1 (aref buffer index) (incf index)))))) 164 165 (defmethod stream-listen ((s sly-input-stream)) 166 (call-with-lock-held 167 (slot-value s 'lock) 168 (lambda () 169 (with-slots (buffer index) s 170 (< index (length buffer)))))) 171 172 (defmethod stream-unread-char ((s sly-input-stream) char) 173 (call-with-lock-held 174 (slot-value s 'lock) 175 (lambda () 176 (with-slots (buffer index) s 177 (decf index) 178 (cond ((eql (aref buffer index) char) 179 (setf (aref buffer index) char)) 180 (t 181 (warn "stream-unread-char: ignoring ~S (expected ~S)" 182 char (aref buffer index))))))) 183 nil) 184 185 (defmethod stream-clear-input ((s sly-input-stream)) 186 (call-with-lock-held 187 (slot-value s 'lock) 188 (lambda () 189 (with-slots (buffer index) s 190 (setf buffer "" 191 index 0)))) 192 nil) 193 194 (defmethod stream-line-column ((s sly-input-stream)) 195 nil) 196 197 (defmethod stream-read-char-no-hang ((s sly-input-stream)) 198 (call-with-lock-held 199 (slot-value s 'lock) 200 (lambda () 201 (with-slots (buffer index) s 202 (when (< index (length buffer)) 203 (prog1 (aref buffer index) (incf index))))))) 204 205 206 ;;; 207 208 (defimplementation make-auto-flush-thread (stream) 209 (if (typep stream 'sly-output-stream) 210 (setf (flush-thread stream) 211 (spawn (lambda () (auto-flush-loop stream 0.08 t)) 212 :name "auto-flush-thread")) 213 (spawn (lambda () (auto-flush-loop stream *auto-flush-interval*)) 214 :name "auto-flush-thread"))) 215 216 (defimplementation make-output-stream (write-string) 217 (make-instance 'sly-output-stream :output-fn write-string)) 218 219 (defimplementation make-input-stream (read-string) 220 (make-instance 'sly-input-stream :input-fn read-string))