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

Contents of /src/code/stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14 - (show annotations)
Thu Dec 10 01:08:40 1992 UTC (21 years, 4 months ago) by ram
Branch: MAIN
Changes since 1.13: +36 -17 lines
Exported various slot accessors of streams now part of the standard.  Made
these read-only slots.  Added open-stream-p and interactive-stream-p.
1 ;;; -*- Package: Lisp -*-
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 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/stream.lisp,v 1.14 1992/12/10 01:08:40 ram Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; Stream functions for Spice Lisp.
15 ;;; Written by Skef Wholey and Rob MacLachlan.
16 ;;;
17 ;;; This file contains the OS-independent stream functions.
18 ;;;
19 (in-package "LISP")
20
21 (export '(broadcast-stream make-broadcast-stream broadcast-stream-streams
22 synonym-stream make-synonym-stream synonym-stream-symbol
23 concatenated-stream make-concatenated-stream
24 concatenated-stream-streams
25 two-way-stream make-two-way-stream two-way-stream-input-stream
26 two-way-stream-output-stream
27 echo-stream make-echo-stream echo-stream-input-stream
28 echo-stream-output-stream
29 make-string-input-stream make-string-output-stream
30 get-output-stream-string stream-element-type input-stream-p
31 output-stream-p open-stream-p interactive-stream-p
32 close read-line read-char
33 unread-char peek-char listen read-char-no-hang clear-input read-byte
34 write-char write-string write-line terpri fresh-line
35 finish-output force-output clear-output write-byte
36 stream streamp string-stream
37 *standard-input* *standard-output*
38 *error-output* *query-io* *debug-io* *terminal-io* *trace-output*))
39
40 (in-package 'system)
41 (export '(make-indenting-stream read-n-bytes))
42 (in-package 'lisp)
43
44 (deftype string-stream ()
45 '(or string-input-stream string-output-stream
46 fill-pointer-output-stream))
47
48 ;;;; Standard streams:
49 ;;;
50 ;;; The initialization of these streams is performed by Stream-Init,
51 ;;; which lives in the file of machine-specific stream functions.
52 ;;;
53 (defvar *terminal-io* () "Terminal I/O stream.")
54 (defvar *standard-input* () "Default input stream.")
55 (defvar *standard-output* () "Default output stream.")
56 (defvar *error-output* () "Error output stream.")
57 (defvar *query-io* () "Query I/O stream.")
58 (defvar *trace-output* () "Trace output stream.")
59 (defvar *debug-io* () "Interactive debugging stream.")
60
61 (defun ill-in (stream &rest ignore)
62 (declare (ignore ignore))
63 (error "~S is not a character input stream." stream))
64 (defun ill-out (stream &rest ignore)
65 (declare (ignore ignore))
66 (error "~S is not a character output stream." stream))
67 (defun ill-bin (stream &rest ignore)
68 (declare (ignore ignore))
69 (error "~S is not a binary input stream." stream))
70 (defun ill-bout (stream &rest ignore)
71 (declare (ignore ignore))
72 (error "~S is not a binary output stream." stream))
73 (defun closed-flame (stream &rest ignore)
74 (declare (ignore ignore))
75 (error "~S is closed." stream))
76 (defun do-nothing (&rest ignore)
77 (declare (ignore ignore)))
78
79 (defun %print-stream (structure stream d)
80 (declare (ignore d structure))
81 (write-string "#<Bare Stream>" stream))
82
83 ;;; HOW THE STREAM STRUCTURE IS USED:
84 ;;;
85 ;;; Many of the slots of the stream structure contain functions
86 ;;; which are called to perform some operation on the stream. Closed
87 ;;; streams have #'Closed-Flame in all of their function slots. If
88 ;;; one side of an I/O or echo stream is closed, the whole stream is
89 ;;; considered closed. The functions in the operation slots take
90 ;;; arguments as follows:
91 ;;;
92 ;;; In: Stream, Eof-Errorp, Eof-Value
93 ;;; Bin: Stream, Eof-Errorp, Eof-Value
94 ;;; N-Bin: Stream, Buffer, Start, Numbytes, Eof-Errorp
95 ;;; Out: Stream, Character
96 ;;; Bout: Stream, Integer
97 ;;; Sout: Stream, String, Start, End
98 ;;; Misc: Stream, Operation, &Optional Arg1, Arg2
99 ;;;
100 ;;; In order to save space, some of the less common stream operations
101 ;;; are handled by just one function, the Misc method. This function
102 ;;; is passed a keyword which indicates the operation to perform.
103 ;;; The following keywords are used:
104 ;;; :read-line - Do a read-line.
105 ;;; :listen - Return the following values:
106 ;;; t if any input waiting.
107 ;;; :eof if at eof.
108 ;;; nil if no input is available and not at eof.
109 ;;; :unread - Unread the character Arg.
110 ;;; :close - Do any stream specific stuff to close the stream.
111 ;;; The methods are set to closed-flame by the close
112 ;;; function, so that need not be done by this
113 ;;; function.
114 ;;; :clear-input - Clear any unread input
115 ;;; :finish-output,
116 ;;; :force-output - Cause output to happen
117 ;;; :clear-output - Clear any undone output
118 ;;; :element-type - Return the type of element the stream deals with.
119 ;;; :line-length - Return the length of a line of output.
120 ;;; :charpos - Return current output position on the line.
121 ;;; :file-length - Return the file length of a file stream.
122 ;;; :file-position - Return or change the current position of a file stream.
123 ;;; :file-name - Return the name of an associated file.
124 ;;; :interactive-p - Is this an interactive device?
125 ;;;
126 ;;; In order to do almost anything useful, it is necessary to
127 ;;; define a new type of structure that includes stream, so that the
128 ;;; stream can have some state information.
129 ;;;
130 ;;; THE STREAM IN-BUFFER:
131 ;;;
132 ;;; The In-Buffer in the stream holds characters or bytes that
133 ;;; are ready to be read by some input function. If there is any
134 ;;; stuff in the In-Buffer, then the reading function can use it
135 ;;; without calling any stream method. Any stream may put stuff in
136 ;;; the In-Buffer, and may also assume that any input in the In-Buffer
137 ;;; has been consumed before any in-method is called. If a text
138 ;;; stream has in In-Buffer, then the first character should not be
139 ;;; used to buffer normal input so that it is free for unreading into.
140 ;;;
141 ;;; The In-Buffer slot is a vector In-Buffer-Length long. The
142 ;;; In-Index is the index in the In-Buffer of the first available
143 ;;; object. The available objects are thus between In-Index and the
144 ;;; length of the In-Buffer.
145 ;;;
146 ;;; When this buffer is only accessed by the normal stream
147 ;;; functions, the number of function calls is halved, thus
148 ;;; potentially doubling the speed of simple operations. If the
149 ;;; Fast-Read-Char and Fast-Read-Byte macros are used, nearly all
150 ;;; function call overhead is removed, vastly speeding up these
151 ;;; important operations.
152 ;;;
153 ;;; If a stream does not have an In-Buffer, then the In-Buffer slot
154 ;;; must be nil, and the In-Index must be In-Buffer-Length. These are
155 ;;; the default values for the slots.
156
157 ;;; Stream manipulation functions.
158
159 (defun input-stream-p (stream)
160 "Returns non-nil if the given Stream can perform input operations."
161 (and (streamp stream)
162 (not (eq (stream-in stream) #'closed-flame))
163 (or (not (eq (stream-in stream) #'ill-in))
164 (not (eq (stream-bin stream) #'ill-bin)))))
165
166 (defun output-stream-p (stream)
167 "Returns non-nil if the given Stream can perform output operations."
168 (and (streamp stream)
169 (not (eq (stream-in stream) #'closed-flame))
170 (or (not (eq (stream-out stream) #'ill-out))
171 (not (eq (stream-bout stream) #'ill-bout)))))
172
173 (defun open-stream-p (stream)
174 "Return true if Stream is not closed."
175 (declare (type stream stream))
176 (not (eq (stream-in stream) #'closed-flame)))
177
178 (defun stream-element-type (stream)
179 "Returns a type specifier for the kind of object returned by the Stream."
180 (if (streamp stream)
181 (funcall (stream-misc stream) stream :element-type)
182 (error "~S is not a stream." stream)))
183
184 (defun interactive-stream-p (stream)
185 "Return true if Stream does I/O on a terminal or other interactive device."
186 (declare (type stream stream))
187 (funcall (stream-misc stream) stream :interactive-p))
188
189 (defun close (stream &key abort)
190 "Closes the given Stream. No more I/O may be performed, but inquiries
191 may still be made. If :Abort is non-nil, an attempt is made to clean
192 up the side effects of having created the stream."
193 (if (streamp stream)
194 (unless (eq (stream-in stream) #'closed-flame)
195 (funcall (stream-misc stream) stream :close abort))
196 (error "~S is not a stream." stream))
197 t)
198
199 (defun set-closed-flame (stream)
200 (setf (stream-in stream) #'closed-flame)
201 (setf (stream-bin stream) #'closed-flame)
202 (setf (stream-n-bin stream) #'closed-flame)
203 (setf (stream-in stream) #'closed-flame)
204 (setf (stream-out stream) #'closed-flame)
205 (setf (stream-bout stream) #'closed-flame)
206 (setf (stream-sout stream) #'closed-flame)
207 (setf (stream-misc stream) #'closed-flame))
208
209 ;;; Input functions:
210
211 (defun read-line (&optional (stream *standard-input*) (eof-errorp t) eof-value
212 recursive-p)
213 "Returns a line of text read from the Stream as a string, discarding the
214 newline character."
215 (declare (ignore recursive-p))
216 (let* ((stream (in-synonym-of stream))
217 (buffer (stream-in-buffer stream))
218 (index (stream-in-index stream)))
219 (declare (fixnum index))
220 (if (simple-string-p buffer)
221 (let ((nl (%sp-find-character buffer index in-buffer-length
222 #\newline)))
223 (if nl
224 (values (prog1 (subseq (the simple-string buffer) index nl)
225 (setf (stream-in-index stream)
226 (1+ (the fixnum nl))))
227 nil)
228 (multiple-value-bind (str eofp)
229 (funcall (stream-misc stream) stream
230 :read-line eof-errorp eof-value)
231 (if (= index in-buffer-length)
232 (values str eofp)
233 (let ((first (subseq buffer index in-buffer-length)))
234 (setf (stream-in-index stream) in-buffer-length)
235 (if (eq str eof-value)
236 (values first t)
237 (values (concatenate 'simple-string first
238 (the simple-string str))
239 eofp)))))))
240 (funcall (stream-misc stream) stream :read-line eof-errorp
241 eof-value))))
242
243
244 ;;; We proclaim them inline here, then proclaim them notinline at EOF,
245 ;;; so, except in this file, they are not inline by default, but they can be.
246 ;;;
247 (proclaim '(inline read-char unread-char read-byte listen))
248 (defun read-char (&optional (stream *standard-input*) (eof-errorp t) eof-value
249 recursive-p)
250 "Inputs a character from Stream and returns it."
251 (declare (ignore recursive-p))
252 (let* ((stream (in-synonym-of stream))
253 (index (stream-in-index stream)))
254 (declare (fixnum index))
255 (if (eql index in-buffer-length)
256 (funcall (stream-in stream) stream eof-errorp eof-value)
257 (prog1 (aref (stream-in-buffer stream) index)
258 (setf (stream-in-index stream) (1+ index))))))
259
260 (defun unread-char (character &optional (stream *standard-input*))
261 "Puts the Character back on the front of the input Stream."
262 (let* ((stream (in-synonym-of stream))
263 (index (1- (the fixnum (stream-in-index stream))))
264 (buffer (stream-in-buffer stream)))
265 (declare (fixnum index))
266 (when (minusp index) (error "Nothing to unread."))
267 (if buffer
268 (setf (aref (the simple-array buffer) index) character
269 (stream-in-index stream) index)
270 (funcall (stream-misc stream) stream :unread character)))
271 nil)
272
273 (defun peek-char (&optional (peek-type nil) (stream *standard-input*)
274 (eof-errorp t) eof-value recursive-p)
275 "Peeks at the next character in the input Stream. See manual for details."
276 (declare (ignore recursive-p))
277 (let* ((stream (in-synonym-of stream))
278 (char (read-char stream eof-errorp eof-value)))
279 (cond ((eq char eof-value) char)
280 ((characterp peek-type)
281 (do ((char char (read-char stream eof-errorp eof-value)))
282 ((or (eq char eof-value) (char= char peek-type))
283 (unless (eq char eof-value)
284 (unread-char char stream))
285 char)))
286 ((eq peek-type t)
287 (do ((char char (read-char stream eof-errorp eof-value)))
288 ((or (eq char eof-value) (not (whitespace-char-p char)))
289 (unless (eq char eof-value)
290 (unread-char char stream))
291 char)))
292 (t
293 (unread-char char stream)
294 char))))
295
296 (defun listen (&optional (stream *standard-input*))
297 "Returns T if a character is availible on the given Stream."
298 (let ((stream (in-synonym-of stream)))
299 (or (/= (the fixnum (stream-in-index stream)) in-buffer-length)
300 ;; Test for t explicitly since misc methods return :eof sometimes.
301 (eq (funcall (stream-misc stream) stream :listen) t))))
302
303 (defun read-char-no-hang (&optional (stream *standard-input*)
304 (eof-errorp t) eof-value recursive-p)
305 "Returns the next character from the Stream if one is availible, or nil."
306 (declare (ignore recursive-p))
307 (let ((stream (in-synonym-of stream)))
308 (if (funcall (stream-misc stream) stream :listen)
309 ;; On t or :eof get READ-CHAR to do the work.
310 (read-char stream eof-errorp eof-value)
311 nil)))
312
313 (defun clear-input (&optional (stream *standard-input*))
314 "Clears any buffered input associated with the Stream."
315 (let ((stream (in-synonym-of stream)))
316 (setf (stream-in-index stream) in-buffer-length)
317 (funcall (stream-misc stream) stream :clear-input)
318 nil))
319
320 (defun read-byte (stream &optional (eof-errorp t) eof-value)
321 "Returns the next byte of the Stream."
322 (let* ((stream (in-synonym-of stream))
323 (index (stream-in-index stream)))
324 (declare (fixnum index))
325 (if (eql index in-buffer-length)
326 (funcall (stream-bin stream) stream eof-errorp eof-value)
327 (prog1 (aref (stream-in-buffer stream) index)
328 (setf (stream-in-index stream) (1+ index))))))
329
330 (defun read-n-bytes (stream buffer start numbytes &optional (eof-errorp t))
331 "Reads Numbytes bytes into the Buffer starting at Start, and returns
332 the number of bytes actually read if the end of file was hit before Numbytes
333 bytes were read (and Eof-Errorp is false)."
334 (declare (fixnum numbytes))
335 (let* ((stream (in-synonym-of stream))
336 (in-buffer (stream-in-buffer stream))
337 (index (stream-in-index stream))
338 (num-buffered (- in-buffer-length index)))
339 (declare (fixnum index num-buffered))
340 (cond
341 ((not in-buffer)
342 (with-in-stream stream stream-n-bin buffer start numbytes eof-errorp))
343 ((not (typep in-buffer
344 '(or simple-string (simple-array (unsigned-byte 8) (*)))))
345 (error "N-Bin only works on 8-bit-like streams."))
346 ((<= numbytes num-buffered)
347 (%primitive byte-blt in-buffer index buffer start (+ start numbytes))
348 (setf (stream-in-index stream) (+ index numbytes))
349 numbytes)
350 (t
351 (let ((end (+ start num-buffered)))
352 (%primitive byte-blt in-buffer index buffer start end)
353 (setf (stream-in-index stream) in-buffer-length)
354 (+ (with-in-stream stream stream-n-bin buffer end
355 (- numbytes num-buffered)
356 eof-errorp)
357 num-buffered))))))
358
359 ;;; Output functions:
360
361 (defun write-char (character &optional (stream *standard-output*))
362 "Outputs the Character to the Stream."
363 (with-out-stream stream stream-out character)
364 character)
365
366 (defun terpri (&optional (stream *standard-output*))
367 "Outputs a new line to the Stream."
368 (with-out-stream stream stream-out #\newline)
369 nil)
370
371 (defun fresh-line (&optional (stream *standard-output*))
372 "Outputs a new line to the Stream if it is not positioned at the begining of
373 a line. Returns T if it output a new line, nil otherwise."
374 (let ((stream (out-synonym-of stream)))
375 (when (/= (or (charpos stream) 1) 0)
376 (funcall (stream-out stream) stream #\newline)
377 t)))
378
379 (defun write-string (string &optional (stream *standard-output*)
380 &key (start 0) (end (length (the vector string))))
381 "Outputs the String to the given Stream."
382 (write-string* string stream start end))
383
384 (defun write-string* (string &optional (stream *standard-output*)
385 (start 0) (end (length (the vector string))))
386 (declare (fixnum start end))
387 (if (array-header-p string)
388 (with-array-data ((data string) (offset-start start) (offset-end end))
389 (with-out-stream stream stream-sout data offset-start offset-end))
390 (with-out-stream stream stream-sout string start end))
391 string)
392
393 (defun write-line (string &optional (stream *standard-output*)
394 &key (start 0) (end (length string)))
395 "Outputs the String to the given Stream, followed by a newline character."
396 (write-line* string stream start end))
397
398 (defun write-line* (string &optional (stream *standard-output*)
399 (start 0) (end (length string)))
400 (declare (fixnum start end))
401 (let ((stream (out-synonym-of stream)))
402 (if (array-header-p string)
403 (with-array-data ((data string) (offset-start start) (offset-end end))
404 (with-out-stream stream stream-sout data offset-start offset-end))
405 (with-out-stream stream stream-sout string start end))
406 (funcall (stream-out stream) stream #\newline))
407 string)
408
409 (defun charpos (&optional (stream *standard-output*))
410 "Returns the number of characters on the current line of output of the given
411 Stream, or Nil if that information is not availible."
412 (with-out-stream stream stream-misc :charpos))
413
414 (defun line-length (&optional (stream *standard-output*))
415 "Returns the number of characters that will fit on a line of output on the
416 given Stream, or Nil if that information is not available."
417 (with-out-stream stream stream-misc :line-length))
418
419 (defun finish-output (&optional (stream *standard-output*))
420 "Attempts to ensure that all output sent to the the Stream has reached its
421 destination, and only then returns."
422 (with-out-stream stream stream-misc :finish-output)
423 nil)
424
425 (defun force-output (&optional (stream *standard-output*))
426 "Attempts to force any buffered output to be sent."
427 (with-out-stream stream stream-misc :force-output)
428 nil)
429
430 (defun clear-output (&optional (stream *standard-output*))
431 "Clears the given output Stream."
432 (with-out-stream stream stream-misc :clear-output)
433 nil)
434
435 (defun write-byte (integer stream)
436 "Outputs the Integer to the binary Stream."
437 (with-out-stream stream stream-bout integer)
438 integer)
439
440 ;;;; Broadcast streams:
441
442 (defstruct (broadcast-stream (:include stream
443 (out #'broadcast-out)
444 (bout #'broadcast-bout)
445 (sout #'broadcast-sout)
446 (misc #'broadcast-misc))
447 (:print-function %print-broadcast-stream)
448 (:constructor make-broadcast-stream (&rest streams)))
449 ;; This is a list of all the streams we broadcast to.
450 (streams () :type list :read-only t))
451
452 (setf (documentation 'make-broadcast-stream 'function)
453 "Returns an ouput stream which sends its output to all of the given streams.")
454
455 (defun %print-broadcast-stream (s stream d)
456 (declare (ignore s d))
457 (write-string "#<Broadcast Stream>" stream))
458
459 (macrolet ((out-fun (fun method &rest args)
460 `(defun ,fun (stream ,@args)
461 (dolist (stream (broadcast-stream-streams stream))
462 (funcall (,method stream) stream ,@args)))))
463 (out-fun broadcast-out stream-out char)
464 (out-fun broadcast-bout stream-bout byte)
465 (out-fun broadcast-sout stream-sout string start end))
466
467 (defun broadcast-misc (stream operation &optional arg1 arg2)
468 (let ((streams (broadcast-stream-streams stream)))
469 (case operation
470 (:charpos
471 (dolist (stream streams)
472 (let ((charpos (funcall (stream-misc stream) stream :charpos)))
473 (if charpos (return charpos)))))
474 (:line-length
475 (let ((min nil))
476 (dolist (stream streams min)
477 (let ((res (funcall (stream-misc stream) stream :line-length)))
478 (when res (setq min (if min (min res min) res)))))))
479 (:element-type
480 (let (res)
481 (dolist (stream streams (if (> (length res) 1) `(and ,@res) res))
482 (pushnew (funcall (stream-misc stream) stream :element-type) res
483 :test #'equal))))
484 (t
485 (let ((res nil))
486 (dolist (stream streams res)
487 (setq res (funcall (stream-misc stream) stream operation
488 arg1 arg2))))))))
489
490 ;;;; Synonym Streams:
491
492 (defstruct (synonym-stream (:include stream
493 (in #'synonym-in)
494 (bin #'synonym-bin)
495 (n-bin #'synonym-n-bin)
496 (out #'synonym-out)
497 (bout #'synonym-bout)
498 (sout #'synonym-sout)
499 (misc #'synonym-misc))
500 (:print-function %print-synonym-stream)
501 (:constructor make-synonym-stream (symbol)))
502 ;; This is the symbol, the value of which is the stream we are synonym to.
503 (symbol :type symbol :read-only t))
504
505 (defun %print-synonym-stream (s stream d)
506 (declare (ignore d))
507 (format stream "#<Synonym Stream to ~S>" (synonym-stream-symbol s)))
508
509 (setf (documentation 'make-synonym-stream 'function)
510 "Returns a stream which performs its operations on the stream which is the
511 value of the dynamic variable named by Symbol.")
512
513 ;;; The output simple output methods just call the corresponding method
514 ;;; in the synonymed stream.
515 ;;;
516 (macrolet ((out-fun (name slot &rest args)
517 `(defun ,name (stream ,@args)
518 (declare (optimize (safety 1)))
519 (let ((syn (symbol-value (synonym-stream-symbol stream))))
520 (funcall (,slot syn) syn ,@args)))))
521 (out-fun synonym-out stream-out ch)
522 (out-fun synonym-bout stream-bout n)
523 (out-fun synonym-sout stream-sout string start end))
524
525
526 ;;; Bind synonym stream to this so that SPIO can turn on the right frob in
527 ;;; the icon when we are in a terminal input wait.
528 ;;;
529 (defvar *previous-stream* nil)
530
531 ;;; For the input methods, we just call the corresponding function on the
532 ;;; synonymed stream. These functions deal with getting input out of
533 ;;; the In-Buffer if there is any.
534 ;;;
535 (macrolet ((in-fun (name fun &rest args)
536 `(defun ,name (stream ,@args)
537 (declare (optimize (safety 1)))
538 (let ((*previous-stream* stream))
539 (,fun (symbol-value (synonym-stream-symbol stream)) ,@args)))))
540 (in-fun synonym-in read-char eof-errorp eof-value)
541 (in-fun synonym-bin read-byte eof-errorp eof-value)
542 (in-fun synonym-n-bin read-n-bytes buffer start numbytes eof-errorp))
543
544
545 ;;; Synonym-Misc -- Internal
546 ;;;
547 ;;; We have to special-case the operations which could look at stuff in
548 ;;; the in-buffer.
549 ;;;
550 (defun synonym-misc (stream operation &optional arg1 arg2)
551 (declare (optimize (safety 1)))
552 (let ((syn (symbol-value (synonym-stream-symbol stream)))
553 (*previous-stream* stream))
554 (case operation
555 (:read-line (read-line syn))
556 (:listen (or (/= (the fixnum (stream-in-index syn)) in-buffer-length)
557 (funcall (stream-misc syn) syn :listen)))
558 (t
559 (funcall (stream-misc syn) syn operation arg1 arg2)))))
560
561 ;;;; Two-Way streams:
562
563 (defstruct (two-way-stream
564 (:include stream
565 (in #'two-way-in)
566 (bin #'two-way-bin)
567 (n-bin #'two-way-n-bin)
568 (out #'two-way-out)
569 (bout #'two-way-bout)
570 (sout #'two-way-sout)
571 (misc #'two-way-misc))
572 (:print-function %print-two-way-stream)
573 (:constructor make-two-way-stream (input-stream output-stream)))
574 ;; We read from this stream...
575 (input-stream (required-argument) :type stream :read-only t)
576 ;; And write to this one
577 (output-stream (required-argument) :type stream :read-only t))
578
579 (defun %print-two-way-stream (s stream d)
580 (declare (ignore d))
581 (format stream "#<Two-Way Stream, Input = ~S, Output = ~S>"
582 (two-way-stream-input-stream s)
583 (two-way-stream-output-stream s)))
584
585 (setf (documentation 'make-two-way-stream 'function)
586 "Returns a bidirectional stream which gets its input from Input-Stream and
587 sends its output to Output-Stream.")
588
589 (macrolet ((out-fun (name slot &rest args)
590 `(defun ,name (stream ,@args)
591 (let ((syn (two-way-stream-output-stream stream)))
592 (funcall (,slot syn) syn ,@args)))))
593 (out-fun two-way-out stream-out ch)
594 (out-fun two-way-bout stream-bout n)
595 (out-fun two-way-sout stream-sout string start end))
596
597 (macrolet ((in-fun (name fun &rest args)
598 `(defun ,name (stream ,@args)
599 (force-output (two-way-stream-output-stream stream))
600 (,fun (two-way-stream-input-stream stream) ,@args))))
601 (in-fun two-way-in read-char eof-errorp eof-value)
602 (in-fun two-way-bin read-byte eof-errorp eof-value)
603 (in-fun two-way-n-bin read-n-bytes buffer start numbytes eof-errorp))
604
605 (defun two-way-misc (stream operation &optional arg1 arg2)
606 (let* ((in (two-way-stream-input-stream stream))
607 (in-method (stream-misc in))
608 (out (two-way-stream-output-stream stream))
609 (out-method (stream-misc out)))
610 (case operation
611 (:listen (or (/= (the fixnum (stream-in-index in)) in-buffer-length)
612 (funcall in-method in :listen)))
613 (:read-line
614 (force-output out)
615 (read-line in arg1 arg2))
616 ((:finish-output :force-output :clear-output)
617 (funcall out-method out operation arg1 arg2))
618 ((:clear-input :unread)
619 (funcall in-method in operation arg1 arg2))
620 (:element-type
621 (let ((in-type (funcall in-method in :element-type))
622 (out-type (funcall out-method out :element-type)))
623 (if (equal in-type out-type)
624 in-type `(and ,in-type ,out-type))))
625 (:close
626 (funcall in-method in :close arg1)
627 (funcall out-method out :close arg1)
628 (set-closed-flame stream))
629 (t
630 (or (funcall in-method in operation arg1 arg2)
631 (funcall out-method out operation arg1 arg2))))))
632
633 ;;;; Concatenated Streams:
634
635 (defstruct (concatenated-stream
636 (:include stream
637 (in #'concatenated-in)
638 (bin #'concatenated-bin)
639 (misc #'concatenated-misc))
640 (:print-function %print-concatenated-stream)
641 (:constructor
642 make-concatenated-stream (&rest streams &aux (current streams))))
643 ;; The car of this is the stream we are reading from now.
644 current
645 ;; This is a list of all the streams. We need to remember them so that
646 ;; we can close them.
647 (streams nil :type list :read-only t))
648
649 (defun %print-concatenated-stream (s stream d)
650 (declare (ignore d))
651 (format stream "#<Concatenated Stream, Streams = ~S>"
652 (concatenated-stream-streams s)))
653
654 (setf (documentation 'make-concatenated-stream 'function)
655 "Returns a stream which takes its input from each of the Streams in turn,
656 going on to the next at EOF.")
657
658 (macrolet ((in-fun (name fun)
659 `(defun ,name (stream eof-errorp eof-value)
660 (do ((current (concatenated-stream-current stream) (cdr current)))
661 ((null current)
662 (eof-or-lose stream eof-errorp eof-value))
663 (let* ((stream (car current))
664 (result (,fun stream nil nil)))
665 (when result (return result)))
666 (setf (concatenated-stream-current stream) current)))))
667 (in-fun concatenated-in read-char)
668 (in-fun concatenated-bin read-byte))
669
670 ;;; Concatenated-Readline is somewhat hairy, since we may need to
671 ;;; do several readlines and concatenate the result if the lines are
672 ;;; terminated by eof.
673 ;;;
674 (defun concatenated-readline (stream eof-errorp eof-value)
675 ;; Loop until we find a stream that will give us something or we error
676 ;; out.
677 (do ((current (concatenated-stream-current stream) (cdr current)))
678 ((null current)
679 (eof-or-lose stream eof-errorp eof-value))
680 (setf (concatenated-stream-current stream) current)
681 (let ((this (car current)))
682 (multiple-value-bind (result eofp)
683 (read-line this nil :eof)
684 (declare (type (or simple-string (member :eof)) result))
685 ;; Once we have found some input, we loop until we either find a
686 ;; line not terminated by eof or hit eof on the last stream.
687 (unless (eq result :eof)
688 (do ((current (cdr current) (cdr current))
689 (new ""))
690 ((or (not eofp) (null current))
691 (return-from concatenated-readline (values result eofp)))
692 (declare (type (or simple-string (member :eof)) new))
693 (setf (concatenated-stream-current stream) current)
694 (let ((this (car current)))
695 (multiple-value-setq (new eofp)
696 (read-line this nil :eof))
697 (if (eq new :eof)
698 (setq eofp t)
699 (setq result (concatenate 'simple-string result new))))))))))
700
701 (defun concatenated-misc (stream operation &optional arg1 arg2)
702 (if (eq operation :read-line)
703 (concatenated-readline stream arg1 arg2)
704 (let ((left (concatenated-stream-current stream)))
705 (when left
706 (let* ((current (car left))
707 (misc (stream-misc current)))
708 (case operation
709 (:listen
710 (loop
711 (let ((stuff (funcall misc current :listen)))
712 (cond ((eq stuff :eof)
713 ;; Advance current, and try again.
714 (pop (concatenated-stream-current stream))
715 (setf current
716 (car (concatenated-stream-current stream)))
717 (unless current
718 ;; No further streams. EOF.
719 (return :eof))
720 (setf misc (stream-misc current)))
721 (stuff
722 ;; Stuff's available.
723 (return t))
724 (t
725 ;; Nothing available yet.
726 (return nil))))))
727 (:close
728 (dolist (stream (concatenated-stream-streams stream))
729 (funcall (stream-misc stream) stream :close arg1))
730 (set-closed-flame stream))
731 (t
732 (funcall misc current operation arg1 arg2))))))))
733
734 ;;;; Echo Streams:
735
736 (defstruct (echo-stream
737 (:include two-way-stream
738 (in #'echo-in)
739 (bin #'echo-bin)
740 (misc #'echo-misc)
741 (n-bin #'ill-bin))
742 (:print-function %print-echo-stream)
743 (:constructor make-echo-stream (input-stream output-stream)))
744 unread-stuff)
745
746
747 (macrolet ((in-fun (name fun out-slot &rest args)
748 `(defun ,name (stream ,@args)
749 (or (pop (echo-stream-unread-stuff stream))
750 (let* ((in (echo-stream-input-stream stream))
751 (out (echo-stream-output-stream stream))
752 (result (,fun in ,@args)))
753 (funcall (,out-slot out) out result)
754 result)))))
755 (in-fun echo-in read-char stream-out eof-errorp eof-value)
756 (in-fun echo-bin read-byte stream-bout eof-errorp eof-value))
757
758 (defun echo-misc (stream operation &optional arg1 arg2)
759 (let* ((in (two-way-stream-input-stream stream))
760 (in-method (stream-misc in))
761 (out (two-way-stream-output-stream stream))
762 (out-method (stream-misc out)))
763 (case operation
764 (:listen (or (not (null (echo-stream-unread-stuff stream)))
765 (/= (the fixnum (stream-in-index in)) in-buffer-length)
766 (funcall in-method in :listen)))
767 (:unread (push arg1 (echo-stream-unread-stuff stream)))
768 (:read-line
769 (let* ((stuff (echo-stream-unread-stuff stream))
770 (newline-pos (position #\newline stuff)))
771 (if newline-pos
772 (progn
773 (setf (echo-stream-unread-stuff stream)
774 (subseq stuff (1+ newline-pos)))
775 (values (coerce (subseq stuff 0 newline-pos) 'simple-string)
776 nil))
777 (multiple-value-bind (result eofp)
778 (read-line in arg1 arg2)
779 (if eofp
780 (write-string result out)
781 (write-line result out))
782 (setf (echo-stream-unread-stuff stream) nil)
783 (values (if stuff
784 (concatenate 'simple-string stuff result)
785 result)
786 eofp)))))
787 (:element-type
788 (let ((in-type (funcall in-method in :element-type))
789 (out-type (funcall out-method out :element-type)))
790 (if (equal in-type out-type)
791 in-type `(and ,in-type ,out-type))))
792 (:close
793 (funcall in-method in :close arg1)
794 (funcall out-method out :close arg1)
795 (set-closed-flame stream))
796 (t
797 (or (funcall in-method in operation arg1 arg2)
798 (funcall out-method out operation arg1 arg2))))))
799
800 (defun %print-echo-stream (s stream d)
801 (declare (ignore d))
802 (format stream "#<Echo Stream, Input = ~S, Output = ~S>"
803 (two-way-stream-input-stream s)
804 (two-way-stream-output-stream s)))
805
806 (setf (documentation 'make-echo-stream 'function)
807 "Returns a bidirectional stream which gets its input from Input-Stream and
808 sends its output to Output-Stream. In addition, all input is echoed to
809 the output stream")
810
811 ;;;; String Input Streams:
812
813 (defstruct (string-input-stream
814 (:include stream
815 (in #'string-inch)
816 (misc #'string-in-misc))
817 (:print-function %print-string-input-stream)
818 ;(:constructor nil)
819 (:constructor internal-make-string-input-stream
820 (string current end)))
821 (string nil :type simple-string)
822 (current nil :type fixnum)
823 (end nil :type fixnum))
824
825 (defun %print-string-input-stream (s stream d)
826 (declare (ignore s d))
827 (write-string "#<String-Input Stream>" stream))
828
829 (defun string-inch (stream eof-errorp eof-value)
830 (let ((string (string-input-stream-string stream))
831 (index (string-input-stream-current stream)))
832 (declare (simple-string string) (fixnum index))
833 (cond ((= index (the fixnum (string-input-stream-end stream)))
834 (eof-or-lose stream eof-errorp eof-value))
835 (t
836 (setf (string-input-stream-current stream) (1+ index))
837 (aref string index)))))
838
839 (defun string-in-misc (stream operation &optional arg1 arg2)
840 (case operation
841 (:file-position
842 (if arg1
843 (setf (string-input-stream-current stream) arg1)
844 (string-input-stream-current stream)))
845 (:file-length (length (string-input-stream-string stream)))
846 (:read-line
847 (let ((string (string-input-stream-string stream))
848 (current (string-input-stream-current stream))
849 (end (string-input-stream-end stream)))
850 (declare (simple-string string) (fixnum current end))
851 (if (= current end)
852 (eof-or-lose stream arg1 arg2)
853 (let ((pos (position #\newline string :start current :end end)))
854 (if pos
855 (let* ((res-length (- (the fixnum pos) current))
856 (result (make-string res-length)))
857 (%primitive byte-blt string current result 0 res-length)
858 (setf (string-input-stream-current stream)
859 (1+ (the fixnum pos)))
860 (values result nil))
861 (let* ((res-length (- end current))
862 (result (make-string res-length)))
863 (%primitive byte-blt string current result 0 res-length)
864 (setf (string-input-stream-current stream) end)
865 (values result t)))))))
866 (:unread (decf (string-input-stream-current stream)))
867 (:listen (or (/= (the fixnum (string-input-stream-current stream))
868 (the fixnum (string-input-stream-end stream)))
869 :eof))
870 (:element-type 'string-char)))
871
872 (defun make-string-input-stream (string &optional
873 (start 0) (end (length string)))
874 "Returns an input stream which will supply the characters of String between
875 Start and End in order."
876 (if (stringp string)
877 (internal-make-string-input-stream (coerce string 'simple-string)
878 start end)
879 (error "~S is not a string." string)))
880
881 ;;;; String Output Streams:
882
883 (defstruct (string-output-stream
884 (:include stream
885 (out #'string-ouch)
886 (sout #'string-sout)
887 (misc #'string-out-misc))
888 (:print-function %print-string-output-stream)
889 (:constructor make-string-output-stream ()))
890 ;; The string we throw stuff in.
891 (string (make-string 40) :type simple-string)
892 ;; Index of the next location to use.
893 (index 0 :type fixnum))
894
895 (defun %print-string-output-stream (s stream d)
896 (declare (ignore s d))
897 (write-string "#<String-Output Stream>" stream))
898
899 (setf (documentation 'make-string-output-stream 'function)
900 "Returns an Output stream which will accumulate all output given it for
901 the benefit of the function Get-Output-Stream-String.")
902
903 (defun string-ouch (stream character)
904 (let ((current (string-output-stream-index stream))
905 (workspace (string-output-stream-string stream)))
906 (declare (simple-string workspace) (fixnum current))
907 (if (= current (the fixnum (length workspace)))
908 (let ((new-workspace (make-string (* current 2))))
909 (%primitive byte-blt workspace 0 new-workspace 0 current)
910 (setf (aref new-workspace current) character)
911 (setf (string-output-stream-string stream) new-workspace))
912 (setf (aref workspace current) character))
913 (setf (string-output-stream-index stream) (1+ current))))
914
915 (defun string-sout (stream string start end)
916 (declare (simple-string string) (fixnum start end))
917 (let* ((current (string-output-stream-index stream))
918 (length (- end start))
919 (dst-end (+ length current))
920 (workspace (string-output-stream-string stream)))
921 (declare (simple-string workspace)
922 (fixnum current length dst-end))
923 (if (> dst-end (the fixnum (length workspace)))
924 (let ((new-workspace (make-string (+ (* current 2) length))))
925 (%primitive byte-blt workspace 0 new-workspace 0 current)
926 (%primitive byte-blt string start new-workspace current dst-end)
927 (setf (string-output-stream-string stream) new-workspace))
928 (%primitive byte-blt string start workspace current dst-end))
929 (setf (string-output-stream-index stream) dst-end)))
930
931 (defun string-out-misc (stream operation &optional arg1 arg2)
932 (declare (ignore arg2))
933 (case operation
934 (:file-position
935 (if (null arg1)
936 (string-output-stream-index stream)))
937 (:charpos
938 (do ((index (1- (the fixnum (string-output-stream-index stream)))
939 (1- index))
940 (count 0 (1+ count))
941 (string (string-output-stream-string stream)))
942 ((< index 0) count)
943 (declare (simple-string string)
944 (fixnum index count))
945 (if (char= (schar string index) #\newline)
946 (return count))))
947 (:element-type 'string-char)))
948
949 (defun get-output-stream-string (stream)
950 "Returns a string of all the characters sent to a stream made by
951 Make-String-Output-Stream since the last call to this function."
952 (if (streamp stream)
953 (let* ((length (string-output-stream-index stream))
954 (result (make-string length)))
955 (%primitive byte-blt (string-output-stream-string stream) 0
956 result 0 length)
957 (setf (string-output-stream-index stream) 0)
958 result)
959 (error "~S is not a string stream.")))
960
961 (defun dump-output-stream-string (in-stream out-stream)
962 "Dumps the characters buffer up in the In-Stream to the Out-Stream as
963 Get-Output-Stream-String would return them."
964 (write-string (string-output-stream-string in-stream) out-stream
965 :start 0 :end (string-output-stream-index in-stream))
966 (setf (string-output-stream-index in-stream) 0))
967
968 ;;;; Fill-pointer streams:
969 ;;;
970 ;;; Fill pointer string output streams are not explicitly mentioned in
971 ;;; the CLM, but they are required for the implementation of With-Output-To-String.
972
973 (defstruct (fill-pointer-output-stream
974 (:include stream
975 (out #'fill-pointer-ouch)
976 (sout #'fill-pointer-sout)
977 (misc #'fill-pointer-misc))
978 (:print-function
979 (lambda (s stream d)
980 (declare (ignore s d))
981 (write-string "#<Fill-Pointer String Output Stream>" stream)))
982 (:constructor make-fill-pointer-output-stream (string)))
983 ;; The string we throw stuff in.
984 string)
985
986
987 (defun fill-pointer-ouch (stream character)
988 (let* ((buffer (fill-pointer-output-stream-string stream))
989 (current (fill-pointer buffer))
990 (current+1 (1+ current)))
991 (declare (fixnum current))
992 (with-array-data ((workspace buffer) (start) (end))
993 (declare (simple-string workspace))
994 (let ((offset-current (+ start current)))
995 (declare (fixnum offset-current))
996 (if (= offset-current end)
997 (let* ((new-length (* current 2))
998 (new-workspace (make-string new-length)))
999 (declare (simple-string new-workspace))
1000 (%primitive byte-blt workspace start new-workspace 0 current)
1001 (setf workspace new-workspace)
1002 (setf offset-current current)
1003 (set-array-header buffer workspace new-length
1004 current+1 0 new-length nil))
1005 (setf (fill-pointer buffer) current+1))
1006 (setf (schar workspace offset-current) character)))
1007 current+1))
1008
1009
1010 (defun fill-pointer-sout (stream string start end)
1011 (declare (simple-string string) (fixnum start end))
1012 (let* ((buffer (fill-pointer-output-stream-string stream))
1013 (current (fill-pointer buffer))
1014 (string-len (- end start))
1015 (dst-end (+ string-len current)))
1016 (declare (fixnum current dst-end string-len))
1017 (with-array-data ((workspace buffer) (dst-start) (dst-length))
1018 (declare (simple-string workspace))
1019 (let ((offset-dst-end (+ dst-start dst-end))
1020 (offset-current (+ dst-start current)))
1021 (declare (fixnum offset-dst-end offset-current))
1022 (if (> offset-dst-end dst-length)
1023 (let* ((new-length (+ (the fixnum (* current 2)) string-len))
1024 (new-workspace (make-string new-length)))
1025 (declare (simple-string new-workspace))
1026 (%primitive byte-blt workspace dst-start new-workspace 0 current)
1027 (setf workspace new-workspace)
1028 (setf offset-current current)
1029 (setf offset-dst-end dst-end)
1030 (set-array-header buffer workspace new-length
1031 dst-end 0 new-length nil))
1032 (setf (fill-pointer buffer) dst-end))
1033 (%primitive byte-blt string start
1034 workspace offset-current offset-dst-end)))
1035 dst-end))
1036
1037
1038 (defun fill-pointer-misc (stream operation &optional arg1 arg2)
1039 (declare (ignore arg1 arg2))
1040 (case operation
1041 (:charpos
1042 (let* ((buffer (fill-pointer-output-stream-string stream))
1043 (current (fill-pointer buffer)))
1044 (with-array-data ((string buffer) (start) (end current))
1045 (declare (simple-string string) (ignore start))
1046 (let ((found (position #\newline string :test #'char=
1047 :end end :from-end t)))
1048 (if found
1049 (- end (the fixnum found))
1050 current)))))
1051 (:element-type 'string-char)))
1052
1053 ;;;; Indenting streams:
1054
1055 (defstruct (indenting-stream (:include stream
1056 (out #'indenting-out)
1057 (sout #'indenting-sout)
1058 (misc #'indenting-misc))
1059 (:print-function %print-indenting-stream)
1060 (:constructor make-indenting-stream (stream)))
1061 ;; The stream we're based on:
1062 stream
1063 ;; How much we indent on each line:
1064 (indentation 0))
1065
1066 (setf (documentation 'make-indenting-stream 'function)
1067 "Returns an ouput stream which indents its output by some amount.")
1068
1069 (defun %print-indenting-stream (s stream d)
1070 (declare (ignore s d))
1071 (write-string "#<Indenting Stream>" stream))
1072
1073 ;;; Indenting-Indent writes the right number of spaces needed to indent output on
1074 ;;; the given Stream based on the specified Sub-Stream.
1075
1076 (defmacro indenting-indent (stream sub-stream)
1077 `(do ((i 0 (+ i 60))
1078 (indentation (indenting-stream-indentation ,stream)))
1079 ((>= i indentation))
1080 (funcall (stream-sout ,sub-stream) ,sub-stream
1081 " "
1082 0 (min 60 (- indentation i)))))
1083
1084 ;;; Indenting-Out writes a character to an indenting stream.
1085
1086 (defun indenting-out (stream char)
1087 (let ((sub-stream (indenting-stream-stream stream)))
1088 (funcall (stream-out sub-stream) sub-stream char)
1089 (if (char= char #\newline)
1090 (indenting-indent stream sub-stream))))
1091
1092 ;;; Indenting-Sout writes a string to an indenting stream.
1093
1094 (defun indenting-sout (stream string start end)
1095 (declare (simple-string string) (fixnum start end))
1096 (do ((i start)
1097 (sub-stream (indenting-stream-stream stream)))
1098 ((= i end))
1099 (let ((newline (position #\newline string :start i :end end)))
1100 (cond (newline
1101 (funcall (stream-sout sub-stream) sub-stream string i (1+ newline))
1102 (indenting-indent stream sub-stream)
1103 (setq i (+ newline 1)))
1104 (t
1105 (funcall (stream-sout sub-stream) sub-stream string i end)
1106 (setq i end))))))
1107
1108 ;;; Indenting-Misc just treats just the :Line-Length message differently.
1109 ;;; Indenting-Charpos says the charpos is the charpos of the base stream minus
1110 ;;; the stream's indentation.
1111
1112 (defun indenting-misc (stream operation &optional arg1 arg2)
1113 (let* ((sub-stream (indenting-stream-stream stream))
1114 (method (stream-misc sub-stream)))
1115 (case operation
1116 (:line-length
1117 (let ((line-length (funcall method sub-stream operation)))
1118 (if line-length
1119 (- line-length (indenting-stream-indentation stream)))))
1120 (:charpos
1121 (let* ((sub-stream (indenting-stream-stream stream))
1122 (charpos (funcall method sub-stream operation)))
1123 (if charpos
1124 (- charpos (indenting-stream-indentation stream)))))
1125 (t
1126 (funcall method sub-stream operation arg1 arg2)))))
1127
1128 (proclaim '(maybe-inline read-char unread-char read-byte listen))
1129
1130
1131
1132 ;;;; Case frobbing streams, used by format ~(...~).
1133
1134 (in-package "EXT")
1135 (export '(make-case-frob-stream))
1136 (in-package "LISP")
1137
1138 (defstruct (case-frob-stream
1139 (:include stream
1140 (:misc #'case-frob-misc))
1141 (:constructor %make-case-frob-stream (target out sout)))
1142 (target (required-argument) :type stream))
1143
1144 (defun make-case-frob-stream (target kind)
1145 "Returns a stream that sends all output to the stream TARGET, but modifies
1146 the case of letters, depending on KIND, which should be one of:
1147 :upcase - convert to upper case.
1148 :downcase - convert to lower case.
1149 :capitalize - convert the first letter of words to upper case and the
1150 rest of the word to lower case.
1151 :capitalize-first - convert the first letter of the first word to upper
1152 case and everything else to lower case."
1153 (declare (type stream target)
1154 (type (member :upcase :downcase :capitalize :capitalize-first)
1155 kind)
1156 (values stream))
1157 (if (case-frob-stream-p target)
1158 ;; If we are going to be writing to a stream that already does case
1159 ;; frobbing, why bother frobbing the case just so it can frob it
1160 ;; again?
1161 target
1162 (multiple-value-bind
1163 (out sout)
1164 (ecase kind
1165 (:upcase
1166 (values #'case-frob-upcase-out
1167 #'case-frob-upcase-sout))
1168 (:downcase
1169 (values #'case-frob-downcase-out
1170 #'case-frob-downcase-sout))
1171 (:capitalize
1172 (values #'case-frob-capitalize-out
1173 #'case-frob-capitalize-sout))
1174 (:capitalize-first
1175 (values #'case-frob-capitalize-first-out
1176 #'case-frob-capitalize-first-sout)))
1177 (%make-case-frob-stream target out sout))))
1178
1179 (defun case-frob-misc (stream op &optional arg1 arg2)
1180 (declare (type case-frob-stream stream))
1181 (case op
1182 (:close)
1183 (t
1184 (let ((target (case-frob-stream-target stream)))
1185 (funcall (stream-misc target) target op arg1 arg2)))))
1186
1187
1188 (defun case-frob-upcase-out (stream char)
1189 (declare (type case-frob-stream stream)
1190 (type base-character char))
1191 (let ((target (case-frob-stream-target stream)))
1192 (funcall (stream-out target) target (char-upcase char))))
1193
1194 (defun case-frob-upcase-sout (stream str start end)
1195 (declare (type case-frob-stream stream)
1196 (type simple-base-string str)
1197 (type index start)
1198 (type (or index null) end))
1199 (let* ((target (case-frob-stream-target stream))
1200 (len (length str))
1201 (end (or end len)))
1202 (funcall (stream-sout target) target
1203 (if (and (zerop start) (= len end))
1204 (string-upcase str)
1205 (nstring-upcase (subseq str start end)))
1206 0
1207 (- end start))))
1208
1209 (defun case-frob-downcase-out (stream char)
1210 (declare (type case-frob-stream stream)
1211 (type base-character char))
1212 (let ((target (case-frob-stream-target stream)))
1213 (funcall (stream-out target) target (char-downcase char))))
1214
1215 (defun case-frob-downcase-sout (stream str start end)
1216 (declare (type case-frob-stream stream)
1217 (type simple-base-string str)
1218 (type index start)
1219 (type (or index null) end))
1220 (let* ((target (case-frob-stream-target stream))
1221 (len (length str))
1222 (end (or end len)))
1223 (funcall (stream-sout target) target
1224 (if (and (zerop start) (= len end))
1225 (string-downcase str)
1226 (nstring-downcase (subseq str start end)))
1227 0
1228 (- end start))))
1229
1230 (defun case-frob-capitalize-out (stream char)
1231 (declare (type case-frob-stream stream)
1232 (type base-character char))
1233 (let ((target (case-frob-stream-target stream)))
1234 (cond ((alphanumericp char)
1235 (funcall (stream-out target) target (char-upcase char))
1236 (setf (case-frob-stream-out stream)
1237 #'case-frob-capitalize-aux-out)
1238 (setf (case-frob-stream-sout stream)
1239 #'case-frob-capitalize-aux-sout))
1240 (t
1241 (funcall (stream-out target) target char)))))
1242
1243 (defun case-frob-capitalize-sout (stream str start end)
1244 (declare (type case-frob-stream stream)
1245 (type simple-base-string str)
1246 (type index start)
1247 (type (or index null) end))
1248 (let* ((target (case-frob-stream-target stream))
1249 (str (subseq str start end))
1250 (len (length str))
1251 (inside-word nil))
1252 (dotimes (i len)
1253 (let ((char (schar str i)))
1254 (cond ((not (alphanumericp char))
1255 (setf inside-word nil))
1256 (inside-word
1257 (setf (schar str i) (char-downcase char)))
1258 (t
1259 (setf inside-word t)
1260 (setf (schar str i) (char-upcase char))))))
1261 (when inside-word
1262 (setf (case-frob-stream-out stream)
1263 #'case-frob-capitalize-aux-out)
1264 (setf (case-frob-stream-sout stream)
1265 #'case-frob-capitalize-aux-sout))
1266 (funcall (stream-sout target) target str 0 len)))
1267
1268 (defun case-frob-capitalize-aux-out (stream char)
1269 (declare (type case-frob-stream stream)
1270 (type base-character char))
1271 (let ((target (case-frob-stream-target stream)))
1272 (cond ((alphanumericp char)
1273 (funcall (stream-out target) target (char-downcase char)))
1274 (t
1275 (funcall (stream-out target) target char)
1276 (setf (case-frob-stream-out stream)
1277 #'case-frob-capitalize-out)
1278 (setf (case-frob-stream-sout stream)
1279 #'case-frob-capitalize-sout)))))
1280
1281 (defun case-frob-capitalize-aux-sout (stream str start end)
1282 (declare (type case-frob-stream stream)
1283 (type simple-base-string str)
1284 (type index start)
1285 (type (or index null) end))
1286 (let* ((target (case-frob-stream-target stream))
1287 (str (subseq str start end))
1288 (len (length str))
1289 (inside-word t))
1290 (dotimes (i len)
1291 (let ((char (schar str i)))
1292 (cond ((not (alphanumericp char))
1293 (setf inside-word nil))
1294 (inside-word
1295 (setf (schar str i) (char-downcase char)))
1296 (t
1297 (setf inside-word t)
1298 (setf (schar str i) (char-upcase char))))))
1299 (unless inside-word
1300 (setf (case-frob-stream-out stream)
1301 #'case-frob-capitalize-out)
1302 (setf (case-frob-stream-sout stream)
1303 #'case-frob-capitalize-sout))
1304 (funcall (stream-sout target) target str 0 len)))
1305
1306 (defun case-frob-capitalize-first-out (stream char)
1307 (declare (type case-frob-stream stream)
1308 (type base-character char))
1309 (let ((target (case-frob-stream-target stream)))
1310 (cond ((alphanumericp char)
1311 (funcall (stream-out target) target (char-upcase char))
1312 (setf (case-frob-stream-out stream)
1313 #'case-frob-downcase-out)
1314 (setf (case-frob-stream-sout stream)
1315 #'case-frob-downcase-sout))
1316 (t
1317 (funcall (stream-out target) target char)))))
1318
1319 (defun case-frob-capitalize-first-sout (stream str start end)
1320 (declare (type case-frob-stream stream)
1321 (type simple-base-string str)
1322 (type index start)
1323 (type (or index null) end))
1324 (let* ((target (case-frob-stream-target stream))
1325 (str (subseq str start end))
1326 (len (length str)))
1327 (dotimes (i len)
1328 (let ((char (schar str i)))
1329 (when (alphanumericp char)
1330 (setf (schar str i) (char-upcase char))
1331 (do ((i (1+ i) (1+ i)))
1332 ((= i len))
1333 (setf (schar str i) (char-downcase (schar str i))))
1334 (setf (case-frob-stream-out stream)
1335 #'case-frob-downcase-out)
1336 (setf (case-frob-stream-sout stream)
1337 #'case-frob-downcase-sout)
1338 (return))))
1339 (funcall (stream-sout target) target str 0 len)))
1340
1341
1342
1343 ;;;; Public interface from "EXTENSIONS" package.
1344
1345 (in-package "EXT")
1346
1347 (export '(get-stream-command stream-command stream-command-p stream-command-name
1348 stream-command-args make-stream-command))
1349
1350 (defstruct (stream-command (:print-function print-stream-command)
1351 (:constructor make-stream-command
1352 (name &optional args)))
1353 (name nil :type symbol)
1354 (args nil :type list))
1355
1356 (defun print-stream-command (obj str n)
1357 (declare (ignore n))
1358 (format str "#<Stream-Cmd ~S>" (stream-command-name obj)))
1359
1360
1361 ;;; GET-STREAM-COMMAND -- Public.
1362 ;;;
1363 ;;; We can't simply call the stream's misc method because because nil is an
1364 ;;; ambiguous return value: does it mean text arrived, or does it mean the
1365 ;;; stream's misc method had no :get-command implementation. We can't return
1366 ;;; nil until there is text input. We don't need to loop because any stream
1367 ;;; implementing :get-command would wait until it had some input. If the
1368 ;;; LISTEN fails, then we have some random stream we must wait on.
1369 ;;;
1370 (defun get-stream-command (stream)
1371 "This takes a stream and waits for text or a command to appear on it. If
1372 text appears before a command, this returns nil, and otherwise it returns
1373 a command."
1374 (let ((cmdp (funcall (lisp::stream-misc stream) stream :get-command)))
1375 (cond (cmdp)
1376 ((listen stream)
1377 nil)
1378 (t
1379 ;; This waits for input and returns nil when it arrives.
1380 (unread-char (read-char stream) stream)))))

  ViewVC Help
Powered by ViewVC 1.1.5