/[cmucl]/src/code/stream.lisp
ViewVC logotype

Contents of /src/code/stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2.1.1 - (show annotations) (vendor branch)
Fri May 25 20:44:13 1990 UTC (23 years, 10 months ago) by wlott
Changes since 1.2: +13 -10 lines
Initial MIPS cut.
1 ;;; -*- Log: code.log; Package: Lisp -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the Spice Lisp project at
5 ;;; Carnegie-Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of Spice Lisp, please contact
7 ;;; Scott Fahlman (FAHLMAN@CMUC).
8 ;;; **********************************************************************
9 ;;;
10 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/stream.lisp,v 1.2.1.1 1990/05/25 20:44:13 wlott Exp $
11 ;;;
12 ;;; Stream functions for Spice Lisp.
13 ;;; Written by Skef Wholey and Rob MacLachlan.
14 ;;;
15 ;;; This file contains the machine-independent stream functions. Another
16 ;;; file (VAXIO, SPIO, or VMIO) contains functions used by this file for
17 ;;; a specific machine.
18 ;;;
19 (in-package "LISP")
20
21 (export '(make-broadcast-stream make-synonym-stream
22 make-broadcast-stream make-concatenated-stream make-two-way-stream
23 make-echo-stream make-string-input-stream make-string-output-stream
24 get-output-stream-string stream-element-type input-stream-p
25 output-stream-p close read-line read-char
26 unread-char peek-char listen read-char-no-hang clear-input read-byte
27 write-char write-string write-line terpri fresh-line
28 finish-output force-output clear-output write-byte
29 stream streamp *standard-input* *standard-output*
30 *error-output* *query-io* *debug-io* *terminal-io* *trace-output*))
31
32 (in-package 'system)
33 (export '(make-indenting-stream read-n-bytes))
34 (in-package 'lisp)
35
36 ;;;; Standard streams:
37 ;;;
38 ;;; The initialization of these streams is performed by Stream-Init,
39 ;;; which lives in the file of machine-specific stream functions.
40 ;;;
41 (defvar *terminal-io* () "Terminal I/O stream.")
42 (defvar *standard-input* () "Default input stream.")
43 (defvar *standard-output* () "Default output stream.")
44 (defvar *error-output* () "Error output stream.")
45 (defvar *query-io* () "Query I/O stream.")
46 (defvar *trace-output* () "Trace output stream.")
47 (defvar *debug-io* () "Interactive debugging stream.")
48
49 (defun ill-in (stream &rest ignore)
50 (declare (ignore ignore))
51 (error "~S is not a character input stream." stream))
52 (defun ill-out (stream &rest ignore)
53 (declare (ignore ignore))
54 (error "~S is not a character output stream." stream))
55 (defun ill-bin (stream &rest ignore)
56 (declare (ignore ignore))
57 (error "~S is not a binary input stream." stream))
58 (defun ill-bout (stream &rest ignore)
59 (declare (ignore ignore))
60 (error "~S is not a binary output stream." stream))
61 (defun closed-flame (stream &rest ignore)
62 (declare (ignore ignore))
63 (error "~S is closed." stream))
64 (defun do-nothing (&rest ignore)
65 (declare (ignore ignore)))
66
67 (defun %print-stream (structure stream d)
68 (declare (ignore d structure))
69 (write-string "#<Bare Stream>" stream))
70
71 ;;; HOW THE STREAM STRUCTURE IS USED:
72 ;;;
73 ;;; Many of the slots of the stream structure contain functions
74 ;;; which are called to perform some operation on the stream. Closed
75 ;;; streams have #'Closed-Flame in all of their function slots. If
76 ;;; one side of an I/O or echo stream is closed, the whole stream is
77 ;;; considered closed. The functions in the operation slots take
78 ;;; arguments as follows:
79 ;;;
80 ;;; In: Stream, Eof-Errorp, Eof-Value
81 ;;; Bin: Stream, Eof-Errorp, Eof-Value
82 ;;; N-Bin: Stream, Buffer, Start, Numbytes, Eof-Errorp
83 ;;; Out: Stream, Character
84 ;;; Bout: Stream, Integer
85 ;;; Sout: Stream, String, Start, End
86 ;;; Misc: Stream, Operation, &Optional Arg1, Arg2
87 ;;;
88 ;;; In order to save space, some of the less common stream operations
89 ;;; are handled by just one function, the Misc method. This function
90 ;;; is passed a keyword which indicates the operation to perform.
91 ;;; The following keywords are used:
92 ;;; :read-line - Do a read-line.
93 ;;; :listen - Return true if any input waiting.
94 ;;; :unread - Unread the character Arg.
95 ;;; :close - Do any stream specific stuff to close the stream.
96 ;;; The methods are set to closed-flame by the close
97 ;;; function, so that need not be done by this
98 ;;; function.
99 ;;; :clear-input - Clear any unread input
100 ;;; :finish-output,
101 ;;; :force-output - Cause output to happen
102 ;;; :clear-output - Clear any undone output
103 ;;; :element-type - Return the type of element the stream deals with.
104 ;;; :line-length - Return the length of a line of output.
105 ;;; :charpos - Return current output position on the line.
106 ;;; :file-length - Return the file length of a file stream.
107 ;;; :file-position - Return or change the current position of a file stream.
108 ;;; :file-name - Return the name of an associated file.
109 ;;;
110 ;;; In order to do almost anything useful, it is necessary to
111 ;;; define a new type of structure that includes stream, so that the
112 ;;; stream can have some state information.
113 ;;;
114 ;;; THE STREAM IN-BUFFER:
115 ;;;
116 ;;; The In-Buffer in the stream holds characters or bytes that
117 ;;; are ready to be read by some input function. If there is any
118 ;;; stuff in the In-Buffer, then the reading function can use it
119 ;;; without calling any stream method. Any stream may put stuff in
120 ;;; the In-Buffer, and may also assume that any input in the In-Buffer
121 ;;; has been consumed before any in-method is called. If a text
122 ;;; stream has in In-Buffer, then the first character should not be
123 ;;; used to buffer normal input so that it is free for unreading into.
124 ;;;
125 ;;; The In-Buffer slot is a vector In-Buffer-Length long. The
126 ;;; In-Index is the index in the In-Buffer of the first available
127 ;;; object. The available objects are thus between In-Index and the
128 ;;; length of the In-Buffer.
129 ;;;
130 ;;; When this buffer is only accessed by the normal stream
131 ;;; functions, the number of function calls is halved, thus
132 ;;; potentially doubling the speed of simple operations. If the
133 ;;; Fast-Read-Char and Fast-Read-Byte macros are used, nearly all
134 ;;; function call overhead is removed, vastly speeding up these
135 ;;; important operations.
136 ;;;
137 ;;; If a stream does not have an In-Buffer, then the In-Buffer slot
138 ;;; must be nil, and the In-Index must be In-Buffer-Length. These are
139 ;;; the default values for the slots.
140
141 ;;; Stream manipulation functions.
142
143 (defun input-stream-p (stream)
144 "Returns non-nil if the given Stream can perform input operations."
145 (and (streamp stream)
146 (not (eq (stream-in stream) #'closed-flame))
147 (or (not (eq (stream-in stream) #'ill-in))
148 (not (eq (stream-bin stream) #'ill-bin)))))
149
150 (defun output-stream-p (stream)
151 "Returns non-nil if the given Stream can perform output operations."
152 (and (streamp stream)
153 (not (eq (stream-in stream) #'closed-flame))
154 (or (not (eq (stream-out stream) #'ill-out))
155 (not (eq (stream-bout stream) #'ill-bout)))))
156
157 (defun stream-element-type (stream)
158 "Returns a type specifier for the kind of object returned by the Stream."
159 (if (streamp stream)
160 (funcall (stream-misc stream) stream :element-type)
161 (error "~S is not a stream." stream)))
162
163 (defun close (stream &key abort)
164 "Closes the given Stream. No more I/O may be performed, but inquiries
165 may still be made. If :Abort is non-nil, an attempt is made to clean
166 up the side effects of having created the stream."
167 (if (streamp stream)
168 (unless (eq (stream-in stream) #'closed-flame)
169 (funcall (stream-misc stream) stream :close abort))
170 (error "~S is not a stream." stream))
171 t)
172
173 (defun set-closed-flame (stream)
174 (setf (stream-in stream) #'closed-flame)
175 (setf (stream-bin stream) #'closed-flame)
176 (setf (stream-n-bin stream) #'closed-flame)
177 (setf (stream-in stream) #'closed-flame)
178 (setf (stream-out stream) #'closed-flame)
179 (setf (stream-bout stream) #'closed-flame)
180 (setf (stream-sout stream) #'closed-flame)
181 (setf (stream-misc stream) #'closed-flame))
182
183 ;;; Input functions:
184
185 (defun read-line (&optional (stream *standard-input*) (eof-errorp t) eof-value
186 recursive-p)
187 "Returns a line of text read from the Stream as a string, discarding the
188 newline character."
189 (declare (ignore recursive-p))
190 (let* ((stream (in-synonym-of stream))
191 (buffer (stream-in-buffer stream))
192 (index (stream-in-index stream)))
193 (declare (fixnum index))
194 (if (simple-string-p buffer)
195 (let ((nl (%sp-find-character buffer index in-buffer-length #\newline)))
196 (if nl
197 (values (prog1 (subseq (the simple-string buffer) index nl)
198 (setf (stream-in-index stream)
199 (1+ (the fixnum nl))))
200 nil)
201 (multiple-value-bind (str eofp)
202 (funcall (stream-misc stream) stream
203 :read-line eof-errorp eof-value)
204 (declare (simple-string str))
205 (if (= index in-buffer-length)
206 (values str eofp)
207 (values (prog1
208 (concatenate 'simple-string
209 (subseq buffer index in-buffer-length)
210 str)
211 (setf (stream-in-index stream) in-buffer-length))
212 eofp)))))
213 (funcall (stream-misc stream) stream :read-line eof-errorp eof-value))))
214
215 ;;; We proclaim them inline here, then proclaim them notinline at EOF,
216 ;;; so, except in this file, they are not inline by default, but they can be.
217 ;;;
218 (proclaim '(inline read-char unread-char read-byte listen))
219 (defun read-char (&optional (stream *standard-input*) (eof-errorp t) eof-value
220 recursive-p)
221 "Inputs a character from Stream and returns it."
222 (declare (ignore recursive-p))
223 (let* ((stream (in-synonym-of stream))
224 (index (stream-in-index stream)))
225 (declare (fixnum index))
226 (if (eql index in-buffer-length)
227 (funcall (stream-in stream) stream eof-errorp eof-value)
228 (prog1 (aref (stream-in-buffer stream) index)
229 (setf (stream-in-index stream) (1+ index))))))
230
231 (defun unread-char (character &optional (stream *standard-input*))
232 "Puts the Character back on the front of the input Stream."
233 (let* ((stream (in-synonym-of stream))
234 (index (1- (the fixnum (stream-in-index stream))))
235 (buffer (stream-in-buffer stream)))
236 (declare (fixnum index))
237 (when (minusp index) (error "Nothing to unread."))
238 (if buffer
239 (setf (aref (the simple-array buffer) index) character
240 (stream-in-index stream) index)
241 (funcall (stream-misc stream) stream :unread character)))
242 nil)
243
244 (defun peek-char (&optional (peek-type nil) (stream *standard-input*)
245 (eof-errorp t) eof-value recursive-p)
246 "Peeks at the next character in the input Stream. See manual for details."
247 (declare (ignore recursive-p))
248 (let* ((stream (in-synonym-of stream))
249 (char (read-char stream eof-errorp eof-value)))
250 (cond ((eq char eof-value) char)
251 ((characterp peek-type)
252 (do ((char char (read-char stream eof-errorp eof-value)))
253 ((or (eq char eof-value) (char= char peek-type))
254 (unless (eq char eof-value)
255 (unread-char char stream))
256 char)))
257 ((eq peek-type t)
258 (do ((char char (read-char stream eof-errorp eof-value)))
259 ((or (eq char eof-value) (not (whitespace-char-p char)))
260 (unless (eq char eof-value)
261 (unread-char char stream))
262 char)))
263 (t
264 (unread-char char stream)
265 char))))
266
267 (defun listen (&optional (stream *standard-input*))
268 "Returns T if a character is availible on the given Stream."
269 (let ((stream (in-synonym-of stream)))
270 (or (/= (the fixnum (stream-in-index stream)) in-buffer-length)
271 (funcall (stream-misc stream) stream :listen))))
272
273 (defun read-char-no-hang (&optional (stream *standard-input*)
274 (eof-errorp t) eof-value recursive-p)
275 "Returns the next character from the Stream if one is availible, or nil."
276 (declare (ignore recursive-p))
277 (if (listen stream) (read-char stream eof-errorp eof-value) nil))
278
279 (defun clear-input (&optional (stream *standard-input*))
280 "Clears any buffered input associated with the Stream."
281 (let ((stream (in-synonym-of stream)))
282 (setf (stream-in-index stream) in-buffer-length)
283 (funcall (stream-misc stream) stream :clear-input)
284 nil))
285
286 (defun read-byte (stream &optional (eof-errorp t) eof-value)
287 "Returns the next byte of the Stream."
288 (let* ((stream (in-synonym-of stream))
289 (index (stream-in-index stream)))
290 (declare (fixnum index))
291 (if (eql index in-buffer-length)
292 (funcall (stream-bin stream) stream eof-errorp eof-value)
293 (prog1 (aref (stream-in-buffer stream) index)
294 (setf (stream-in-index stream) (1+ index))))))
295
296 (defun read-n-bytes (stream buffer start numbytes &optional (eof-errorp t))
297 "Reads Numbytes bytes into the Buffer starting at Start, and returns
298 the number of bytes actually read if the end of file was hit before Numbytes
299 bytes were read (and Eof-Errorp is false)."
300 (declare (fixnum numbytes))
301 (let* ((stream (in-synonym-of stream))
302 (in-buffer (stream-in-buffer stream))
303 (index (stream-in-index stream))
304 (num-buffered (- in-buffer-length index)))
305 (declare (fixnum index num-buffered))
306 (cond
307 ((not in-buffer)
308 (with-in-stream stream stream-n-bin buffer start numbytes eof-errorp))
309 ((not (typep in-buffer
310 '(or simple-string (simple-array (unsigned-byte 8) (*)))))
311 (error "N-Bin only works on 8-bit-like streams."))
312 ((<= numbytes num-buffered)
313 (%primitive byte-blt in-buffer index buffer start (+ start numbytes))
314 (setf (stream-in-index stream) (+ index numbytes))
315 numbytes)
316 (t
317 (let ((end (+ start num-buffered)))
318 (%primitive byte-blt in-buffer index buffer start end)
319 (setf (stream-in-index stream) in-buffer-length)
320 (+ (with-in-stream stream stream-n-bin buffer end
321 (- numbytes num-buffered)
322 eof-errorp)
323 num-buffered))))))
324
325 ;;; Output functions:
326
327 (defun write-char (character &optional (stream *standard-output*))
328 "Outputs the Character to the Stream."
329 (with-out-stream stream stream-out character)
330 character)
331
332 (defun terpri (&optional (stream *standard-output*))
333 "Outputs a new line to the Stream."
334 (with-out-stream stream stream-out #\newline)
335 nil)
336
337 (defun fresh-line (&optional (stream *standard-output*))
338 "Outputs a new line to the Stream if it is not positioned at the begining of
339 a line. Returns T if it output a new line, nil otherwise."
340 (let ((stream (out-synonym-of stream)))
341 (when (/= (or (charpos stream) 1) 0)
342 (funcall (stream-out stream) stream #\newline)
343 t)))
344
345 (defun write-string (string &optional (stream *standard-output*)
346 &key (start 0) (end (length (the vector string))))
347 "Outputs the String to the given Stream."
348 (write-string* string stream start end))
349
350 (defun write-string* (string &optional (stream *standard-output*)
351 (start 0) (end (length (the vector string))))
352 (declare (fixnum start end))
353 (if (array-header-p string)
354 (with-array-data ((data string) (offset-start start) (offset-end end))
355 (with-out-stream stream stream-sout data offset-start offset-end))
356 (with-out-stream stream stream-sout string start end))
357 string)
358
359 (defun write-line (string &optional (stream *standard-output*)
360 &key (start 0) (end (length string)))
361 "Outputs the String to the given Stream, followed by a newline character."
362 (write-line* string stream start end))
363
364 (defun write-line* (string &optional (stream *standard-output*)
365 (start 0) (end (length string)))
366 (declare (fixnum start end))
367 (let ((stream (out-synonym-of stream)))
368 (if (array-header-p string)
369 (with-array-data ((data string) (offset-start start) (offset-end end))
370 (with-out-stream stream stream-sout data offset-start offset-end))
371 (with-out-stream stream stream-sout string start end))
372 (funcall (stream-out stream) stream #\newline))
373 string)
374
375 (defun charpos (&optional (stream *standard-output*))
376 "Returns the number of characters on the current line of output of the given
377 Stream, or Nil if that information is not availible."
378 (with-out-stream stream stream-misc :charpos))
379
380 (defun line-length (&optional (stream *standard-output*))
381 "Returns the number of characters that will fit on a line of output on the
382 given Stream, or Nil if that information is not available."
383 (with-out-stream stream stream-misc :line-length))
384
385 (defun finish-output (&optional (stream *standard-output*))
386 "Attempts to ensure that all output sent to the the Stream has reached its
387 destination, and only then returns."
388 (with-out-stream stream stream-misc :finish-output)
389 nil)
390
391 (defun force-output (&optional (stream *standard-output*))
392 "Attempts to force any buffered output to be sent."
393 (with-out-stream stream stream-misc :force-output)
394 nil)
395
396 (defun clear-output (&optional (stream *standard-output*))
397 "Clears the given output Stream."
398 (with-out-stream stream stream-misc :clear-output)
399 nil)
400
401 (defun write-byte (integer stream)
402 "Outputs the Integer to the binary Stream."
403 (with-out-stream stream stream-bout integer)
404 integer)
405
406 ;;;; Broadcast streams:
407
408 (defstruct (broadcast-stream (:include stream
409 (out #'broadcast-out)
410 (bout #'broadcast-bout)
411 (sout #'broadcast-sout)
412 (misc #'broadcast-misc))
413 (:print-function %print-broadcast-stream)
414 (:constructor make-broadcast-stream (&rest streams)))
415 ;; This is a list of all the streams we broadcast to.
416 streams)
417
418 (setf (documentation 'make-broadcast-stream 'function)
419 "Returns an ouput stream which sends its output to all of the given streams.")
420
421 (defun %print-broadcast-stream (s stream d)
422 (declare (ignore s d))
423 (write-string "#<Broadcast Stream>" stream))
424
425 (macrolet ((out-fun (fun method &rest args)
426 `(defun ,fun (stream ,@args)
427 (dolist (stream (broadcast-stream-streams stream))
428 (funcall (,method stream) stream ,@args)))))
429 (out-fun broadcast-out stream-out char)
430 (out-fun broadcast-bout stream-bout byte)
431 (out-fun broadcast-sout stream-sout string start end))
432
433 (defun broadcast-misc (stream operation &optional arg1 arg2)
434 (let ((streams (broadcast-stream-streams stream)))
435 (case operation
436 (:charpos
437 (dolist (stream streams)
438 (let ((charpos (funcall (stream-misc stream) stream :charpos)))
439 (if charpos (return charpos)))))
440 (:line-length
441 (let ((min nil))
442 (dolist (stream streams min)
443 (let ((res (funcall (stream-misc stream) stream :line-length)))
444 (when res (setq min (if min (min res min) res)))))))
445 (:element-type
446 (let (res)
447 (dolist (stream streams (if (> (length res) 1) `(and ,@res) res))
448 (pushnew (funcall (stream-misc stream) stream :element-type) res
449 :test #'equal))))
450 (t
451 (let ((res nil))
452 (dolist (stream streams res)
453 (setq res (funcall (stream-misc stream) stream operation
454 arg1 arg2))))))))
455
456 ;;;; Synonym Streams:
457
458 (defstruct (synonym-stream (:include stream
459 (in #'synonym-in)
460 (bin #'synonym-bin)
461 (n-bin #'synonym-n-bin)
462 (out #'synonym-out)
463 (bout #'synonym-bout)
464 (sout #'synonym-sout)
465 (misc #'synonym-misc))
466 (:print-function %print-synonym-stream)
467 (:constructor make-synonym-stream (symbol)))
468 ;; This is the symbol, the value of which is the stream we are synonym to.
469 symbol)
470
471 (defun %print-synonym-stream (s stream d)
472 (declare (ignore d))
473 (format stream "#<Synonym Stream to ~S>" (synonym-stream-symbol s)))
474
475 (setf (documentation 'make-synonym-stream 'function)
476 "Returns a stream which performs its operations on the stream which is the
477 value of the dynamic variable named by Symbol.")
478
479 ;;; The output simple output methods just call the corresponding method
480 ;;; in the synonymed stream.
481 ;;;
482 (macrolet ((out-fun (name slot &rest args)
483 `(defun ,name (stream ,@args)
484 (let ((syn (symbol-value (synonym-stream-symbol stream))))
485 (funcall (,slot syn) syn ,@args)))))
486 (out-fun synonym-out stream-out ch)
487 (out-fun synonym-bout stream-bout n)
488 (out-fun synonym-sout stream-sout string start end))
489
490
491 ;;; Bind synonym stream to this so that SPIO can turn on the right frob in
492 ;;; the icon when we are in a terminal input wait.
493 ;;;
494 (defvar *previous-stream* nil)
495
496 ;;; For the input methods, we just call the corresponding function on the
497 ;;; synonymed stream. These functions deal with getting input out of
498 ;;; the In-Buffer if there is any.
499 ;;;
500 (macrolet ((in-fun (name fun &rest args)
501 `(defun ,name (stream ,@args)
502 (let ((*previous-stream* stream))
503 (,fun (symbol-value (synonym-stream-symbol stream)) ,@args)))))
504 (in-fun synonym-in read-char eof-errorp eof-value)
505 (in-fun synonym-bin read-byte eof-errorp eof-value)
506 (in-fun synonym-n-bin read-n-bytes buffer start numbytes eof-errorp))
507
508
509 ;;; Synonym-Misc -- Internal
510 ;;;
511 ;;; We have to special-case the operations which could look at stuff in
512 ;;; the in-buffer.
513 ;;;
514 (defun synonym-misc (stream operation &optional arg1 arg2)
515 (let ((syn (symbol-value (synonym-stream-symbol stream)))
516 (*previous-stream* stream))
517 (case operation
518 (:read-line (read-line syn))
519 (:listen (or (/= (the fixnum (stream-in-index syn)) in-buffer-length)
520 (funcall (stream-misc syn) syn :listen)))
521 (t
522 (funcall (stream-misc syn) syn operation arg1 arg2)))))
523
524 ;;;; Two-Way streams:
525
526 (defstruct (two-way-stream
527 (:include stream
528 (in #'two-way-in)
529 (bin #'two-way-bin)
530 (n-bin #'two-way-n-bin)
531 (out #'two-way-out)
532 (bout #'two-way-bout)
533 (sout #'two-way-sout)
534 (misc #'two-way-misc))
535 (:print-function %print-two-way-stream)
536 (:constructor make-two-way-stream (input-stream output-stream)))
537 ;; We read from this stream...
538 input-stream
539 ;; And write to this one
540 output-stream)
541
542 (defun %print-two-way-stream (s stream d)
543 (declare (ignore d))
544 (format stream "#<Two-Way Stream, Input = ~S, Output = ~S>"
545 (two-way-stream-input-stream s)
546 (two-way-stream-output-stream s)))
547
548 (setf (documentation 'make-two-way-stream 'function)
549 "Returns a bidirectional stream which gets its input from Input-Stream and
550 sends its output to Output-Stream.")
551
552 (macrolet ((out-fun (name slot &rest args)
553 `(defun ,name (stream ,@args)
554 (let ((syn (two-way-stream-output-stream stream)))
555 (funcall (,slot syn) syn ,@args)))))
556 (out-fun two-way-out stream-out ch)
557 (out-fun two-way-bout stream-bout n)
558 (out-fun two-way-sout stream-sout string start end))
559
560 (macrolet ((in-fun (name fun &rest args)
561 `(defun ,name (stream ,@args)
562 (,fun (two-way-stream-input-stream stream) ,@args))))
563 (in-fun two-way-in read-char eof-errorp eof-value)
564 (in-fun two-way-bin read-byte eof-errorp eof-value)
565 (in-fun two-way-n-bin read-n-bytes buffer start numbytes eof-errorp))
566
567 (defun two-way-misc (stream operation &optional arg1 arg2)
568 (let* ((in (two-way-stream-input-stream stream))
569 (in-method (stream-misc in))
570 (out (two-way-stream-output-stream stream))
571 (out-method (stream-misc out)))
572 (case operation
573 (:listen (or (/= (the fixnum (stream-in-index in)) in-buffer-length)
574 (funcall in-method in :listen)))
575 (:read-line (read-line in arg1 arg2))
576 ((:finish-output :force-output :clear-output)
577 (funcall out-method out operation arg1 arg2))
578 ((:clear-input :unread)
579 (funcall in-method in operation arg1 arg2))
580 (:element-type
581 (let ((in-type (funcall in-method in :element-type))
582 (out-type (funcall out-method out :element-type)))
583 (if (equal in-type out-type)
584 in-type `(and ,in-type ,out-type))))
585 (:close
586 (funcall in-method in :close arg1)
587 (funcall out-method out :close arg1)
588 (set-closed-flame stream))
589 (t
590 (or (funcall in-method in operation arg1 arg2)
591 (funcall out-method out operation arg1 arg2))))))
592
593 ;;;; Concatenated Streams:
594
595 (defstruct (concatenated-stream
596 (:include stream
597 (in #'concatenated-in)
598 (bin #'concatenated-bin)
599 (misc #'concatenated-misc))
600 (:print-function %print-concatenated-stream)
601 (:constructor
602 make-concatenated-stream (&rest streams &aux (current streams))))
603 ;; The car of this is the stream we are reading from now.
604 current
605 ;; This is a list of all the streams. We need to remember them so that
606 ;; we can close them.
607 streams)
608
609 (defun %print-concatenated-stream (s stream d)
610 (declare (ignore d))
611 (format stream "#<Concatenated Stream, Streams = ~S>"
612 (concatenated-stream-streams s)))
613
614 (setf (documentation 'make-concatenated-stream 'function)
615 "Returns a stream which takes its input from each of the Streams in turn,
616 going on to the next at EOF.")
617
618 (macrolet ((in-fun (name fun)
619 `(defun ,name (stream eof-errorp eof-value)
620 (do ((current (concatenated-stream-current stream) (cdr current)))
621 ((null current)
622 (eof-or-lose stream eof-errorp eof-value))
623 (let* ((stream (car current))
624 (result (,fun stream nil nil)))
625 (when result (return result)))
626 (setf (concatenated-stream-current stream) current)))))
627 (in-fun concatenated-in read-char)
628 (in-fun concatenated-bin read-byte))
629
630 ;;; Concatenated-Readline is somewhat hairy, since we may need to
631 ;;; do several readlines and concatenate the result if the lines are
632 ;;; terminated by eof.
633 ;;;
634 (defun concatenated-readline (stream eof-errorp eof-value)
635 ;; Loop until we find a stream that will give us something or we error
636 ;; out.
637 (do ((current (concatenated-stream-current stream) (cdr current)))
638 ((null current)
639 (eof-or-lose stream eof-errorp eof-value))
640 (setf (concatenated-stream-current stream) current)
641 (let ((this (car current)))
642 (multiple-value-bind (result eofp)
643 (read-line this nil nil)
644 (declare (simple-string result))
645 ;; Once we have found some input, we loop until we either find a
646 ;; line not terminated by eof or hit eof on the last stream.
647 (when result
648 (do ((current (cdr current) (cdr current))
649 (new ""))
650 ((or (not eofp) (null current))
651 (return-from concatenated-readline (values result eofp)))
652 (declare (simple-string new))
653 (setf (concatenated-stream-current stream) current)
654 (let ((this (car current)))
655 (multiple-value-setq (new eofp)
656 (read-line this nil nil))
657 (if new
658 (setq result (concatenate 'simple-string result new))
659 (setq eofp t)))))))))
660
661 (defun concatenated-misc (stream operation &optional arg1 arg2)
662 (if (eq operation :read-line)
663 (concatenated-readline stream arg1 arg2)
664 (let ((left (concatenated-stream-current stream)))
665 (when left
666 (let* ((current (car left))
667 (misc (stream-misc current)))
668 (case operation
669 (:listen (or (/= (the fixnum (stream-in-index current)) in-buffer-length)
670 (funcall misc current :listen)))
671 (:close
672 (dolist (stream (concatenated-stream-streams stream))
673 (funcall (stream-misc stream) stream :close arg1))
674 (set-closed-flame stream))
675 (t
676 (funcall misc current operation arg1 arg2))))))))
677
678 ;;;; Echo Streams:
679
680 (defstruct (echo-stream
681 (:include two-way-stream
682 (in #'echo-in)
683 (bin #'echo-bin)
684 (misc #'echo-misc)
685 (n-bin #'ill-bin))
686 (:print-function %print-echo-stream)
687 (:constructor make-echo-stream (input-stream output-stream))))
688
689
690 (macrolet ((in-fun (name fun out-slot &rest args)
691 `(defun ,name (stream ,@args)
692 (let* ((in (two-way-stream-input-stream stream))
693 (out (two-way-stream-output-stream stream))
694 (result (,fun in ,@args)))
695 (funcall (,out-slot out) out result)
696 result))))
697 (in-fun echo-in read-char stream-out eof-errorp eof-value)
698 (in-fun echo-bin read-byte stream-bout eof-errorp eof-value))
699
700 (defun echo-misc (stream operation &optional arg1 arg2)
701 (let* ((in (two-way-stream-input-stream stream))
702 (in-method (stream-misc in))
703 (out (two-way-stream-output-stream stream))
704 (out-method (stream-misc out)))
705 (case operation
706 (:listen (or (/= (the fixnum (stream-in-index in)) in-buffer-length)
707 (funcall in-method in :listen)))
708 (:read-line
709 (multiple-value-bind (result eofp)
710 (read-line in arg1 arg2)
711 (if eofp
712 (write-string result out)
713 (write-line result out))
714 (values result eofp)))
715 (:element-type
716 (let ((in-type (funcall in-method in :element-type))
717 (out-type (funcall out-method out :element-type)))
718 (if (equal in-type out-type)
719 in-type `(and ,in-type ,out-type))))
720 (:close
721 (funcall in-method in :close arg1)
722 (funcall out-method out :close arg1)
723 (set-closed-flame stream))
724 (t
725 (or (funcall in-method in operation arg1 arg2)
726 (funcall out-method out operation arg1 arg2))))))
727
728 (defun %print-echo-stream (s stream d)
729 (declare (ignore d))
730 (format stream "#<Echo Stream, Input = ~S, Output = ~S>"
731 (two-way-stream-input-stream s)
732 (two-way-stream-output-stream s)))
733
734 (setf (documentation 'make-echo-stream 'function)
735 "Returns a bidirectional stream which gets its input from Input-Stream and
736 sends its output to Output-Stream. In addition, all input is echoed to
737 the output stream")
738
739 ;;;; String Input Streams:
740
741 (defstruct (string-input-stream
742 (:include stream
743 (in #'string-inch)
744 (misc #'string-in-misc))
745 (:print-function %print-string-input-stream)
746 (:constructor nil)
747 (:constructor internal-make-string-input-stream
748 (string current end)))
749 (string nil :type simple-string)
750 (current nil :type fixnum)
751 (end nil :type fixnum))
752
753 (defun %print-string-input-stream (s stream d)
754 (declare (ignore s d))
755 (write-string "#<String-Input Stream>" stream))
756
757 (defun string-inch (stream eof-errorp eof-value)
758 (let ((string (string-input-stream-string stream))
759 (index (string-input-stream-current stream)))
760 (declare (simple-string string) (fixnum index))
761 (cond ((= index (the fixnum (string-input-stream-end stream)))
762 (eof-or-lose stream eof-errorp eof-value))
763 (t
764 (setf (string-input-stream-current stream) (1+ index))
765 (aref string index)))))
766
767 (defun string-in-misc (stream operation &optional arg1 arg2)
768 (case operation
769 (:file-position
770 (if (null arg1)
771 (string-input-stream-current stream)))
772 (:read-line
773 (let ((string (string-input-stream-string stream))
774 (current (string-input-stream-current stream))
775 (end (string-input-stream-end stream)))
776 (declare (simple-string string) (fixnum current end))
777 (if (= current end)
778 (eof-or-lose stream arg1 arg2)
779 (let ((pos (position #\newline string :start current :end end)))
780 (if pos
781 (let* ((res-length (- (the fixnum pos) current))
782 (result (make-string res-length)))
783 (%primitive byte-blt string current result 0 res-length)
784 (setf (string-input-stream-current stream)
785 (1+ (the fixnum pos)))
786 (values result nil))
787 (let* ((res-length (- end current))
788 (result (make-string res-length)))
789 (%primitive byte-blt string current result 0 res-length)
790 (setf (string-input-stream-current stream) end)
791 (values result t)))))))
792 (:unread (decf (string-input-stream-current stream)))
793 (:listen (not (= (the fixnum (string-input-stream-current stream))
794 (the fixnum (string-input-stream-end stream)))))
795 (:element-type 'string-char)))
796
797 (defun make-string-input-stream (string &optional
798 (start 0) (end (length string)))
799 "Returns an input stream which will supply the characters of String between
800 Start and End in order."
801 (if (stringp string)
802 (internal-make-string-input-stream (coerce string 'simple-string)
803 start end)
804 (error "~S is not a string." string)))
805
806 ;;;; String Output Streams:
807
808 (defstruct (string-output-stream
809 (:include stream
810 (out #'string-ouch)
811 (sout #'string-sout)
812 (misc #'string-out-misc))
813 (:print-function %print-string-output-stream)
814 (:constructor make-string-output-stream ()))
815 ;; The string we throw stuff in.
816 (string (make-string 40) :type simple-string)
817 ;; Index of the next location to use.
818 (index 0 :type fixnum))
819
820 (defun %print-string-output-stream (s stream d)
821 (declare (ignore s d))
822 (write-string "#<String-Output Stream>" stream))
823
824 (setf (documentation 'make-string-output-stream 'function)
825 "Returns an Output stream which will accumulate all output given it for
826 the benefit of the function Get-Output-Stream-String.")
827
828 (defun string-ouch (stream character)
829 (let ((current (string-output-stream-index stream))
830 (workspace (string-output-stream-string stream)))
831 (declare (simple-string workspace) (fixnum current))
832 (if (= current (the fixnum (length workspace)))
833 (let ((new-workspace (make-string (* current 2))))
834 (%primitive byte-blt workspace 0 new-workspace 0 current)
835 (setf (aref new-workspace current) character)
836 (setf (string-output-stream-string stream) new-workspace))
837 (setf (aref workspace current) character))
838 (setf (string-output-stream-index stream) (1+ current))))
839
840 (defun string-sout (stream string start end)
841 (declare (simple-string string) (fixnum start end))
842 (let* ((current (string-output-stream-index stream))
843 (length (- end start))
844 (dst-end (+ length current))
845 (workspace (string-output-stream-string stream)))
846 (declare (simple-string workspace)
847 (fixnum current length dst-end))
848 (if (> dst-end (the fixnum (length workspace)))
849 (let ((new-workspace (make-string (+ (* current 2) length))))
850 (%primitive byte-blt workspace 0 new-workspace 0 current)
851 (%primitive byte-blt string start new-workspace current dst-end)
852 (setf (string-output-stream-string stream) new-workspace))
853 (%primitive byte-blt string start workspace current dst-end))
854 (setf (string-output-stream-index stream) dst-end)))
855
856 (defun string-out-misc (stream operation &optional arg1 arg2)
857 (declare (ignore arg1 arg2))
858 (case operation
859 (:file-position
860 (if (null arg1)
861 (string-output-stream-index stream)))
862 (:charpos
863 (do ((index (1- (the fixnum (string-output-stream-index stream)))
864 (1- index))
865 (count 0 (1+ count))
866 (string (string-output-stream-string stream)))
867 ((< index 0) count)
868 (declare (simple-string string)
869 (fixnum index count))
870 (if (char= (schar string index) #\newline)
871 (return count))))
872 (:element-type 'string-char)))
873
874 (defun get-output-stream-string (stream)
875 "Returns a string of all the characters sent to a stream made by
876 Make-String-Output-Stream since the last call to this function."
877 (if (streamp stream)
878 (let* ((length (string-output-stream-index stream))
879 (result (make-string length)))
880 (%primitive byte-blt (string-output-stream-string stream) 0
881 result 0 length)
882 (setf (string-output-stream-index stream) 0)
883 result)
884 (error "~S is not a string stream.")))
885
886 (defun dump-output-stream-string (in-stream out-stream)
887 "Dumps the characters buffer up in the In-Stream to the Out-Stream as
888 Get-Output-Stream-String would return them."
889 (write-string (string-output-stream-string in-stream) out-stream
890 :start 0 :end (string-output-stream-index in-stream))
891 (setf (string-output-stream-index in-stream) 0))
892
893 ;;;; Fill-pointer streams:
894 ;;;
895 ;;; Fill pointer string output streams are not explicitly mentioned in
896 ;;; the CLM, but they are required for the implementation of With-Output-To-String.
897
898 (defstruct (fill-pointer-output-stream
899 (:include stream
900 (out #'fill-pointer-ouch)
901 (sout #'fill-pointer-sout)
902 (misc #'fill-pointer-misc))
903 (:print-function
904 (lambda (s stream d)
905 (declare (ignore s d))
906 (write-string "#<Fill-Pointer String Output Stream>" stream)))
907 (:constructor make-fill-pointer-output-stream (string)))
908 ;; The string we throw stuff in.
909 string)
910
911
912 (defun fill-pointer-ouch (stream character)
913 (let* ((buffer (fill-pointer-output-stream-string stream))
914 (current (fill-pointer buffer))
915 (current+1 (1+ current)))
916 (declare (fixnum current))
917 (with-array-data ((workspace buffer) (start) (end))
918 (declare (simple-string workspace))
919 (let ((offset-current (+ start current)))
920 (declare (fixnum offset-current))
921 (if (= offset-current end)
922 (let* ((new-length (* current 2))
923 (new-workspace (make-string new-length)))
924 (declare (simple-string new-workspace))
925 (%primitive byte-blt workspace start new-workspace 0 current)
926 (setf workspace new-workspace)
927 (setf offset-current current)
928 (set-array-header buffer workspace new-length
929 current+1 0 new-length nil))
930 (setf (fill-pointer buffer) current+1))
931 (setf (schar workspace offset-current) character)))
932 current+1))
933
934
935 (defun fill-pointer-sout (stream string start end)
936 (declare (simple-string string) (fixnum start end))
937 (let* ((buffer (fill-pointer-output-stream-string stream))
938 (current (fill-pointer buffer))
939 (string-len (- end start))
940 (dst-end (+ string-len current)))
941 (declare (fixnum current dst-end string-len))
942 (with-array-data ((workspace buffer) (dst-start) (dst-length))
943 (declare (simple-string workspace))
944 (let ((offset-dst-end (+ dst-start dst-end))
945 (offset-current (+ dst-start current)))
946 (declare (fixnum offset-dst-end offset-current))
947 (if (> offset-dst-end dst-length)
948 (let* ((new-length (+ (the fixnum (* current 2)) string-len))
949 (new-workspace (make-string new-length)))
950 (declare (simple-string new-workspace))
951 (%primitive byte-blt workspace dst-start new-workspace 0 current)
952 (setf workspace new-workspace)
953 (setf offset-current current)
954 (setf offset-dst-end dst-end)
955 (set-array-header buffer workspace new-length
956 dst-end 0 new-length nil))
957 (setf (fill-pointer buffer) dst-end))
958 (%primitive byte-blt string start
959 workspace offset-current offset-dst-end)))
960 dst-end))
961
962
963 (defun fill-pointer-misc (stream operation &optional arg1 arg2)
964 (declare (ignore arg1 arg2))
965 (case operation
966 (:charpos
967 (let* ((buffer (fill-pointer-output-stream-string stream))
968 (current (fill-pointer buffer)))
969 (with-array-data ((string buffer) (start) (end current))
970 (declare (simple-string string) (ignore start))
971 (let ((found (position #\newline string :test #'char=
972 :end end :from-end t)))
973 (if found
974 (- end (the fixnum found))
975 current)))))
976 (:element-type 'string-char)))
977
978 ;;;; Indenting streams:
979
980 (defstruct (indenting-stream (:include stream
981 (out #'indenting-out)
982 (sout #'indenting-sout)
983 (misc #'indenting-misc))
984 (:print-function %print-indenting-stream)
985 (:constructor make-indenting-stream (stream)))
986 ;; The stream we're based on:
987 stream
988 ;; How much we indent on each line:
989 (indentation 0))
990
991 (setf (documentation 'make-indenting-stream 'function)
992 "Returns an ouput stream which indents its output by some amount.")
993
994 (defun %print-indenting-stream (s stream d)
995 (declare (ignore s d))
996 (write-string "#<Indenting Stream>" stream))
997
998 ;;; Indenting-Indent writes the right number of spaces needed to indent output on
999 ;;; the given Stream based on the specified Sub-Stream.
1000
1001 (defmacro indenting-indent (stream sub-stream)
1002 `(do ((i 0 (+ i 60))
1003 (indentation (indenting-stream-indentation ,stream)))
1004 ((>= i indentation))
1005 (funcall (stream-sout ,sub-stream) ,sub-stream
1006 " "
1007 0 (min 60 (- indentation i)))))
1008
1009 ;;; Indenting-Out writes a character to an indenting stream.
1010
1011 (defun indenting-out (stream char)
1012 (let ((sub-stream (indenting-stream-stream stream)))
1013 (funcall (stream-out sub-stream) sub-stream char)
1014 (if (char= char #\newline)
1015 (indenting-indent stream sub-stream))))
1016
1017 ;;; Indenting-Sout writes a string to an indenting stream.
1018
1019 (defun indenting-sout (stream string start end)
1020 (declare (simple-string string) (fixnum start end))
1021 (do ((i start)
1022 (sub-stream (indenting-stream-stream stream)))
1023 ((= i end))
1024 (let ((newline (position #\newline string :start i :end end)))
1025 (cond (newline
1026 (funcall (stream-sout sub-stream) sub-stream string i (1+ newline))
1027 (indenting-indent stream sub-stream)
1028 (setq i (+ newline 1)))
1029 (t
1030 (funcall (stream-sout sub-stream) sub-stream string i end)
1031 (setq i end))))))
1032
1033 ;;; Indenting-Misc just treats just the :Line-Length message differently.
1034 ;;; Indenting-Charpos says the charpos is the charpos of the base stream minus
1035 ;;; the stream's indentation.
1036
1037 (defun indenting-misc (stream operation &optional arg1 arg2)
1038 (let* ((sub-stream (indenting-stream-stream stream))
1039 (method (stream-misc sub-stream)))
1040 (case operation
1041 (:line-length
1042 (let ((line-length (funcall method sub-stream operation)))
1043 (if line-length
1044 (- line-length (indenting-stream-indentation stream)))))
1045 (:charpos
1046 (let* ((sub-stream (indenting-stream-stream stream))
1047 (charpos (funcall method sub-stream operation)))
1048 (if charpos
1049 (- charpos (indenting-stream-indentation stream)))))
1050 (t
1051 (funcall method sub-stream operation arg1 arg2)))))
1052
1053 (proclaim '(notinline read-char unread-char read-byte listen))

  ViewVC Help
Powered by ViewVC 1.1.5