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

Contents of /slime/swank-gray.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (show annotations)
Mon Aug 4 21:38:07 2008 UTC (5 years, 8 months ago) by heller
Branch: MAIN
Changes since 1.11: +21 -35 lines
* swank-gray.lisp (slime-output-stream): Undo last change.
Make force-output and finish-output do the same.
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; swank-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 :swank-backend)
12
13 (defclass slime-output-stream (fundamental-character-output-stream)
14 ((output-fn :initarg :output-fn)
15 (buffer :initform (make-string 8000))
16 (fill-pointer :initform 0)
17 (column :initform 0)
18 (lock :initform (make-recursive-lock :name "buffer write lock"))))
19
20 (defmacro with-slime-output-stream (stream &body body)
21 `(with-slots (lock output-fn buffer fill-pointer column) ,stream
22 (call-with-recursive-lock-held lock (lambda () ,@body))))
23
24 (defmethod stream-write-char ((stream slime-output-stream) char)
25 (with-slime-output-stream stream
26 (setf (schar buffer fill-pointer) char)
27 (incf fill-pointer)
28 (incf column)
29 (when (char= #\newline char)
30 (setf column 0))
31 (when (= fill-pointer (length buffer))
32 (finish-output stream)))
33 char)
34
35 (defmethod stream-line-column ((stream slime-output-stream))
36 (with-slime-output-stream stream column))
37
38 (defmethod stream-line-length ((stream slime-output-stream))
39 75)
40
41 (defmethod stream-finish-output ((stream slime-output-stream))
42 (with-slime-output-stream stream
43 (unless (zerop fill-pointer)
44 (funcall output-fn (subseq buffer 0 fill-pointer))
45 (setf fill-pointer 0)))
46 nil)
47
48 (defmethod stream-force-output ((stream slime-output-stream))
49 (stream-finish-output stream))
50
51 (defmethod stream-fresh-line ((stream slime-output-stream))
52 (with-slime-output-stream stream
53 (cond ((zerop column) nil)
54 (t (terpri stream) t))))
55
56 (defclass slime-input-stream (fundamental-character-input-stream)
57 ((output-stream :initarg :output-stream)
58 (input-fn :initarg :input-fn)
59 (buffer :initform "") (index :initform 0)
60 (lock :initform (make-lock :name "buffer read lock"))))
61
62 (defmethod stream-read-char ((s slime-input-stream))
63 (call-with-lock-held
64 (slot-value s 'lock)
65 (lambda ()
66 (with-slots (buffer index output-stream input-fn) s
67 (when (= index (length buffer))
68 (when output-stream
69 (finish-output output-stream))
70 (let ((string (funcall input-fn)))
71 (cond ((zerop (length string))
72 (return-from stream-read-char :eof))
73 (t
74 (setf buffer string)
75 (setf index 0)))))
76 (assert (plusp (length buffer)))
77 (prog1 (aref buffer index) (incf index))))))
78
79 (defmethod stream-listen ((s slime-input-stream))
80 (call-with-lock-held
81 (slot-value s 'lock)
82 (lambda ()
83 (with-slots (buffer index) s
84 (< index (length buffer))))))
85
86 (defmethod stream-unread-char ((s slime-input-stream) char)
87 (call-with-lock-held
88 (slot-value s 'lock)
89 (lambda ()
90 (with-slots (buffer index) s
91 (decf index)
92 (cond ((eql (aref buffer index) char)
93 (setf (aref buffer index) char))
94 (t
95 (warn "stream-unread-char: ignoring ~S (expected ~S)"
96 char (aref buffer index)))))))
97 nil)
98
99 (defmethod stream-clear-input ((s slime-input-stream))
100 (call-with-lock-held
101 (slot-value s 'lock)
102 (lambda ()
103 (with-slots (buffer index) s
104 (setf buffer ""
105 index 0))))
106 nil)
107
108 (defmethod stream-line-column ((s slime-input-stream))
109 nil)
110
111 (defmethod stream-line-length ((s slime-input-stream))
112 75)
113
114
115 ;;; CLISP extensions
116
117 ;; We have to define an additional method for the sake of the C
118 ;; function listen_char (see src/stream.d), on which SYS::READ-FORM
119 ;; depends.
120
121 ;; We could make do with either of the two methods below.
122
123 (defmethod stream-read-char-no-hang ((s slime-input-stream))
124 (call-with-lock-held
125 (slot-value s 'lock)
126 (lambda ()
127 (with-slots (buffer index) s
128 (when (< index (length buffer))
129 (prog1 (aref buffer index) (incf index)))))))
130
131 ;; This CLISP extension is what listen_char actually calls. The
132 ;; default method would call STREAM-READ-CHAR-NO-HANG, so it is a bit
133 ;; more efficient to define it directly.
134
135 (defmethod stream-read-char-will-hang-p ((s slime-input-stream))
136 (with-slots (buffer index) s
137 (= index (length buffer))))
138
139
140 ;;;
141 (defimplementation make-fn-streams (input-fn output-fn)
142 (let* ((output (make-instance 'slime-output-stream
143 :output-fn output-fn))
144 (input (make-instance 'slime-input-stream
145 :input-fn input-fn
146 :output-stream output)))
147 (values input output)))

  ViewVC Help
Powered by ViewVC 1.1.5