slynk-gray.lisp (6628B)
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 stream-finish-output ((stream sly-output-stream)) 103 (with-sly-output-stream stream 104 (unless (zerop fill-pointer) 105 (funcall output-fn (subseq buffer 0 fill-pointer)) 106 (setf fill-pointer 0)) 107 (setf (flush-scheduled stream) nil)) 108 nil) 109 110 #+(and sbcl sb-thread) 111 (defmethod stream-force-output :around ((stream sly-output-stream)) 112 ;; Workaround for deadlocks between the world-lock and auto-flush-thread 113 ;; buffer write lock. 114 ;; 115 ;; Another alternative would be to grab the world-lock here, but that's less 116 ;; future-proof, and could introduce other lock-ordering issues in the 117 ;; future. 118 (handler-case 119 (sb-sys:with-deadline (:seconds 0.1) 120 (call-next-method)) 121 (sb-sys:deadline-timeout () 122 nil))) 123 124 (defmethod stream-force-output ((stream sly-output-stream)) 125 (stream-finish-output stream)) 126 127 (defmethod stream-fresh-line ((stream sly-output-stream)) 128 (with-sly-output-stream stream 129 (cond ((zerop column) nil) 130 (t (terpri stream) t)))) 131 132 (defclass sly-input-stream (fundamental-character-input-stream) 133 ((input-fn :initarg :input-fn) 134 (buffer :initform "") (index :initform 0) 135 (lock :initform (make-lock :name "buffer read lock")))) 136 137 (defmethod stream-read-char ((s sly-input-stream)) 138 (call-with-lock-held 139 (slot-value s 'lock) 140 (lambda () 141 (with-slots (buffer index input-fn) s 142 (when (= index (length buffer)) 143 (let ((string (funcall input-fn))) 144 (cond ((zerop (length string)) 145 (return-from stream-read-char :eof)) 146 (t 147 (setf buffer string) 148 (setf index 0))))) 149 (assert (plusp (length buffer))) 150 (prog1 (aref buffer index) (incf index)))))) 151 152 (defmethod stream-listen ((s sly-input-stream)) 153 (call-with-lock-held 154 (slot-value s 'lock) 155 (lambda () 156 (with-slots (buffer index) s 157 (< index (length buffer)))))) 158 159 (defmethod stream-unread-char ((s sly-input-stream) char) 160 (call-with-lock-held 161 (slot-value s 'lock) 162 (lambda () 163 (with-slots (buffer index) s 164 (decf index) 165 (cond ((eql (aref buffer index) char) 166 (setf (aref buffer index) char)) 167 (t 168 (warn "stream-unread-char: ignoring ~S (expected ~S)" 169 char (aref buffer index))))))) 170 nil) 171 172 (defmethod stream-clear-input ((s sly-input-stream)) 173 (call-with-lock-held 174 (slot-value s 'lock) 175 (lambda () 176 (with-slots (buffer index) s 177 (setf buffer "" 178 index 0)))) 179 nil) 180 181 (defmethod stream-line-column ((s sly-input-stream)) 182 nil) 183 184 (defmethod stream-read-char-no-hang ((s sly-input-stream)) 185 (call-with-lock-held 186 (slot-value s 'lock) 187 (lambda () 188 (with-slots (buffer index) s 189 (when (< index (length buffer)) 190 (prog1 (aref buffer index) (incf index))))))) 191 192 193 ;;; 194 195 (defimplementation make-auto-flush-thread (stream) 196 (if (typep stream 'sly-output-stream) 197 (setf (flush-thread stream) 198 (spawn (lambda () (auto-flush-loop stream 0.08 t)) 199 :name "auto-flush-thread")) 200 (spawn (lambda () (auto-flush-loop stream *auto-flush-interval*)) 201 :name "auto-flush-thread"))) 202 203 (defimplementation make-output-stream (write-string) 204 (make-instance 'sly-output-stream :output-fn write-string)) 205 206 (defimplementation make-input-stream (read-string) 207 (make-instance 'sly-input-stream :input-fn read-string))