/[cmucl]/src/hemlock/ts-stream.lisp
ViewVC logotype

Contents of /src/hemlock/ts-stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Mon May 4 01:27:21 1998 UTC (15 years, 11 months ago) by dtc
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.3: +2 -2 lines
Gray streams support:
* Rename the 'stream structure class to sys:lisp-stream.
* Add a new none hierarchical 'stream built-in class which inherits
  from: instance, t.
* Hack in the new stream class as a mixin for the structure base
  lisp-stream class which now inherits from: stream, structure-object,
  instance, t.
* Add a new 'fundamental-stream standard-class which includes 'stream
  as a mixin, and add PCL hacks to allow this to be redefined after PCL is
  loaded to be (defclass fundamental-stream (standard-object stream) ...).
* Add appropriate support to the base stream functions to dispatch to
  the Gray stream functions for the handling of fundamental-streams.
  Some of the lisp-streams encapsulating CLOS streams still need
  a little work.
1 ;;; -*- Package: Hemlock; Log: hemlock.log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/ts-stream.lisp,v 1.4 1998/05/04 01:27:21 dtc Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file implements typescript streams.
13 ;;;
14 ;;; Written by William Lott.
15 ;;;
16
17 (in-package "HEMLOCK")
18
19
20
21 ;;;; Ts-streams.
22
23 (defconstant ts-stream-output-buffer-size 512)
24
25 (defstruct (ts-stream
26 (:include sys:lisp-stream
27 (in #'%ts-stream-in)
28 (out #'%ts-stream-out)
29 (sout #'%ts-stream-sout)
30 (misc #'%ts-stream-misc))
31 (:print-function %ts-stream-print)
32 (:constructor make-ts-stream (wire typescript)))
33 wire
34 typescript
35 (output-buffer (make-string ts-stream-output-buffer-size)
36 :type simple-string)
37 (output-buffer-index 0 :type fixnum)
38 ;;
39 ;; The current output character position on the line, returned by the
40 ;; :CHARPOS method.
41 (char-pos 0 :type fixnum)
42 ;;
43 ;; The current length of a line of output. Returned by the :LINE-LENGTH
44 ;; method.
45 (line-length 80)
46 ;;
47 ;; This is a list of strings and stream-commands whose order manifests the
48 ;; input provided by remote procedure calls into the slave of
49 ;; TS-STREAM-ACCEPT-INPUT.
50 (current-input nil :type list)
51 (input-read-index 0 :type fixnum))
52
53 (defun %ts-stream-print (ts stream depth)
54 (declare (ignore ts depth))
55 (write-string "#<TS Stream>" stream))
56
57
58
59 ;;;; Conditions.
60
61 (define-condition unexpected-stream-command (error)
62 ;; Context is a string to be plugged into the report text.
63 ((context :reader unexpected-stream-command-context :initarg :context))
64 (:report (lambda (condition stream)
65 (format stream "~&Unexpected stream-command while ~A."
66 (unexpected-stream-command-context condition)))))
67
68
69
70 ;;;; Editor remote calls into slave.
71
72 ;;; TS-STREAM-ACCEPT-INPUT -- Internal Interface.
73 ;;;
74 ;;; The editor calls this remotely in the slave to indicate that the user has
75 ;;; provided input. Input is a string, symbol, or list. If it is a list, the
76 ;;; the CAR names the command, and the CDR is the arguments.
77 ;;;
78 (defun ts-stream-accept-input (remote input)
79 (let ((stream (wire:remote-object-value remote)))
80 (system:without-interrupts
81 (system:without-gcing
82 (setf (ts-stream-current-input stream)
83 (nconc (ts-stream-current-input stream)
84 (list (etypecase input
85 (string
86 (let ((newline
87 (position #\newline input :from-end t)))
88 (setf (ts-stream-char-pos stream)
89 (if newline
90 (- (length input) newline 1)
91 (length input)))
92 input))
93 (cons
94 (ext:make-stream-command (car input)
95 (cdr input)))
96 (symbol
97 (ext:make-stream-command input)))))))))
98 nil)
99
100 ;;; TS-STREAM-SET-LINE-LENGTH -- Internal Interface.
101 ;;;
102 ;;; This function is called by the editor to indicate that the line-length for
103 ;;; a TS stream should now be Length.
104 ;;;
105 (defun ts-stream-set-line-length (remote length)
106 (let ((stream (wire:remote-object-value remote)))
107 (setf (ts-stream-line-length stream) length)))
108
109
110
111 ;;;; Stream methods.
112
113 ;;; %TS-STREAM-LISTEN -- Internal.
114 ;;;
115 ;;; Determine if there is any input available. If we don't think so, process
116 ;;; all pending events, and look again.
117 ;;;
118 (defun %ts-stream-listen (stream)
119 (flet ((check ()
120 (system:without-interrupts
121 (system:without-gcing
122 (loop
123 (let* ((current (ts-stream-current-input stream))
124 (first (first current)))
125 (cond ((null current)
126 (return nil))
127 ((ext:stream-command-p first)
128 (return t))
129 ((>= (ts-stream-input-read-index stream)
130 (length (the simple-string first)))
131 (pop (ts-stream-current-input stream))
132 (setf (ts-stream-input-read-index stream) 0))
133 (t
134 (return t)))))))))
135 (or (check)
136 (progn
137 (system:serve-all-events 0)
138 (check)))))
139
140 ;;; %TS-STREAM-IN -- Internal.
141 ;;;
142 ;;; The READ-CHAR stream method.
143 ;;;
144 (defun %ts-stream-in (stream &optional eoferr eofval)
145 (declare (ignore eoferr eofval)) ; EOF's are impossible.
146 (wait-for-typescript-input stream)
147 (system:without-interrupts
148 (system:without-gcing
149 (let ((first (first (ts-stream-current-input stream))))
150 (etypecase first
151 (string
152 (prog1 (schar first (ts-stream-input-read-index stream))
153 (incf (ts-stream-input-read-index stream))))
154 (ext:stream-command
155 (error 'unexpected-stream-command
156 :context "in the READ-CHAR method")))))))
157
158 ;;; %TS-STREAM-READ-LINE -- Internal.
159 ;;;
160 ;;; The READ-LINE stream method. Note: here we take advantage of the fact that
161 ;;; newlines will only appear at the end of strings.
162 ;;;
163 (defun %ts-stream-read-line (stream eoferr eofval)
164 (declare (ignore eoferr eofval))
165 (macrolet
166 ((next-str ()
167 '(progn
168 (wait-for-typescript-input stream)
169 (system:without-interrupts
170 (system:without-gcing
171 (let ((first (first (ts-stream-current-input stream))))
172 (etypecase first
173 (string
174 (prog1 (if (zerop (ts-stream-input-read-index stream))
175 (pop (ts-stream-current-input stream))
176 (subseq (pop (ts-stream-current-input stream))
177 (ts-stream-input-read-index stream)))
178 (setf (ts-stream-input-read-index stream) 0)))
179 (ext:stream-command
180 (error 'unexpected-stream-command
181 :context "in the READ-CHAR method")))))))))
182 (do ((result (next-str) (concatenate 'simple-string result (next-str))))
183 ((char= (schar result (1- (length result))) #\newline)
184 (values (subseq result 0 (1- (length result)))
185 nil))
186 (declare (simple-string result)))))
187
188 ;;; WAIT-FOR-TYPESCRIPT-INPUT -- Internal.
189 ;;;
190 ;;; Keep calling server until some input shows up.
191 ;;;
192 (defun wait-for-typescript-input (stream)
193 (unless (%ts-stream-listen stream)
194 (let ((wire (ts-stream-wire stream))
195 (ts (ts-stream-typescript stream)))
196 (system:without-interrupts
197 (system:without-gcing
198 (wire:remote wire (ts-buffer-ask-for-input ts))
199 (wire:wire-force-output wire)))
200 (loop
201 (system:serve-all-events)
202 (when (%ts-stream-listen stream)
203 (return))))))
204
205 ;;; %TS-STREAM-FLSBUF --- internal.
206 ;;;
207 ;;; Flush the output buffer associated with stream. This should only be used
208 ;;; inside a without-interrupts and without-gcing.
209 ;;;
210 (defun %ts-stream-flsbuf (stream)
211 (when (and (ts-stream-wire stream)
212 (ts-stream-output-buffer stream)
213 (not (zerop (ts-stream-output-buffer-index stream))))
214 (wire:remote (ts-stream-wire stream)
215 (ts-buffer-output-string
216 (ts-stream-typescript stream)
217 (subseq (the simple-string (ts-stream-output-buffer stream))
218 0
219 (ts-stream-output-buffer-index stream))))
220 (setf (ts-stream-output-buffer-index stream) 0)))
221
222 ;;; %TS-STREAM-OUT --- internal.
223 ;;;
224 ;;; Output a single character to stream.
225 ;;;
226 (defun %ts-stream-out (stream char)
227 (declare (base-char char))
228 (system:without-interrupts
229 (system:without-gcing
230 (when (= (ts-stream-output-buffer-index stream)
231 ts-stream-output-buffer-size)
232 (%ts-stream-flsbuf stream))
233 (setf (schar (ts-stream-output-buffer stream)
234 (ts-stream-output-buffer-index stream))
235 char)
236 (incf (ts-stream-output-buffer-index stream))
237 (incf (ts-stream-char-pos stream))
238 (when (= (char-code char)
239 (char-code #\Newline))
240 (%ts-stream-flsbuf stream)
241 (setf (ts-stream-char-pos stream) 0)
242 (wire:wire-force-output (ts-stream-wire stream)))
243 char)))
244
245 ;;; %TS-STREAM-SOUT --- internal.
246 ;;;
247 ;;; Output a string to stream.
248 ;;;
249 (defun %ts-stream-sout (stream string start end)
250 (declare (simple-string string))
251 (declare (fixnum start end))
252 (let ((wire (ts-stream-wire stream))
253 (newline (position #\Newline string :start start :end end :from-end t))
254 (length (- end start)))
255 (when wire
256 (system:without-interrupts
257 (system:without-gcing
258 (let ((index (ts-stream-output-buffer-index stream)))
259 (cond ((> (+ index length)
260 ts-stream-output-buffer-size)
261 (%ts-stream-flsbuf stream)
262 (wire:remote wire
263 (ts-buffer-output-string (ts-stream-typescript stream)
264 (subseq string start end)))
265 (when newline
266 (wire:wire-force-output wire)))
267 (t
268 (replace (the simple-string (ts-stream-output-buffer stream))
269 string
270 :start1 index
271 :end1 (+ index length)
272 :start2 start
273 :end2 end)
274 (incf (ts-stream-output-buffer-index stream)
275 length)
276 (when newline
277 (%ts-stream-flsbuf stream)
278 (wire:wire-force-output wire)))))
279 (setf (ts-stream-char-pos stream)
280 (if newline
281 (- end newline 1)
282 (+ (ts-stream-char-pos stream)
283 length))))))))
284
285 ;;; %TS-STREAM-UNREAD -- Internal.
286 ;;;
287 ;;; Unread a single character.
288 ;;;
289 (defun %ts-stream-unread (stream char)
290 (system:without-interrupts
291 (system:without-gcing
292 (let ((first (first (ts-stream-current-input stream))))
293 (cond ((and (stringp first)
294 (> (ts-stream-input-read-index stream) 0))
295 (setf (schar first (decf (ts-stream-input-read-index stream)))
296 char))
297 (t
298 (push (string char) (ts-stream-current-input stream))
299 (setf (ts-stream-input-read-index stream) 0)))))))
300
301 ;;; %TS-STREAM-CLOSE --- internal.
302 ;;;
303 ;;; Can't do much, 'cause the wire is shared.
304 ;;;
305 (defun %ts-stream-close (stream abort)
306 (unless abort
307 (force-output stream))
308 (lisp::set-closed-flame stream))
309
310 ;;; %TS-STREAM-CLEAR-INPUT -- Internal.
311 ;;;
312 ;;; Pass the request to the editor and clear any buffered input.
313 ;;;
314 (defun %ts-stream-clear-input (stream)
315 (system:without-interrupts
316 (system:without-gcing
317 (when (ts-stream-wire stream)
318 (wire:remote-value (ts-stream-wire stream)
319 (ts-buffer-clear-input (ts-stream-typescript stream))))
320 (setf (ts-stream-current-input stream) nil
321 (ts-stream-input-read-index stream) 0))))
322
323 ;;; %TS-STREAM-MISC -- Internal.
324 ;;;
325 ;;; The misc stream method.
326 ;;;
327 (defun %ts-stream-misc (stream operation &optional arg1 arg2)
328 (case operation
329 (:read-line
330 (%ts-stream-read-line stream arg1 arg2))
331 (:listen
332 (%ts-stream-listen stream))
333 (:unread
334 (%ts-stream-unread stream arg1))
335 (:interactive-p t)
336 (:get-command
337 (wait-for-typescript-input stream)
338 (system:without-interrupts
339 (system:without-gcing
340 (etypecase (first (ts-stream-current-input stream))
341 (stream-command
342 (setf (ts-stream-input-read-index stream) 0)
343 (pop (ts-stream-current-input stream)))
344 (string nil)))))
345 (:close
346 (%ts-stream-close stream arg1))
347 (:clear-input
348 (%ts-stream-clear-input stream)
349 t)
350 (:finish-output
351 (when (ts-stream-wire stream)
352 (system:without-interrupts
353 (system:without-gcing
354 (%ts-stream-flsbuf stream)
355 ;; Note: for the return value to come back,
356 ;; all pending RPCs must have completed.
357 ;; Therefore, we know it has synced.
358 (wire:remote-value (ts-stream-wire stream)
359 (ts-buffer-finish-output (ts-stream-typescript stream))))))
360 t)
361 (:force-output
362 (when (ts-stream-wire stream)
363 (system:without-interrupts
364 (system:without-gcing
365 (%ts-stream-flsbuf stream)
366 (wire:wire-force-output (ts-stream-wire stream)))))
367 t)
368 (:clear-output
369 (setf (ts-stream-output-buffer-index stream) 0)
370 t)
371 (:element-type
372 'base-char)
373 (:charpos
374 (ts-stream-char-pos stream))
375 (:line-length
376 (ts-stream-line-length stream))))

  ViewVC Help
Powered by ViewVC 1.1.5