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

Contents of /src/code/stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5