Klimi's new dotfiles with stow.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

207 rivejä
6.5 KiB

;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; swank-gray.lisp --- Gray stream based IO redirection.
;;;
;;; Created 2003
;;;
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
;;;
(in-package swank/backend)
#.(progn
(defvar *gray-stream-symbols*
'(fundamental-character-output-stream
stream-write-char
stream-write-string
stream-fresh-line
stream-force-output
stream-finish-output
fundamental-character-input-stream
stream-read-char
stream-peek-char
stream-read-line
stream-listen
stream-unread-char
stream-clear-input
stream-line-column
stream-read-char-no-hang))
nil)
(defpackage swank/gray
(:use cl swank/backend)
(:import-from #.(gray-package-name) . #.*gray-stream-symbols*)
(:export . #.*gray-stream-symbols*))
(in-package swank/gray)
(defclass slime-output-stream (fundamental-character-output-stream)
((output-fn :initarg :output-fn)
(buffer :initform (make-string 8000))
(fill-pointer :initform 0)
(column :initform 0)
(lock :initform (make-lock :name "buffer write lock"))
(flush-thread :initarg :flush-thread
:initform nil
:accessor flush-thread)
(flush-scheduled :initarg :flush-scheduled
:initform nil
:accessor flush-scheduled)))
(defun maybe-schedule-flush (stream)
(when (and (flush-thread stream)
(not (flush-scheduled stream)))
(setf (flush-scheduled stream) t)
(send (flush-thread stream) t)))
(defmacro with-slime-output-stream (stream &body body)
`(with-slots (lock output-fn buffer fill-pointer column) ,stream
(call-with-lock-held lock (lambda () ,@body))))
(defmethod stream-write-char ((stream slime-output-stream) char)
(with-slime-output-stream stream
(setf (schar buffer fill-pointer) char)
(incf fill-pointer)
(incf column)
(when (char= #\newline char)
(setf column 0))
(if (= fill-pointer (length buffer))
(finish-output stream)
(maybe-schedule-flush stream)))
char)
(defmethod stream-write-string ((stream slime-output-stream) string
&optional start end)
(with-slime-output-stream stream
(let* ((start (or start 0))
(end (or end (length string)))
(len (length buffer))
(count (- end start))
(free (- len fill-pointer)))
(when (>= count free)
(stream-finish-output stream))
(cond ((< count len)
(replace buffer string :start1 fill-pointer
:start2 start :end2 end)
(incf fill-pointer count)
(maybe-schedule-flush stream))
(t
(funcall output-fn (subseq string start end))))
(let ((last-newline (position #\newline string :from-end t
:start start :end end)))
(setf column (if last-newline
(- end last-newline 1)
(+ column count))))))
string)
(defmethod stream-line-column ((stream slime-output-stream))
(with-slime-output-stream stream column))
(defmethod stream-finish-output ((stream slime-output-stream))
(with-slime-output-stream stream
(unless (zerop fill-pointer)
(funcall output-fn (subseq buffer 0 fill-pointer))
(setf fill-pointer 0))
(setf (flush-scheduled stream) nil))
nil)
#+(and sbcl sb-thread)
(defmethod stream-force-output :around ((stream slime-output-stream))
;; Workaround for deadlocks between the world-lock and auto-flush-thread
;; buffer write lock.
;;
;; Another alternative would be to grab the world-lock here, but that's less
;; future-proof, and could introduce other lock-ordering issues in the
;; future.
(handler-case
(sb-sys:with-deadline (:seconds 0.1)
(call-next-method))
(sb-sys:deadline-timeout ()
nil)))
(defmethod stream-force-output ((stream slime-output-stream))
(stream-finish-output stream))
(defmethod stream-fresh-line ((stream slime-output-stream))
(with-slime-output-stream stream
(cond ((zerop column) nil)
(t (terpri stream) t))))
(defclass slime-input-stream (fundamental-character-input-stream)
((input-fn :initarg :input-fn)
(buffer :initform "") (index :initform 0)
(lock :initform (make-lock :name "buffer read lock"))))
(defmethod stream-read-char ((s slime-input-stream))
(call-with-lock-held
(slot-value s 'lock)
(lambda ()
(with-slots (buffer index input-fn) s
(when (= index (length buffer))
(let ((string (funcall input-fn)))
(cond ((zerop (length string))
(return-from stream-read-char :eof))
(t
(setf buffer string)
(setf index 0)))))
(assert (plusp (length buffer)))
(prog1 (aref buffer index) (incf index))))))
(defmethod stream-listen ((s slime-input-stream))
(call-with-lock-held
(slot-value s 'lock)
(lambda ()
(with-slots (buffer index) s
(< index (length buffer))))))
(defmethod stream-unread-char ((s slime-input-stream) char)
(call-with-lock-held
(slot-value s 'lock)
(lambda ()
(with-slots (buffer index) s
(decf index)
(cond ((eql (aref buffer index) char)
(setf (aref buffer index) char))
(t
(warn "stream-unread-char: ignoring ~S (expected ~S)"
char (aref buffer index)))))))
nil)
(defmethod stream-clear-input ((s slime-input-stream))
(call-with-lock-held
(slot-value s 'lock)
(lambda ()
(with-slots (buffer index) s
(setf buffer ""
index 0))))
nil)
(defmethod stream-line-column ((s slime-input-stream))
nil)
(defmethod stream-read-char-no-hang ((s slime-input-stream))
(call-with-lock-held
(slot-value s 'lock)
(lambda ()
(with-slots (buffer index) s
(when (< index (length buffer))
(prog1 (aref buffer index) (incf index)))))))
;;;
(defimplementation make-auto-flush-thread (stream)
(if (typep stream 'slime-output-stream)
(setf (flush-thread stream)
(spawn (lambda () (auto-flush-loop stream 0.08 t))
:name "auto-flush-thread"))
(spawn (lambda () (auto-flush-loop stream *auto-flush-interval*))
:name "auto-flush-thread")))
(defimplementation make-output-stream (write-string)
(make-instance 'slime-output-stream :output-fn write-string))
(defimplementation make-input-stream (read-string)
(make-instance 'slime-input-stream :input-fn read-string))