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

Contents of /src/code/stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Wed Oct 17 03:46:22 1990 UTC (23 years, 6 months ago) by ram
Branch: MAIN
Changes since 1.5: +3 -3 lines
Fixed CONCATENATED-READLINE to not declare variables to be 
SIMPLE-STRING when they aren't.
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.6 1990/10/17 03:46:22 ram 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
196 #\newline)))
197 (if nl
198 (values (prog1 (subseq (the simple-string buffer) index nl)
199 (setf (stream-in-index stream)
200 (1+ (the fixnum nl))))
201 nil)
202 (multiple-value-bind (str eofp)
203 (funcall (stream-misc stream) stream
204 :read-line eof-errorp eof-value)
205 (if (= index in-buffer-length)
206 (values str eofp)
207 (let ((first (subseq buffer index in-buffer-length)))
208 (setf (stream-in-index stream) in-buffer-length)
209 (if (eq str eof-value)
210 (values first t)
211 (values (concatenate 'simple-string first
212 (the simple-string str))
213 eofp)))))))
214 (funcall (stream-misc stream) stream :read-line eof-errorp
215 eof-value))))
216
217 ;;; We proclaim them inline here, then proclaim them notinline at EOF,
218 ;;; so, except in this file, they are not inline by default, but they can be.
219 ;;;
220 (proclaim '(inline read-char unread-char read-byte listen))
221 (defun read-char (&optional (stream *standard-input*) (eof-errorp t) eof-value
222 recursive-p)
223 "Inputs a character from Stream and returns it."
224 (declare (ignore recursive-p))
225 (let* ((stream (in-synonym-of stream))
226 (index (stream-in-index stream)))
227 (declare (fixnum index))
228 (if (eql index in-buffer-length)
229 (funcall (stream-in stream) stream eof-errorp eof-value)
230 (prog1 (aref (stream-in-buffer stream) index)
231 (setf (stream-in-index stream) (1+ index))))))
232
233 (defun unread-char (character &optional (stream *standard-input*))
234 "Puts the Character back on the front of the input Stream."
235 (let* ((stream (in-synonym-of stream))
236 (index (1- (the fixnum (stream-in-index stream))))
237 (buffer (stream-in-buffer stream)))
238 (declare (fixnum index))
239 (when (minusp index) (error "Nothing to unread."))
240 (if buffer
241 (setf (aref (the simple-array buffer) index) character
242 (stream-in-index stream) index)
243 (funcall (stream-misc stream) stream :unread character)))
244 nil)
245
246 (defun peek-char (&optional (peek-type nil) (stream *standard-input*)
247 (eof-errorp t) eof-value recursive-p)
248 "Peeks at the next character in the input Stream. See manual for details."
249 (declare (ignore recursive-p))
250 (let* ((stream (in-synonym-of stream))
251 (char (read-char stream eof-errorp eof-value)))
252 (cond ((eq char eof-value) char)
253 ((characterp peek-type)
254 (do ((char char (read-char stream eof-errorp eof-value)))
255 ((or (eq char eof-value) (char= char peek-type))
256 (unless (eq char eof-value)
257 (unread-char char stream))
258 char)))
259 ((eq peek-type t)
260 (do ((char char (read-char stream eof-errorp eof-value)))
261 ((or (eq char eof-value) (not (whitespace-char-p char)))
262 (unless (eq char eof-value)
263 (unread-char char stream))
264 char)))
265 (t
266 (unread-char char stream)
267 char))))
268
269 (defun listen (&optional (stream *standard-input*))
270 "Returns T if a character is availible on the given Stream."
271 (let ((stream (in-synonym-of stream)))
272 (or (/= (the fixnum (stream-in-index stream)) in-buffer-length)
273 (funcall (stream-misc stream) stream :listen))))
274
275 (defun read-char-no-hang (&optional (stream *standard-input*)
276 (eof-errorp t) eof-value recursive-p)
277 "Returns the next character from the Stream if one is availible, or nil."
278 (declare (ignore recursive-p))
279 (if (listen stream) (read-char stream eof-errorp eof-value) nil))
280
281 (defun clear-input (&optional (stream *standard-input*))
282 "Clears any buffered input associated with the Stream."
283 (let ((stream (in-synonym-of stream)))
284 (setf (stream-in-index stream) in-buffer-length)
285 (funcall (stream-misc stream) stream :clear-input)
286 nil))
287
288 (defun read-byte (stream &optional (eof-errorp t) eof-value)
289 "Returns the next byte of the Stream."
290 (let* ((stream (in-synonym-of stream))
291 (index (stream-in-index stream)))
292 (declare (fixnum index))
293 (if (eql index in-buffer-length)
294 (funcall (stream-bin stream) stream eof-errorp eof-value)
295 (prog1 (aref (stream-in-buffer stream) index)
296 (setf (stream-in-index stream) (1+ index))))))
297
298 (defun read-n-bytes (stream buffer start numbytes &optional (eof-errorp t))
299 "Reads Numbytes bytes into the Buffer starting at Start, and returns
300 the number of bytes actually read if the end of file was hit before Numbytes
301 bytes were read (and Eof-Errorp is false)."
302 (declare (fixnum numbytes))
303 (let* ((stream (in-synonym-of stream))
304 (in-buffer (stream-in-buffer stream))
305 (index (stream-in-index stream))
306 (num-buffered (- in-buffer-length index)))
307 (declare (fixnum index num-buffered))
308 (cond
309 ((not in-buffer)
310 (with-in-stream stream stream-n-bin buffer start numbytes eof-errorp))
311 ((not (typep in-buffer
312 '(or simple-string (simple-array (unsigned-byte 8) (*)))))
313 (error "N-Bin only works on 8-bit-like streams."))
314 ((<= numbytes num-buffered)
315 (%primitive byte-blt in-buffer index buffer start (+ start numbytes))
316 (setf (stream-in-index stream) (+ index numbytes))
317 numbytes)
318 (t
319 (let ((end (+ start num-buffered)))
320 (%primitive byte-blt in-buffer index buffer start end)
321 (setf (stream-in-index stream) in-buffer-length)
322 (+ (with-in-stream stream stream-n-bin buffer end
323 (- numbytes num-buffered)
324 eof-errorp)
325 num-buffered))))))
326
327 ;;; Output functions:
328
329 (defun write-char (character &optional (stream *standard-output*))
330 "Outputs the Character to the Stream."
331 (with-out-stream stream stream-out character)
332 character)
333
334 (defun terpri (&optional (stream *standard-output*))
335 "Outputs a new line to the Stream."
336 (with-out-stream stream stream-out #\newline)
337 nil)
338
339 (defun fresh-line (&optional (stream *standard-output*))
340 "Outputs a new line to the Stream if it is not positioned at the begining of
341 a line. Returns T if it output a new line, nil otherwise."
342 (let ((stream (out-synonym-of stream)))
343 (when (/= (or (charpos stream) 1) 0)
344 (funcall (stream-out stream) stream #\newline)
345 t)))
346
347 (defun write-string (string &optional (stream *standard-output*)
348 &key (start 0) (end (length (the vector string))))
349 "Outputs the String to the given Stream."
350 (write-string* string stream start end))
351
352 (defun write-string* (string &optional (stream *standard-output*)
353 (start 0) (end (length (the vector string))))
354 (declare (fixnum start end))
355 (if (array-header-p string)
356 (with-array-data ((data string) (offset-start start) (offset-end end))
357 (with-out-stream stream stream-sout data offset-start offset-end))
358 (with-out-stream stream stream-sout string start end))
359 string)
360
361 (defun write-line (string &optional (stream *standard-output*)
362 &key (start 0) (end (length string)))
363 "Outputs the String to the given Stream, followed by a newline character."
364 (write-line* string stream start end))
365
366 (defun write-line* (string &optional (stream *standard-output*)
367 (start 0) (end (length string)))
368 (declare (fixnum start end))
369 (let ((stream (out-synonym-of stream)))
370 (if (array-header-p string)
371 (with-array-data ((data string) (offset-start start) (offset-end end))
372 (with-out-stream stream stream-sout data offset-start offset-end))
373 (with-out-stream stream stream-sout string start end))
374 (funcall (stream-out stream) stream #\newline))
375 string)
376
377 (defun charpos (&optional (stream *standard-output*))
378 "Returns the number of characters on the current line of output of the given
379 Stream, or Nil if that information is not availible."
380 (with-out-stream stream stream-misc :charpos))
381
382 (defun line-length (&optional (stream *standard-output*))
383 "Returns the number of characters that will fit on a line of output on the
384 given Stream, or Nil if that information is not available."
385 (with-out-stream stream stream-misc :line-length))
386
387 (defun finish-output (&optional (stream *standard-output*))
388 "Attempts to ensure that all output sent to the the Stream has reached its
389 destination, and only then returns."
390 (with-out-stream stream stream-misc :finish-output)
391 nil)
392
393 (defun force-output (&optional (stream *standard-output*))
394 "Attempts to force any buffered output to be sent."
395 (with-out-stream stream stream-misc :force-output)
396 nil)
397
398 (defun clear-output (&optional (stream *standard-output*))
399 "Clears the given output Stream."
400 (with-out-stream stream stream-misc :clear-output)
401 nil)
402
403 (defun write-byte (integer stream)
404 "Outputs the Integer to the binary Stream."
405 (with-out-stream stream stream-bout integer)
406 integer)
407
408 ;;;; Broadcast streams:
409
410 (defstruct (broadcast-stream (:include stream
411 (out #'broadcast-out)
412 (bout #'broadcast-bout)
413 (sout #'broadcast-sout)
414 (misc #'broadcast-misc))
415 (:print-function %print-broadcast-stream)
416 (:constructor make-broadcast-stream (&rest streams)))
417 ;; This is a list of all the streams we broadcast to.
418 streams)
419
420 (setf (documentation 'make-broadcast-stream 'function)
421 "Returns an ouput stream which sends its output to all of the given streams.")
422
423 (defun %print-broadcast-stream (s stream d)
424 (declare (ignore s d))
425 (write-string "#<Broadcast Stream>" stream))
426
427 (macrolet ((out-fun (fun method &rest args)
428 `(defun ,fun (stream ,@args)
429 (dolist (stream (broadcast-stream-streams stream))
430 (funcall (,method stream) stream ,@args)))))
431 (out-fun broadcast-out stream-out char)
432 (out-fun broadcast-bout stream-bout byte)
433 (out-fun broadcast-sout stream-sout string start end))
434
435 (defun broadcast-misc (stream operation &optional arg1 arg2)
436 (let ((streams (broadcast-stream-streams stream)))
437 (case operation
438 (:charpos
439 (dolist (stream streams)
440 (let ((charpos (funcall (stream-misc stream) stream :charpos)))
441 (if charpos (return charpos)))))
442 (:line-length
443 (let ((min nil))
444 (dolist (stream streams min)
445 (let ((res (funcall (stream-misc stream) stream :line-length)))
446 (when res (setq min (if min (min res min) res)))))))
447 (:element-type
448 (let (res)
449 (dolist (stream streams (if (> (length res) 1) `(and ,@res) res))
450 (pushnew (funcall (stream-misc stream) stream :element-type) res
451 :test #'equal))))
452 (t
453 (let ((res nil))
454 (dolist (stream streams res)
455 (setq res (funcall (stream-misc stream) stream operation
456 arg1 arg2))))))))
457
458 ;;;; Synonym Streams:
459
460 (defstruct (synonym-stream (:include stream
461 (in #'synonym-in)
462 (bin #'synonym-bin)
463 (n-bin #'synonym-n-bin)
464 (out #'synonym-out)
465 (bout #'synonym-bout)
466 (sout #'synonym-sout)
467 (misc #'synonym-misc))
468 (:print-function %print-synonym-stream)
469 (:constructor make-synonym-stream (symbol)))
470 ;; This is the symbol, the value of which is the stream we are synonym to.
471 symbol)
472
473 (defun %print-synonym-stream (s stream d)
474 (declare (ignore d))
475 (format stream "#<Synonym Stream to ~S>" (synonym-stream-symbol s)))
476
477 (setf (documentation 'make-synonym-stream 'function)
478 "Returns a stream which performs its operations on the stream which is the
479 value of the dynamic variable named by Symbol.")
480
481 ;;; The output simple output methods just call the corresponding method
482 ;;; in the synonymed stream.
483 ;;;
484 (macrolet ((out-fun (name slot &rest args)
485 `(defun ,name (stream ,@args)
486 (let ((syn (symbol-value (synonym-stream-symbol stream))))
487 (funcall (,slot syn) syn ,@args)))))
488 (out-fun synonym-out stream-out ch)
489 (out-fun synonym-bout stream-bout n)
490 (out-fun synonym-sout stream-sout string start end))
491
492
493 ;;; Bind synonym stream to this so that SPIO can turn on the right frob in
494 ;;; the icon when we are in a terminal input wait.
495 ;;;
496 (defvar *previous-stream* nil)
497
498 ;;; For the input methods, we just call the corresponding function on the
499 ;;; synonymed stream. These functions deal with getting input out of
500 ;;; the In-Buffer if there is any.
501 ;;;
502 (macrolet ((in-fun (name fun &rest args)
503 `(defun ,name (stream ,@args)
504 (let ((*previous-stream* stream))
505 (,fun (symbol-value (synonym-stream-symbol stream)) ,@args)))))
506 (in-fun synonym-in read-char eof-errorp eof-value)
507 (in-fun synonym-bin read-byte eof-errorp eof-value)
508 (in-fun synonym-n-bin read-n-bytes buffer start numbytes eof-errorp))
509
510
511 ;;; Synonym-Misc -- Internal
512 ;;;
513 ;;; We have to special-case the operations which could look at stuff in
514 ;;; the in-buffer.
515 ;;;
516 (defun synonym-misc (stream operation &optional arg1 arg2)
517 (let ((syn (symbol-value (synonym-stream-symbol stream)))
518 (*previous-stream* stream))
519 (case operation
520 (:read-line (read-line syn))
521 (:listen (or (/= (the fixnum (stream-in-index syn)) in-buffer-length)
522 (funcall (stream-misc syn) syn :listen)))
523 (t
524 (funcall (stream-misc syn) syn operation arg1 arg2)))))
525
526 ;;;; Two-Way streams:
527
528 (defstruct (two-way-stream
529 (:include stream
530 (in #'two-way-in)
531 (bin #'two-way-bin)
532 (n-bin #'two-way-n-bin)
533 (out #'two-way-out)
534 (bout #'two-way-bout)
535 (sout #'two-way-sout)
536 (misc #'two-way-misc))
537 (:print-function %print-two-way-stream)
538 (:constructor make-two-way-stream (input-stream output-stream)))
539 ;; We read from this stream...
540 input-stream
541 ;; And write to this one
542 output-stream)
543
544 (defun %print-two-way-stream (s stream d)
545 (declare (ignore d))
546 (format stream "#<Two-Way Stream, Input = ~S, Output = ~S>"
547 (two-way-stream-input-stream s)
548 (two-way-stream-output-stream s)))
549
550 (setf (documentation 'make-two-way-stream 'function)
551 "Returns a bidirectional stream which gets its input from Input-Stream and
552 sends its output to Output-Stream.")
553
554 (macrolet ((out-fun (name slot &rest args)
555 `(defun ,name (stream ,@args)
556 (let ((syn (two-way-stream-output-stream stream)))
557 (funcall (,slot syn) syn ,@args)))))
558 (out-fun two-way-out stream-out ch)
559 (out-fun two-way-bout stream-bout n)
560 (out-fun two-way-sout stream-sout string start end))
561
562 (macrolet ((in-fun (name fun &rest args)
563 `(defun ,name (stream ,@args)
564 (,fun (two-way-stream-input-stream stream) ,@args))))
565 (in-fun two-way-in read-char eof-errorp eof-value)
566 (in-fun two-way-bin read-byte eof-errorp eof-value)
567 (in-fun two-way-n-bin read-n-bytes buffer start numbytes eof-errorp))
568
569 (defun two-way-misc (stream operation &optional arg1 arg2)
570 (let* ((in (two-way-stream-input-stream stream))
571 (in-method (stream-misc in))
572 (out (two-way-stream-output-stream stream))
573 (out-method (stream-misc out)))
574 (case operation
575 (:listen (or (/= (the fixnum (stream-in-index in)) in-buffer-length)
576 (funcall in-method in :listen)))
577 (:read-line (read-line in arg1 arg2))
578 ((:finish-output :force-output :clear-output)
579 (funcall out-method out operation arg1 arg2))
580 ((:clear-input :unread)
581 (funcall in-method in operation arg1 arg2))
582 (:element-type
583 (let ((in-type (funcall in-method in :element-type))
584 (out-type (funcall out-method out :element-type)))
585 (if (equal in-type out-type)
586 in-type `(and ,in-type ,out-type))))
587 (:close
588 (funcall in-method in :close arg1)
589 (funcall out-method out :close arg1)
590 (set-closed-flame stream))
591 (t
592 (or (funcall in-method in operation arg1 arg2)
593 (funcall out-method out operation arg1 arg2))))))
594
595 ;;;; Concatenated Streams:
596
597 (defstruct (concatenated-stream
598 (:include stream
599 (in #'concatenated-in)
600 (bin #'concatenated-bin)
601 (misc #'concatenated-misc))
602 (:print-function %print-concatenated-stream)
603 (:constructor
604 make-concatenated-stream (&rest streams &aux (current streams))))
605 ;; The car of this is the stream we are reading from now.
606 current
607 ;; This is a list of all the streams. We need to remember them so that
608 ;; we can close them.
609 streams)
610
611 (defun %print-concatenated-stream (s stream d)
612 (declare (ignore d))
613 (format stream "#<Concatenated Stream, Streams = ~S>"
614 (concatenated-stream-streams s)))
615
616 (setf (documentation 'make-concatenated-stream 'function)
617 "Returns a stream which takes its input from each of the Streams in turn,
618 going on to the next at EOF.")
619
620 (macrolet ((in-fun (name fun)
621 `(defun ,name (stream eof-errorp eof-value)
622 (do ((current (concatenated-stream-current stream) (cdr current)))
623 ((null current)
624 (eof-or-lose stream eof-errorp eof-value))
625 (let* ((stream (car current))
626 (result (,fun stream nil nil)))
627 (when result (return result)))
628 (setf (concatenated-stream-current stream) current)))))
629 (in-fun concatenated-in read-char)
630 (in-fun concatenated-bin read-byte))
631
632 ;;; Concatenated-Readline is somewhat hairy, since we may need to
633 ;;; do several readlines and concatenate the result if the lines are
634 ;;; terminated by eof.
635 ;;;
636 (defun concatenated-readline (stream eof-errorp eof-value)
637 ;; Loop until we find a stream that will give us something or we error
638 ;; out.
639 (do ((current (concatenated-stream-current stream) (cdr current)))
640 ((null current)
641 (eof-or-lose stream eof-errorp eof-value))
642 (setf (concatenated-stream-current stream) current)
643 (let ((this (car current)))
644 (multiple-value-bind (result eofp)
645 (read-line this nil nil)
646 (declare (simple-string result))
647 ;; Once we have found some input, we loop until we either find a
648 ;; line not terminated by eof or hit eof on the last stream.
649 (when result
650 (do ((current (cdr current) (cdr current))
651 (new ""))
652 ((or (not eofp) (null current))
653 (return-from concatenated-readline (values result eofp)))
654 (declare (type (or simple-string (member :eof)) new))
655 (setf (concatenated-stream-current stream) current)
656 (let ((this (car current)))
657 (multiple-value-setq (new eofp)
658 (read-line this nil :eof))
659 (if new
660 (setq result (concatenate 'simple-string result new))
661 (setq eofp t)))))))))
662
663 (defun concatenated-misc (stream operation &optional arg1 arg2)
664 (if (eq operation :read-line)
665 (concatenated-readline stream arg1 arg2)
666 (let ((left (concatenated-stream-current stream)))
667 (when left
668 (let* ((current (car left))
669 (misc (stream-misc current)))
670 (case operation
671 (:listen (or (/= (the fixnum (stream-in-index current)) in-buffer-length)
672 (funcall misc current :listen)))
673 (:close
674 (dolist (stream (concatenated-stream-streams stream))
675 (funcall (stream-misc stream) stream :close arg1))
676 (set-closed-flame stream))
677 (t
678 (funcall misc current operation arg1 arg2))))))))
679
680 ;;;; Echo Streams:
681
682 (defstruct (echo-stream
683 (:include two-way-stream
684 (in #'echo-in)
685 (bin #'echo-bin)
686 (misc #'echo-misc)
687 (n-bin #'ill-bin))
688 (:print-function %print-echo-stream)
689 (:constructor make-echo-stream (input-stream output-stream))))
690
691
692 (macrolet ((in-fun (name fun out-slot &rest args)
693 `(defun ,name (stream ,@args)
694 (let* ((in (two-way-stream-input-stream stream))
695 (out (two-way-stream-output-stream stream))
696 (result (,fun in ,@args)))
697 (funcall (,out-slot out) out result)
698 result))))
699 (in-fun echo-in read-char stream-out eof-errorp eof-value)
700 (in-fun echo-bin read-byte stream-bout eof-errorp eof-value))
701
702 (defun echo-misc (stream operation &optional arg1 arg2)
703 (let* ((in (two-way-stream-input-stream stream))
704 (in-method (stream-misc in))
705 (out (two-way-stream-output-stream stream))
706 (out-method (stream-misc out)))
707 (case operation
708 (:listen (or (/= (the fixnum (stream-in-index in)) in-buffer-length)
709 (funcall in-method in :listen)))
710 (:read-line
711 (multiple-value-bind (result eofp)
712 (read-line in arg1 arg2)
713 (if eofp
714 (write-string result out)
715 (write-line result out))
716 (values result eofp)))
717 (:element-type
718 (let ((in-type (funcall in-method in :element-type))
719 (out-type (funcall out-method out :element-type)))
720 (if (equal in-type out-type)
721 in-type `(and ,in-type ,out-type))))
722 (:close
723 (funcall in-method in :close arg1)
724 (funcall out-method out :close arg1)
725 (set-closed-flame stream))
726 (t
727 (or (funcall in-method in operation arg1 arg2)
728 (funcall out-method out operation arg1 arg2))))))
729
730 (defun %print-echo-stream (s stream d)
731 (declare (ignore d))
732 (format stream "#<Echo Stream, Input = ~S, Output = ~S>"
733 (two-way-stream-input-stream s)
734 (two-way-stream-output-stream s)))
735
736 (setf (documentation 'make-echo-stream 'function)
737 "Returns a bidirectional stream which gets its input from Input-Stream and
738 sends its output to Output-Stream. In addition, all input is echoed to
739 the output stream")
740
741 ;;;; String Input Streams:
742
743 (defstruct (string-input-stream
744 (:include stream
745 (in #'string-inch)
746 (misc #'string-in-misc))
747 (:print-function %print-string-input-stream)
748 (:constructor nil)
749 (:constructor internal-make-string-input-stream
750 (string current end)))
751 (string nil :type simple-string)
752 (current nil :type fixnum)
753 (end nil :type fixnum))
754
755 (defun %print-string-input-stream (s stream d)
756 (declare (ignore s d))
757 (write-string "#<String-Input Stream>" stream))
758
759 (defun string-inch (stream eof-errorp eof-value)
760 (let ((string (string-input-stream-string stream))
761 (index (string-input-stream-current stream)))
762 (declare (simple-string string) (fixnum index))
763 (cond ((= index (the fixnum (string-input-stream-end stream)))
764 (eof-or-lose stream eof-errorp eof-value))
765 (t
766 (setf (string-input-stream-current stream) (1+ index))
767 (aref string index)))))
768
769 (defun string-in-misc (stream operation &optional arg1 arg2)
770 (case operation
771 (:file-position
772 (if arg1
773 (setf (string-input-stream-current stream) arg1)
774 (string-input-stream-current stream)))
775 (:file-length (length (string-input-stream-string stream)))
776 (:read-line
777 (let ((string (string-input-stream-string stream))
778 (current (string-input-stream-current stream))
779 (end (string-input-stream-end stream)))
780 (declare (simple-string string) (fixnum current end))
781 (if (= current end)
782 (eof-or-lose stream arg1 arg2)
783 (let ((pos (position #\newline string :start current :end end)))
784 (if pos
785 (let* ((res-length (- (the fixnum pos) current))
786 (result (make-string res-length)))
787 (%primitive byte-blt string current result 0 res-length)
788 (setf (string-input-stream-current stream)
789 (1+ (the fixnum pos)))
790 (values result nil))
791 (let* ((res-length (- end current))
792 (result (make-string res-length)))
793 (%primitive byte-blt string current result 0 res-length)
794 (setf (string-input-stream-current stream) end)
795 (values result t)))))))
796 (:unread (decf (string-input-stream-current stream)))
797 (:listen (not (= (the fixnum (string-input-stream-current stream))
798 (the fixnum (string-input-stream-end stream)))))
799 (:element-type 'string-char)))
800
801 (defun make-string-input-stream (string &optional
802 (start 0) (end (length string)))
803 "Returns an input stream which will supply the characters of String between
804 Start and End in order."
805 (if (stringp string)
806 (internal-make-string-input-stream (coerce string 'simple-string)
807 start end)
808 (error "~S is not a string." string)))
809
810 ;;;; String Output Streams:
811
812 (defstruct (string-output-stream
813 (:include stream
814 (out #'string-ouch)
815 (sout #'string-sout)
816 (misc #'string-out-misc))
817 (:print-function %print-string-output-stream)
818 (:constructor make-string-output-stream ()))
819 ;; The string we throw stuff in.
820 (string (make-string 40) :type simple-string)
821 ;; Index of the next location to use.
822 (index 0 :type fixnum))
823
824 (defun %print-string-output-stream (s stream d)
825 (declare (ignore s d))
826 (write-string "#<String-Output Stream>" stream))
827
828 (setf (documentation 'make-string-output-stream 'function)
829 "Returns an Output stream which will accumulate all output given it for
830 the benefit of the function Get-Output-Stream-String.")
831
832 (defun string-ouch (stream character)
833 (let ((current (string-output-stream-index stream))
834 (workspace (string-output-stream-string stream)))
835 (declare (simple-string workspace) (fixnum current))
836 (if (= current (the fixnum (length workspace)))
837 (let ((new-workspace (make-string (* current 2))))
838 (%primitive byte-blt workspace 0 new-workspace 0 current)
839 (setf (aref new-workspace current) character)
840 (setf (string-output-stream-string stream) new-workspace))
841 (setf (aref workspace current) character))
842 (setf (string-output-stream-index stream) (1+ current))))
843
844 (defun string-sout (stream string start end)
845 (declare (simple-string string) (fixnum start end))
846 (let* ((current (string-output-stream-index stream))
847 (length (- end start))
848 (dst-end (+ length current))
849 (workspace (string-output-stream-string stream)))
850 (declare (simple-string workspace)
851 (fixnum current length dst-end))
852 (if (> dst-end (the fixnum (length workspace)))
853 (let ((new-workspace (make-string (+ (* current 2) length))))
854 (%primitive byte-blt workspace 0 new-workspace 0 current)
855 (%primitive byte-blt string start new-workspace current dst-end)
856 (setf (string-output-stream-string stream) new-workspace))
857 (%primitive byte-blt string start workspace current dst-end))
858 (setf (string-output-stream-index stream) dst-end)))
859
860 (defun string-out-misc (stream operation &optional arg1 arg2)
861 (declare (ignore arg2))
862 (case operation
863 (:file-position
864 (if (null arg1)
865 (string-output-stream-index stream)))
866 (:charpos
867 (do ((index (1- (the fixnum (string-output-stream-index stream)))
868 (1- index))
869 (count 0 (1+ count))
870 (string (string-output-stream-string stream)))
871 ((< index 0) count)
872 (declare (simple-string string)
873 (fixnum index count))
874 (if (char= (schar string index) #\newline)
875 (return count))))
876 (:element-type 'string-char)))
877
878 (defun get-output-stream-string (stream)
879 "Returns a string of all the characters sent to a stream made by
880 Make-String-Output-Stream since the last call to this function."
881 (if (streamp stream)
882 (let* ((length (string-output-stream-index stream))
883 (result (make-string length)))
884 (%primitive byte-blt (string-output-stream-string stream) 0
885 result 0 length)
886 (setf (string-output-stream-index stream) 0)
887 result)
888 (error "~S is not a string stream.")))
889
890 (defun dump-output-stream-string (in-stream out-stream)
891 "Dumps the characters buffer up in the In-Stream to the Out-Stream as
892 Get-Output-Stream-String would return them."
893 (write-string (string-output-stream-string in-stream) out-stream
894 :start 0 :end (string-output-stream-index in-stream))
895 (setf (string-output-stream-index in-stream) 0))
896
897 ;;;; Fill-pointer streams:
898 ;;;
899 ;;; Fill pointer string output streams are not explicitly mentioned in
900 ;;; the CLM, but they are required for the implementation of With-Output-To-String.
901
902 (defstruct (fill-pointer-output-stream
903 (:include stream
904 (out #'fill-pointer-ouch)
905 (sout #'fill-pointer-sout)
906 (misc #'fill-pointer-misc))
907 (:print-function
908 (lambda (s stream d)
909 (declare (ignore s d))
910 (write-string "#<Fill-Pointer String Output Stream>" stream)))
911 (:constructor make-fill-pointer-output-stream (string)))
912 ;; The string we throw stuff in.
913 string)
914
915
916 (defun fill-pointer-ouch (stream character)
917 (let* ((buffer (fill-pointer-output-stream-string stream))
918 (current (fill-pointer buffer))
919 (current+1 (1+ current)))
920 (declare (fixnum current))
921 (with-array-data ((workspace buffer) (start) (end))
922 (declare (simple-string workspace))
923 (let ((offset-current (+ start current)))
924 (declare (fixnum offset-current))
925 (if (= offset-current end)
926 (let* ((new-length (* current 2))
927 (new-workspace (make-string new-length)))
928 (declare (simple-string new-workspace))
929 (%primitive byte-blt workspace start new-workspace 0 current)
930 (setf workspace new-workspace)
931 (setf offset-current current)
932 (set-array-header buffer workspace new-length
933 current+1 0 new-length nil))
934 (setf (fill-pointer buffer) current+1))
935 (setf (schar workspace offset-current) character)))
936 current+1))
937
938
939 (defun fill-pointer-sout (stream string start end)
940 (declare (simple-string string) (fixnum start end))
941 (let* ((buffer (fill-pointer-output-stream-string stream))
942 (current (fill-pointer buffer))
943 (string-len (- end start))
944 (dst-end (+ string-len current)))
945 (declare (fixnum current dst-end string-len))
946 (with-array-data ((workspace buffer) (dst-start) (dst-length))
947 (declare (simple-string workspace))
948 (let ((offset-dst-end (+ dst-start dst-end))
949 (offset-current (+ dst-start current)))
950 (declare (fixnum offset-dst-end offset-current))
951 (if (> offset-dst-end dst-length)
952 (let* ((new-length (+ (the fixnum (* current 2)) string-len))
953 (new-workspace (make-string new-length)))
954 (declare (simple-string new-workspace))
955 (%primitive byte-blt workspace dst-start new-workspace 0 current)
956 (setf workspace new-workspace)
957 (setf offset-current current)
958 (setf offset-dst-end dst-end)
959 (set-array-header buffer workspace new-length
960 dst-end 0 new-length nil))
961 (setf (fill-pointer buffer) dst-end))
962 (%primitive byte-blt string start
963 workspace offset-current offset-dst-end)))
964 dst-end))
965
966
967 (defun fill-pointer-misc (stream operation &optional arg1 arg2)
968 (declare (ignore arg1 arg2))
969 (case operation
970 (:charpos
971 (let* ((buffer (fill-pointer-output-stream-string stream))
972 (current (fill-pointer buffer)))
973 (with-array-data ((string buffer) (start) (end current))
974 (declare (simple-string string) (ignore start))
975 (let ((found (position #\newline string :test #'char=
976 :end end :from-end t)))
977 (if found
978 (- end (the fixnum found))
979 current)))))
980 (:element-type 'string-char)))
981
982 ;;;; Indenting streams:
983
984 (defstruct (indenting-stream (:include stream
985 (out #'indenting-out)
986 (sout #'indenting-sout)
987 (misc #'indenting-misc))
988 (:print-function %print-indenting-stream)
989 (:constructor make-indenting-stream (stream)))
990 ;; The stream we're based on:
991 stream
992 ;; How much we indent on each line:
993 (indentation 0))
994
995 (setf (documentation 'make-indenting-stream 'function)
996 "Returns an ouput stream which indents its output by some amount.")
997
998 (defun %print-indenting-stream (s stream d)
999 (declare (ignore s d))
1000 (write-string "#<Indenting Stream>" stream))
1001
1002 ;;; Indenting-Indent writes the right number of spaces needed to indent output on
1003 ;;; the given Stream based on the specified Sub-Stream.
1004
1005 (defmacro indenting-indent (stream sub-stream)
1006 `(do ((i 0 (+ i 60))
1007 (indentation (indenting-stream-indentation ,stream)))
1008 ((>= i indentation))
1009 (funcall (stream-sout ,sub-stream) ,sub-stream
1010 " "
1011 0 (min 60 (- indentation i)))))
1012
1013 ;;; Indenting-Out writes a character to an indenting stream.
1014
1015 (defun indenting-out (stream char)
1016 (let ((sub-stream (indenting-stream-stream stream)))
1017 (funcall (stream-out sub-stream) sub-stream char)
1018 (if (char= char #\newline)
1019 (indenting-indent stream sub-stream))))
1020
1021 ;;; Indenting-Sout writes a string to an indenting stream.
1022
1023 (defun indenting-sout (stream string start end)
1024 (declare (simple-string string) (fixnum start end))
1025 (do ((i start)
1026 (sub-stream (indenting-stream-stream stream)))
1027 ((= i end))
1028 (let ((newline (position #\newline string :start i :end end)))
1029 (cond (newline
1030 (funcall (stream-sout sub-stream) sub-stream string i (1+ newline))
1031 (indenting-indent stream sub-stream)
1032 (setq i (+ newline 1)))
1033 (t
1034 (funcall (stream-sout sub-stream) sub-stream string i end)
1035 (setq i end))))))
1036
1037 ;;; Indenting-Misc just treats just the :Line-Length message differently.
1038 ;;; Indenting-Charpos says the charpos is the charpos of the base stream minus
1039 ;;; the stream's indentation.
1040
1041 (defun indenting-misc (stream operation &optional arg1 arg2)
1042 (let* ((sub-stream (indenting-stream-stream stream))
1043 (method (stream-misc sub-stream)))
1044 (case operation
1045 (:line-length
1046 (let ((line-length (funcall method sub-stream operation)))
1047 (if line-length
1048 (- line-length (indenting-stream-indentation stream)))))
1049 (:charpos
1050 (let* ((sub-stream (indenting-stream-stream stream))
1051 (charpos (funcall method sub-stream operation)))
1052 (if charpos
1053 (- charpos (indenting-stream-indentation stream)))))
1054 (t
1055 (funcall method sub-stream operation arg1 arg2)))))
1056
1057 (proclaim '(notinline read-char unread-char read-byte listen))

  ViewVC Help
Powered by ViewVC 1.1.5