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

Contents of /slime/swank-gray.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (show annotations)
Sat Aug 30 15:33:28 2008 UTC (5 years, 7 months ago) by heller
Branch: MAIN
Changes since 1.16: +4 -2 lines
* swank-gray.lisp (make-input-stream): fixed typos
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-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-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-write-string ((stream slime-output-stream) string
36 &optional start end)
37 (with-slime-output-stream stream
38 (let* ((start (or start 0))
39 (end (or end (length string)))
40 (len (length buffer))
41 (count (- end start))
42 (free (- len fill-pointer)))
43 (when (>= count free)
44 (stream-finish-output stream))
45 (cond ((< count len)
46 (replace buffer string :start1 fill-pointer
47 :start2 start :end2 end)
48 (incf fill-pointer count))
49 (t
50 (funcall output-fn (subseq string start end))))
51 (let ((last-newline (position #\newline string :from-end t
52 :start start :end end)))
53 (setf column (if last-newline
54 (- end last-newline 1)
55 (+ column count))))))
56 string)
57
58 (defmethod stream-line-column ((stream slime-output-stream))
59 (with-slime-output-stream stream column))
60
61 (defmethod stream-line-length ((stream slime-output-stream))
62 75)
63
64 (defmethod stream-finish-output ((stream slime-output-stream))
65 (with-slime-output-stream stream
66 (unless (zerop fill-pointer)
67 (funcall output-fn (subseq buffer 0 fill-pointer))
68 (setf fill-pointer 0)))
69 nil)
70
71 (defmethod stream-force-output ((stream slime-output-stream))
72 (stream-finish-output stream))
73
74 (defmethod stream-fresh-line ((stream slime-output-stream))
75 (with-slime-output-stream stream
76 (cond ((zerop column) nil)
77 (t (terpri stream) t))))
78
79 (defclass slime-input-stream (fundamental-character-input-stream)
80 ((output-stream :initarg :output-stream)
81 (input-fn :initarg :input-fn)
82 (buffer :initform "") (index :initform 0)
83 (lock :initform (make-lock :name "buffer read lock"))))
84
85 (defmethod stream-read-char ((s slime-input-stream))
86 (call-with-lock-held
87 (slot-value s 'lock)
88 (lambda ()
89 (with-slots (buffer index output-stream input-fn) s
90 (when (= index (length buffer))
91 (when output-stream
92 (finish-output output-stream))
93 (let ((string (funcall input-fn)))
94 (cond ((zerop (length string))
95 (return-from stream-read-char :eof))
96 (t
97 (setf buffer string)
98 (setf index 0)))))
99 (assert (plusp (length buffer)))
100 (prog1 (aref buffer index) (incf index))))))
101
102 (defmethod stream-listen ((s slime-input-stream))
103 (call-with-lock-held
104 (slot-value s 'lock)
105 (lambda ()
106 (with-slots (buffer index) s
107 (< index (length buffer))))))
108
109 (defmethod stream-unread-char ((s slime-input-stream) char)
110 (call-with-lock-held
111 (slot-value s 'lock)
112 (lambda ()
113 (with-slots (buffer index) s
114 (decf index)
115 (cond ((eql (aref buffer index) char)
116 (setf (aref buffer index) char))
117 (t
118 (warn "stream-unread-char: ignoring ~S (expected ~S)"
119 char (aref buffer index)))))))
120 nil)
121
122 (defmethod stream-clear-input ((s slime-input-stream))
123 (call-with-lock-held
124 (slot-value s 'lock)
125 (lambda ()
126 (with-slots (buffer index) s
127 (setf buffer ""
128 index 0))))
129 nil)
130
131 (defmethod stream-line-column ((s slime-input-stream))
132 nil)
133
134 (defmethod stream-line-length ((s slime-input-stream))
135 75)
136
137
138 ;;; CLISP extensions
139
140 ;; We have to define an additional method for the sake of the C
141 ;; function listen_char (see src/stream.d), on which SYS::READ-FORM
142 ;; depends.
143
144 ;; We could make do with either of the two methods below.
145
146 (defmethod stream-read-char-no-hang ((s slime-input-stream))
147 (call-with-lock-held
148 (slot-value s 'lock)
149 (lambda ()
150 (with-slots (buffer index) s
151 (when (< index (length buffer))
152 (prog1 (aref buffer index) (incf index)))))))
153
154 ;; This CLISP extension is what listen_char actually calls. The
155 ;; default method would call STREAM-READ-CHAR-NO-HANG, so it is a bit
156 ;; more efficient to define it directly.
157
158 (defmethod stream-read-char-will-hang-p ((s slime-input-stream))
159 (with-slots (buffer index) s
160 (= index (length buffer))))
161
162
163 ;;;
164
165 (defimplementation make-output-stream (write-string)
166 (make-instance 'slime-output-stream :output-fn write-string))
167
168 (defimplementation make-input-stream (read-string)
169 (make-instance 'slime-input-stream
170 :input-fn read-string
171 :output-stream nil))
172
173 (defimplementation make-fn-streams (input-fn output-fn)
174 (let* ((output (make-instance 'slime-output-stream
175 :output-fn output-fn))
176 (input (make-instance 'slime-input-stream
177 :input-fn input-fn
178 :output-stream output)))
179 (values input output)))

  ViewVC Help
Powered by ViewVC 1.1.5