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

Contents of /src/code/stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17.1.2 - (hide annotations) (vendor branch)
Tue Feb 23 23:27:49 1993 UTC (21 years, 2 months ago) by ram
Branch: new_struct
Changes since 1.17.1.1: +16 -11 lines
Fixes to in-buffer/fast-read-char stuff.
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.17.1.2 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/stream.lisp,v 1.17.1.2 1993/02/23 23:27:49 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.17.1.1 (in-package "SYSTEM")
41 ram 1.1 (export '(make-indenting-stream read-n-bytes))
42    
43 ram 1.17.1.1 (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.17.1.1 ;;; :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.17.1.1
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.17.1.1
219 ram 1.1
220 ram 1.17.1.1 ;;;; 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     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) (type (or index null) position))
232     (cond
233     (position
234     (setf (stream-in-index stream) in-buffer-length)
235     (funcall (stream-misc stream) stream :file-position position))
236     (t
237     (let ((res (funcall (stream-misc stream) stream :file-position nil)))
238     (when res (+ res (- in-buffer-length (stream-in-index stream))))))))
239    
240    
241     ;;; File-Length -- Public
242     ;;;
243     ;;; Like File-Position, only use :file-length.
244     ;;;
245     (defun file-length (stream)
246     "This function returns the length of the file that File-Stream is open to."
247     (declare (stream stream))
248     (funcall (stream-misc stream) stream :file-length))
249    
250    
251 ram 1.1 ;;; Input functions:
252    
253     (defun read-line (&optional (stream *standard-input*) (eof-errorp t) eof-value
254     recursive-p)
255     "Returns a line of text read from the Stream as a string, discarding the
256     newline character."
257     (declare (ignore recursive-p))
258 ram 1.17.1.1 (prepare-for-fast-read-char stream
259     (let ((res (make-string 80))
260     (len 80)
261     (index 0))
262     (loop
263     (let ((ch (fast-read-char nil nil)))
264     (cond (ch
265     (when (char= ch #\newline)
266 ram 1.17.1.2 (done-with-fast-read-char)
267 ram 1.17.1.1 (return (values (shrink-vector res index) nil)))
268     (when (= index len)
269     (setq len (* len 2))
270     (let ((new (make-string len)))
271     (replace new res)
272     (setq res new)))
273     (setf (schar res index) ch)
274     (incf index))
275     ((zerop index)
276     (done-with-fast-read-char)
277     (return (funcall (stream-in stream) stream
278     eof-errorp eof-value)))
279     (t
280     (done-with-fast-read-char)
281     (return (values (shrink-vector res index) t)))))))))
282 ram 1.1
283 ram 1.10
284 ram 1.1 ;;; We proclaim them inline here, then proclaim them notinline at EOF,
285     ;;; so, except in this file, they are not inline by default, but they can be.
286     ;;;
287     (proclaim '(inline read-char unread-char read-byte listen))
288     (defun read-char (&optional (stream *standard-input*) (eof-errorp t) eof-value
289     recursive-p)
290     "Inputs a character from Stream and returns it."
291     (declare (ignore recursive-p))
292 ram 1.17.1.1 (prepare-for-fast-read-char stream
293     (prog1
294     (fast-read-char eof-errorp eof-value)
295     (done-with-fast-read-char))))
296 ram 1.1
297     (defun unread-char (character &optional (stream *standard-input*))
298     "Puts the Character back on the front of the input Stream."
299     (let* ((stream (in-synonym-of stream))
300 ram 1.17.1.1 (index (1- (stream-in-index stream)))
301 ram 1.1 (buffer (stream-in-buffer stream)))
302     (declare (fixnum index))
303     (when (minusp index) (error "Nothing to unread."))
304 ram 1.17.1.1 (cond (buffer
305     (setf (aref buffer index) (char-code character))
306     (setf (stream-in-index stream) index))
307     (t
308     (funcall (stream-misc stream) stream :unread character))))
309 ram 1.1 nil)
310    
311     (defun peek-char (&optional (peek-type nil) (stream *standard-input*)
312     (eof-errorp t) eof-value recursive-p)
313     "Peeks at the next character in the input Stream. See manual for details."
314     (declare (ignore recursive-p))
315     (let* ((stream (in-synonym-of stream))
316     (char (read-char stream eof-errorp eof-value)))
317     (cond ((eq char eof-value) char)
318     ((characterp peek-type)
319     (do ((char char (read-char stream eof-errorp eof-value)))
320     ((or (eq char eof-value) (char= char peek-type))
321     (unless (eq char eof-value)
322     (unread-char char stream))
323     char)))
324     ((eq peek-type t)
325     (do ((char char (read-char stream eof-errorp eof-value)))
326     ((or (eq char eof-value) (not (whitespace-char-p char)))
327     (unless (eq char eof-value)
328     (unread-char char stream))
329     char)))
330     (t
331     (unread-char char stream)
332     char))))
333    
334     (defun listen (&optional (stream *standard-input*))
335     "Returns T if a character is availible on the given Stream."
336     (let ((stream (in-synonym-of stream)))
337     (or (/= (the fixnum (stream-in-index stream)) in-buffer-length)
338 ram 1.10 ;; Test for t explicitly since misc methods return :eof sometimes.
339     (eq (funcall (stream-misc stream) stream :listen) t))))
340 ram 1.1
341     (defun read-char-no-hang (&optional (stream *standard-input*)
342     (eof-errorp t) eof-value recursive-p)
343     "Returns the next character from the Stream if one is availible, or nil."
344     (declare (ignore recursive-p))
345 ram 1.10 (let ((stream (in-synonym-of stream)))
346     (if (funcall (stream-misc stream) stream :listen)
347     ;; On t or :eof get READ-CHAR to do the work.
348     (read-char stream eof-errorp eof-value)
349     nil)))
350 ram 1.1
351     (defun clear-input (&optional (stream *standard-input*))
352     "Clears any buffered input associated with the Stream."
353     (let ((stream (in-synonym-of stream)))
354     (setf (stream-in-index stream) in-buffer-length)
355 ram 1.2 (funcall (stream-misc stream) stream :clear-input)
356     nil))
357 ram 1.1
358     (defun read-byte (stream &optional (eof-errorp t) eof-value)
359     "Returns the next byte of the Stream."
360 ram 1.17.1.1 (prepare-for-fast-read-byte stream
361     (prog1
362     (fast-read-byte eof-errorp eof-value)
363     (done-with-fast-read-byte))))
364 ram 1.1
365     (defun read-n-bytes (stream buffer start numbytes &optional (eof-errorp t))
366     "Reads Numbytes bytes into the Buffer starting at Start, and returns
367 ram 1.17.1.1 the number of bytes actually read if the end of file was hit before Numbytes
368     bytes were read (and Eof-Errorp is false)."
369     (declare (type index numbytes start)
370 ram 1.17.1.2 (type (or (simple-array * (*)) system-area-pointer) buffer))
371 ram 1.1 (let* ((stream (in-synonym-of stream))
372     (in-buffer (stream-in-buffer stream))
373     (index (stream-in-index stream))
374     (num-buffered (- in-buffer-length index)))
375     (declare (fixnum index num-buffered))
376     (cond
377 ram 1.2 ((not in-buffer)
378 ram 1.17.1.1 (funcall (stream-n-bin stream) stream buffer start numbytes eof-errorp))
379 ram 1.1 ((<= numbytes num-buffered)
380     (%primitive byte-blt in-buffer index buffer start (+ start numbytes))
381     (setf (stream-in-index stream) (+ index numbytes))
382     numbytes)
383     (t
384     (let ((end (+ start num-buffered)))
385     (%primitive byte-blt in-buffer index buffer start end)
386     (setf (stream-in-index stream) in-buffer-length)
387 ram 1.17.1.1 (+ (funcall (stream-n-bin stream) stream buffer end
388     (- numbytes num-buffered)
389     eof-errorp)
390 ram 1.1 num-buffered))))))
391 ram 1.17.1.1
392    
393     ;;; Amount of space we leave at the start of the in-buffer for unreading. 4
394     ;;; instead of 1 to allow word-aligned copies.
395     ;;;
396     (defconstant in-buffer-extra 4)
397    
398     ;;; FAST-READ-CHAR-REFILL -- Interface
399     ;;;
400     ;;; This function is called by the fast-read-char expansion to refill the
401     ;;; in-buffer for text streams. There is definitely an in-buffer, and hence
402     ;;; myst be an n-bin method.
403     ;;;
404     (defun fast-read-char-refill (stream eof-errorp eof-value)
405     (let* ((ibuf (stream-in-buffer stream))
406     (count (funcall (stream-n-bin stream) stream
407     ibuf in-buffer-extra
408     (- in-buffer-length in-buffer-extra)
409     nil))
410     (start (- in-buffer-length count)))
411     (declare (type index start count))
412     (cond ((zerop count)
413     (funcall (stream-in stream) stream eof-errorp eof-value))
414     (t
415     (when (/= start in-buffer-extra)
416 ram 1.17.1.2 (bit-bash-copy ibuf (+ (* in-buffer-extra vm:byte-bits)
417     (* vm:vector-data-offset vm:word-bits))
418     ibuf (+ (the index (* start vm:byte-bits))
419     (* vm:vector-data-offset vm:word-bits))
420     (* count vm:byte-bits)))
421     (setf (stream-in-index stream) (1+ start))
422     (code-char (aref ibuf start))))))
423 ram 1.17.1.1
424    
425     ;;; FAST-READ-BYTE-REFILL -- Interface
426     ;;;
427     ;;; Similar to FAST-READ-CHAR-REFILL, but we don't have to leave room for
428     ;;; unreading.
429     ;;;
430     (defun fast-read-byte-refill (stream eof-errorp eof-value)
431     (let* ((ibuf (stream-in-buffer stream))
432     (count (funcall (stream-n-bin stream) stream
433     ibuf 0 in-buffer-length
434     nil))
435     (start (- in-buffer-length count)))
436     (declare (type index start count))
437     (cond ((zerop count)
438     (funcall (stream-bin stream) stream eof-errorp eof-value))
439     (t
440     (unless (zerop start)
441 ram 1.17.1.2 (bit-bash-copy ibuf (* vm:vector-data-offset vm:word-bits)
442     ibuf (+ (the index (* start vm:byte-bits))
443     (* vm:vector-data-offset vm:word-bits))
444     (* count vm:byte-bits)))
445     (setf (stream-in-index stream) (1+ start))
446     (aref ibuf start)))))
447 ram 1.17.1.1
448 ram 1.1
449     ;;; Output functions:
450    
451     (defun write-char (character &optional (stream *standard-output*))
452     "Outputs the Character to the Stream."
453     (with-out-stream stream stream-out character)
454     character)
455    
456     (defun terpri (&optional (stream *standard-output*))
457     "Outputs a new line to the Stream."
458     (with-out-stream stream stream-out #\newline)
459     nil)
460    
461     (defun fresh-line (&optional (stream *standard-output*))
462     "Outputs a new line to the Stream if it is not positioned at the begining of
463     a line. Returns T if it output a new line, nil otherwise."
464     (let ((stream (out-synonym-of stream)))
465     (when (/= (or (charpos stream) 1) 0)
466     (funcall (stream-out stream) stream #\newline)
467     t)))
468    
469     (defun write-string (string &optional (stream *standard-output*)
470     &key (start 0) (end (length (the vector string))))
471     "Outputs the String to the given Stream."
472     (write-string* string stream start end))
473    
474     (defun write-string* (string &optional (stream *standard-output*)
475     (start 0) (end (length (the vector string))))
476     (declare (fixnum start end))
477     (if (array-header-p string)
478     (with-array-data ((data string) (offset-start start) (offset-end end))
479     (with-out-stream stream stream-sout data offset-start offset-end))
480     (with-out-stream stream stream-sout string start end))
481     string)
482    
483     (defun write-line (string &optional (stream *standard-output*)
484     &key (start 0) (end (length string)))
485     "Outputs the String to the given Stream, followed by a newline character."
486     (write-line* string stream start end))
487    
488     (defun write-line* (string &optional (stream *standard-output*)
489     (start 0) (end (length string)))
490     (declare (fixnum start end))
491     (let ((stream (out-synonym-of stream)))
492     (if (array-header-p string)
493     (with-array-data ((data string) (offset-start start) (offset-end end))
494     (with-out-stream stream stream-sout data offset-start offset-end))
495     (with-out-stream stream stream-sout string start end))
496     (funcall (stream-out stream) stream #\newline))
497     string)
498    
499     (defun charpos (&optional (stream *standard-output*))
500     "Returns the number of characters on the current line of output of the given
501     Stream, or Nil if that information is not availible."
502     (with-out-stream stream stream-misc :charpos))
503    
504     (defun line-length (&optional (stream *standard-output*))
505     "Returns the number of characters that will fit on a line of output on the
506     given Stream, or Nil if that information is not available."
507     (with-out-stream stream stream-misc :line-length))
508    
509     (defun finish-output (&optional (stream *standard-output*))
510     "Attempts to ensure that all output sent to the the Stream has reached its
511     destination, and only then returns."
512     (with-out-stream stream stream-misc :finish-output)
513     nil)
514    
515     (defun force-output (&optional (stream *standard-output*))
516     "Attempts to force any buffered output to be sent."
517     (with-out-stream stream stream-misc :force-output)
518     nil)
519    
520     (defun clear-output (&optional (stream *standard-output*))
521     "Clears the given output Stream."
522     (with-out-stream stream stream-misc :clear-output)
523     nil)
524    
525     (defun write-byte (integer stream)
526     "Outputs the Integer to the binary Stream."
527     (with-out-stream stream stream-bout integer)
528     integer)
529    
530     ;;;; Broadcast streams:
531    
532     (defstruct (broadcast-stream (:include stream
533     (out #'broadcast-out)
534     (bout #'broadcast-bout)
535     (sout #'broadcast-sout)
536     (misc #'broadcast-misc))
537     (:print-function %print-broadcast-stream)
538     (:constructor make-broadcast-stream (&rest streams)))
539     ;; This is a list of all the streams we broadcast to.
540 ram 1.14 (streams () :type list :read-only t))
541 ram 1.1
542     (setf (documentation 'make-broadcast-stream 'function)
543     "Returns an ouput stream which sends its output to all of the given streams.")
544    
545     (defun %print-broadcast-stream (s stream d)
546     (declare (ignore s d))
547     (write-string "#<Broadcast Stream>" stream))
548    
549     (macrolet ((out-fun (fun method &rest args)
550     `(defun ,fun (stream ,@args)
551     (dolist (stream (broadcast-stream-streams stream))
552     (funcall (,method stream) stream ,@args)))))
553     (out-fun broadcast-out stream-out char)
554     (out-fun broadcast-bout stream-bout byte)
555     (out-fun broadcast-sout stream-sout string start end))
556    
557     (defun broadcast-misc (stream operation &optional arg1 arg2)
558     (let ((streams (broadcast-stream-streams stream)))
559     (case operation
560     (:charpos
561     (dolist (stream streams)
562     (let ((charpos (funcall (stream-misc stream) stream :charpos)))
563     (if charpos (return charpos)))))
564     (:line-length
565     (let ((min nil))
566     (dolist (stream streams min)
567     (let ((res (funcall (stream-misc stream) stream :line-length)))
568     (when res (setq min (if min (min res min) res)))))))
569     (:element-type
570     (let (res)
571     (dolist (stream streams (if (> (length res) 1) `(and ,@res) res))
572     (pushnew (funcall (stream-misc stream) stream :element-type) res
573     :test #'equal))))
574     (t
575     (let ((res nil))
576     (dolist (stream streams res)
577     (setq res (funcall (stream-misc stream) stream operation
578     arg1 arg2))))))))
579    
580     ;;;; Synonym Streams:
581    
582     (defstruct (synonym-stream (:include stream
583     (in #'synonym-in)
584     (bin #'synonym-bin)
585     (n-bin #'synonym-n-bin)
586     (out #'synonym-out)
587     (bout #'synonym-bout)
588     (sout #'synonym-sout)
589     (misc #'synonym-misc))
590     (:print-function %print-synonym-stream)
591     (:constructor make-synonym-stream (symbol)))
592     ;; This is the symbol, the value of which is the stream we are synonym to.
593 wlott 1.15 (symbol nil :type symbol :read-only t))
594 ram 1.1
595     (defun %print-synonym-stream (s stream d)
596     (declare (ignore d))
597     (format stream "#<Synonym Stream to ~S>" (synonym-stream-symbol s)))
598    
599     (setf (documentation 'make-synonym-stream 'function)
600     "Returns a stream which performs its operations on the stream which is the
601     value of the dynamic variable named by Symbol.")
602    
603     ;;; The output simple output methods just call the corresponding method
604     ;;; in the synonymed stream.
605     ;;;
606     (macrolet ((out-fun (name slot &rest args)
607     `(defun ,name (stream ,@args)
608 ram 1.11 (declare (optimize (safety 1)))
609 ram 1.1 (let ((syn (symbol-value (synonym-stream-symbol stream))))
610     (funcall (,slot syn) syn ,@args)))))
611     (out-fun synonym-out stream-out ch)
612     (out-fun synonym-bout stream-bout n)
613     (out-fun synonym-sout stream-sout string start end))
614    
615    
616     ;;; Bind synonym stream to this so that SPIO can turn on the right frob in
617     ;;; the icon when we are in a terminal input wait.
618     ;;;
619     (defvar *previous-stream* nil)
620    
621     ;;; For the input methods, we just call the corresponding function on the
622     ;;; synonymed stream. These functions deal with getting input out of
623     ;;; the In-Buffer if there is any.
624     ;;;
625     (macrolet ((in-fun (name fun &rest args)
626     `(defun ,name (stream ,@args)
627 ram 1.11 (declare (optimize (safety 1)))
628 ram 1.1 (let ((*previous-stream* stream))
629     (,fun (symbol-value (synonym-stream-symbol stream)) ,@args)))))
630     (in-fun synonym-in read-char eof-errorp eof-value)
631     (in-fun synonym-bin read-byte eof-errorp eof-value)
632     (in-fun synonym-n-bin read-n-bytes buffer start numbytes eof-errorp))
633    
634    
635     ;;; Synonym-Misc -- Internal
636     ;;;
637     ;;; We have to special-case the operations which could look at stuff in
638     ;;; the in-buffer.
639     ;;;
640     (defun synonym-misc (stream operation &optional arg1 arg2)
641 ram 1.11 (declare (optimize (safety 1)))
642 ram 1.1 (let ((syn (symbol-value (synonym-stream-symbol stream)))
643     (*previous-stream* stream))
644     (case operation
645     (:listen (or (/= (the fixnum (stream-in-index syn)) in-buffer-length)
646     (funcall (stream-misc syn) syn :listen)))
647     (t
648     (funcall (stream-misc syn) syn operation arg1 arg2)))))
649    
650     ;;;; Two-Way streams:
651    
652     (defstruct (two-way-stream
653     (:include stream
654     (in #'two-way-in)
655     (bin #'two-way-bin)
656     (n-bin #'two-way-n-bin)
657     (out #'two-way-out)
658     (bout #'two-way-bout)
659     (sout #'two-way-sout)
660     (misc #'two-way-misc))
661     (:print-function %print-two-way-stream)
662     (:constructor make-two-way-stream (input-stream output-stream)))
663     ;; We read from this stream...
664 ram 1.14 (input-stream (required-argument) :type stream :read-only t)
665 ram 1.1 ;; And write to this one
666 ram 1.14 (output-stream (required-argument) :type stream :read-only t))
667 ram 1.1
668     (defun %print-two-way-stream (s stream d)
669     (declare (ignore d))
670     (format stream "#<Two-Way Stream, Input = ~S, Output = ~S>"
671     (two-way-stream-input-stream s)
672     (two-way-stream-output-stream s)))
673    
674     (setf (documentation 'make-two-way-stream 'function)
675     "Returns a bidirectional stream which gets its input from Input-Stream and
676     sends its output to Output-Stream.")
677    
678     (macrolet ((out-fun (name slot &rest args)
679     `(defun ,name (stream ,@args)
680     (let ((syn (two-way-stream-output-stream stream)))
681     (funcall (,slot syn) syn ,@args)))))
682     (out-fun two-way-out stream-out ch)
683     (out-fun two-way-bout stream-bout n)
684     (out-fun two-way-sout stream-sout string start end))
685    
686     (macrolet ((in-fun (name fun &rest args)
687     `(defun ,name (stream ,@args)
688 ram 1.10 (force-output (two-way-stream-output-stream stream))
689 ram 1.1 (,fun (two-way-stream-input-stream stream) ,@args))))
690     (in-fun two-way-in read-char eof-errorp eof-value)
691     (in-fun two-way-bin read-byte eof-errorp eof-value)
692     (in-fun two-way-n-bin read-n-bytes buffer start numbytes eof-errorp))
693    
694     (defun two-way-misc (stream operation &optional arg1 arg2)
695     (let* ((in (two-way-stream-input-stream stream))
696     (in-method (stream-misc in))
697     (out (two-way-stream-output-stream stream))
698     (out-method (stream-misc out)))
699     (case operation
700     (:listen (or (/= (the fixnum (stream-in-index in)) in-buffer-length)
701     (funcall in-method in :listen)))
702     ((:finish-output :force-output :clear-output)
703     (funcall out-method out operation arg1 arg2))
704     ((:clear-input :unread)
705     (funcall in-method in operation arg1 arg2))
706     (:element-type
707     (let ((in-type (funcall in-method in :element-type))
708     (out-type (funcall out-method out :element-type)))
709     (if (equal in-type out-type)
710     in-type `(and ,in-type ,out-type))))
711     (:close
712     (funcall in-method in :close arg1)
713     (funcall out-method out :close arg1)
714     (set-closed-flame stream))
715     (t
716     (or (funcall in-method in operation arg1 arg2)
717     (funcall out-method out operation arg1 arg2))))))
718    
719     ;;;; Concatenated Streams:
720    
721     (defstruct (concatenated-stream
722     (:include stream
723     (in #'concatenated-in)
724     (bin #'concatenated-bin)
725     (misc #'concatenated-misc))
726     (:print-function %print-concatenated-stream)
727     (:constructor
728     make-concatenated-stream (&rest streams &aux (current streams))))
729     ;; The car of this is the stream we are reading from now.
730     current
731     ;; This is a list of all the streams. We need to remember them so that
732     ;; we can close them.
733 ram 1.14 (streams nil :type list :read-only t))
734 ram 1.1
735     (defun %print-concatenated-stream (s stream d)
736     (declare (ignore d))
737     (format stream "#<Concatenated Stream, Streams = ~S>"
738     (concatenated-stream-streams s)))
739    
740     (setf (documentation 'make-concatenated-stream 'function)
741     "Returns a stream which takes its input from each of the Streams in turn,
742     going on to the next at EOF.")
743    
744     (macrolet ((in-fun (name fun)
745     `(defun ,name (stream eof-errorp eof-value)
746     (do ((current (concatenated-stream-current stream) (cdr current)))
747     ((null current)
748     (eof-or-lose stream eof-errorp eof-value))
749     (let* ((stream (car current))
750     (result (,fun stream nil nil)))
751     (when result (return result)))
752     (setf (concatenated-stream-current stream) current)))))
753     (in-fun concatenated-in read-char)
754     (in-fun concatenated-bin read-byte))
755    
756     (defun concatenated-misc (stream operation &optional arg1 arg2)
757 ram 1.17.1.1 (let ((left (concatenated-stream-current stream)))
758     (when left
759     (let* ((current (car left))
760     (misc (stream-misc current)))
761     (case operation
762     (:listen
763     (loop
764     (let ((stuff (funcall misc current :listen)))
765     (cond ((eq stuff :eof)
766     ;; Advance current, and try again.
767     (pop (concatenated-stream-current stream))
768     (setf current
769     (car (concatenated-stream-current stream)))
770     (unless current
771     ;; No further streams. EOF.
772     (return :eof))
773     (setf misc (stream-misc current)))
774     (stuff
775     ;; Stuff's available.
776     (return t))
777     (t
778     ;; Nothing available yet.
779     (return nil))))))
780     (:close
781     (dolist (stream (concatenated-stream-streams stream))
782     (funcall (stream-misc stream) stream :close arg1))
783     (set-closed-flame stream))
784     (t
785     (funcall misc current operation arg1 arg2)))))))
786 ram 1.1
787     ;;;; Echo Streams:
788    
789     (defstruct (echo-stream
790     (:include two-way-stream
791     (in #'echo-in)
792     (bin #'echo-bin)
793     (misc #'echo-misc)
794     (n-bin #'ill-bin))
795     (:print-function %print-echo-stream)
796 wlott 1.8 (:constructor make-echo-stream (input-stream output-stream)))
797     unread-stuff)
798 ram 1.1
799    
800     (macrolet ((in-fun (name fun out-slot &rest args)
801     `(defun ,name (stream ,@args)
802 wlott 1.8 (or (pop (echo-stream-unread-stuff stream))
803     (let* ((in (echo-stream-input-stream stream))
804     (out (echo-stream-output-stream stream))
805     (result (,fun in ,@args)))
806     (funcall (,out-slot out) out result)
807     result)))))
808 ram 1.1 (in-fun echo-in read-char stream-out eof-errorp eof-value)
809     (in-fun echo-bin read-byte stream-bout eof-errorp eof-value))
810    
811     (defun echo-misc (stream operation &optional arg1 arg2)
812     (let* ((in (two-way-stream-input-stream stream))
813     (in-method (stream-misc in))
814     (out (two-way-stream-output-stream stream))
815     (out-method (stream-misc out)))
816     (case operation
817 wlott 1.8 (:listen (or (not (null (echo-stream-unread-stuff stream)))
818     (/= (the fixnum (stream-in-index in)) in-buffer-length)
819 ram 1.1 (funcall in-method in :listen)))
820 wlott 1.8 (:unread (push arg1 (echo-stream-unread-stuff stream)))
821 ram 1.1 (:element-type
822     (let ((in-type (funcall in-method in :element-type))
823     (out-type (funcall out-method out :element-type)))
824     (if (equal in-type out-type)
825     in-type `(and ,in-type ,out-type))))
826     (:close
827     (funcall in-method in :close arg1)
828     (funcall out-method out :close arg1)
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     (:include stream
849     (in #'string-inch)
850     (misc #'string-in-misc))
851     (:print-function %print-string-input-stream)
852 ram 1.10 ;(:constructor nil)
853 ram 1.1 (:constructor internal-make-string-input-stream
854     (string current end)))
855     (string nil :type simple-string)
856     (current nil :type fixnum)
857     (end nil :type fixnum))
858    
859     (defun %print-string-input-stream (s stream d)
860     (declare (ignore s d))
861     (write-string "#<String-Input Stream>" stream))
862    
863     (defun string-inch (stream eof-errorp eof-value)
864     (let ((string (string-input-stream-string stream))
865     (index (string-input-stream-current stream)))
866     (declare (simple-string string) (fixnum index))
867     (cond ((= index (the fixnum (string-input-stream-end stream)))
868     (eof-or-lose stream eof-errorp eof-value))
869     (t
870     (setf (string-input-stream-current stream) (1+ index))
871     (aref string index)))))
872    
873     (defun string-in-misc (stream operation &optional arg1 arg2)
874 ram 1.17.1.1 (declare (ignore arg2))
875 ram 1.1 (case operation
876 ram 1.2 (:file-position
877 ram 1.5 (if arg1
878     (setf (string-input-stream-current stream) arg1)
879     (string-input-stream-current stream)))
880     (:file-length (length (string-input-stream-string stream)))
881 ram 1.1 (:unread (decf (string-input-stream-current stream)))
882 ram 1.10 (:listen (or (/= (the fixnum (string-input-stream-current stream))
883     (the fixnum (string-input-stream-end stream)))
884     :eof))
885 ram 1.1 (:element-type 'string-char)))
886    
887     (defun make-string-input-stream (string &optional
888     (start 0) (end (length string)))
889     "Returns an input stream which will supply the characters of String between
890     Start and End in order."
891 wlott 1.17 (declare (type string string)
892     (type index start)
893 ram 1.17.1.1 (type (or index null) end))
894 wlott 1.17 (internal-make-string-input-stream (coerce string 'simple-string)
895     start end))
896 ram 1.1
897     ;;;; String Output Streams:
898    
899     (defstruct (string-output-stream
900     (:include stream
901     (out #'string-ouch)
902     (sout #'string-sout)
903     (misc #'string-out-misc))
904     (:print-function %print-string-output-stream)
905     (:constructor make-string-output-stream ()))
906     ;; The string we throw stuff in.
907     (string (make-string 40) :type simple-string)
908     ;; Index of the next location to use.
909     (index 0 :type fixnum))
910    
911     (defun %print-string-output-stream (s stream d)
912     (declare (ignore s d))
913     (write-string "#<String-Output Stream>" stream))
914    
915     (setf (documentation 'make-string-output-stream 'function)
916     "Returns an Output stream which will accumulate all output given it for
917     the benefit of the function Get-Output-Stream-String.")
918    
919     (defun string-ouch (stream character)
920     (let ((current (string-output-stream-index stream))
921     (workspace (string-output-stream-string stream)))
922     (declare (simple-string workspace) (fixnum current))
923     (if (= current (the fixnum (length workspace)))
924     (let ((new-workspace (make-string (* current 2))))
925 wlott 1.17 (replace new-workspace workspace)
926 ram 1.1 (setf (aref new-workspace current) character)
927     (setf (string-output-stream-string stream) new-workspace))
928     (setf (aref workspace current) character))
929     (setf (string-output-stream-index stream) (1+ current))))
930    
931     (defun string-sout (stream string start end)
932     (declare (simple-string string) (fixnum start end))
933     (let* ((current (string-output-stream-index stream))
934     (length (- end start))
935     (dst-end (+ length current))
936     (workspace (string-output-stream-string stream)))
937     (declare (simple-string workspace)
938     (fixnum current length dst-end))
939     (if (> dst-end (the fixnum (length workspace)))
940     (let ((new-workspace (make-string (+ (* current 2) length))))
941 wlott 1.17 (replace new-workspace workspace :end2 current)
942     (replace new-workspace string
943     :start1 current :end1 dst-end
944     :start2 start :end2 end)
945 ram 1.1 (setf (string-output-stream-string stream) new-workspace))
946 wlott 1.17 (replace workspace string
947     :start1 current :end1 dst-end
948     :start2 start :end2 end))
949 ram 1.1 (setf (string-output-stream-index stream) dst-end)))
950    
951     (defun string-out-misc (stream operation &optional arg1 arg2)
952 ram 1.3 (declare (ignore arg2))
953 ram 1.1 (case operation
954 ram 1.2 (:file-position
955     (if (null arg1)
956 ram 1.3 (string-output-stream-index stream)))
957 ram 1.1 (:charpos
958     (do ((index (1- (the fixnum (string-output-stream-index stream)))
959     (1- index))
960     (count 0 (1+ count))
961     (string (string-output-stream-string stream)))
962     ((< index 0) count)
963     (declare (simple-string string)
964     (fixnum index count))
965     (if (char= (schar string index) #\newline)
966     (return count))))
967     (:element-type 'string-char)))
968    
969     (defun get-output-stream-string (stream)
970     "Returns a string of all the characters sent to a stream made by
971     Make-String-Output-Stream since the last call to this function."
972 wlott 1.17 (declare (type string-output-stream stream))
973     (let* ((length (string-output-stream-index stream))
974     (result (make-string length)))
975     (replace result (string-output-stream-string stream))
976     (setf (string-output-stream-index stream) 0)
977     result))
978 ram 1.1
979     (defun dump-output-stream-string (in-stream out-stream)
980     "Dumps the characters buffer up in the In-Stream to the Out-Stream as
981     Get-Output-Stream-String would return them."
982     (write-string (string-output-stream-string in-stream) out-stream
983     :start 0 :end (string-output-stream-index in-stream))
984     (setf (string-output-stream-index in-stream) 0))
985    
986     ;;;; Fill-pointer streams:
987     ;;;
988     ;;; Fill pointer string output streams are not explicitly mentioned in
989     ;;; the CLM, but they are required for the implementation of With-Output-To-String.
990    
991     (defstruct (fill-pointer-output-stream
992     (:include stream
993     (out #'fill-pointer-ouch)
994     (sout #'fill-pointer-sout)
995     (misc #'fill-pointer-misc))
996     (:print-function
997     (lambda (s stream d)
998     (declare (ignore s d))
999     (write-string "#<Fill-Pointer String Output Stream>" stream)))
1000     (:constructor make-fill-pointer-output-stream (string)))
1001     ;; The string we throw stuff in.
1002     string)
1003    
1004    
1005     (defun fill-pointer-ouch (stream character)
1006     (let* ((buffer (fill-pointer-output-stream-string stream))
1007 wlott 1.4 (current (fill-pointer buffer))
1008 ram 1.1 (current+1 (1+ current)))
1009     (declare (fixnum current))
1010     (with-array-data ((workspace buffer) (start) (end))
1011     (declare (simple-string workspace))
1012     (let ((offset-current (+ start current)))
1013     (declare (fixnum offset-current))
1014     (if (= offset-current end)
1015     (let* ((new-length (* current 2))
1016     (new-workspace (make-string new-length)))
1017     (declare (simple-string new-workspace))
1018     (%primitive byte-blt workspace start new-workspace 0 current)
1019     (setf workspace new-workspace)
1020     (setf offset-current current)
1021     (set-array-header buffer workspace new-length
1022     current+1 0 new-length nil))
1023 wlott 1.4 (setf (fill-pointer buffer) current+1))
1024 ram 1.1 (setf (schar workspace offset-current) character)))
1025     current+1))
1026    
1027    
1028     (defun fill-pointer-sout (stream string start end)
1029     (declare (simple-string string) (fixnum start end))
1030     (let* ((buffer (fill-pointer-output-stream-string stream))
1031 wlott 1.4 (current (fill-pointer buffer))
1032 ram 1.1 (string-len (- end start))
1033     (dst-end (+ string-len current)))
1034     (declare (fixnum current dst-end string-len))
1035     (with-array-data ((workspace buffer) (dst-start) (dst-length))
1036     (declare (simple-string workspace))
1037     (let ((offset-dst-end (+ dst-start dst-end))
1038     (offset-current (+ dst-start current)))
1039     (declare (fixnum offset-dst-end offset-current))
1040     (if (> offset-dst-end dst-length)
1041     (let* ((new-length (+ (the fixnum (* current 2)) string-len))
1042     (new-workspace (make-string new-length)))
1043     (declare (simple-string new-workspace))
1044     (%primitive byte-blt workspace dst-start new-workspace 0 current)
1045     (setf workspace new-workspace)
1046     (setf offset-current current)
1047     (setf offset-dst-end dst-end)
1048     (set-array-header buffer workspace new-length
1049     dst-end 0 new-length nil))
1050 wlott 1.4 (setf (fill-pointer buffer) dst-end))
1051 ram 1.1 (%primitive byte-blt string start
1052     workspace offset-current offset-dst-end)))
1053     dst-end))
1054    
1055    
1056     (defun fill-pointer-misc (stream operation &optional arg1 arg2)
1057     (declare (ignore arg1 arg2))
1058     (case operation
1059     (:charpos
1060     (let* ((buffer (fill-pointer-output-stream-string stream))
1061 wlott 1.4 (current (fill-pointer buffer)))
1062 ram 1.1 (with-array-data ((string buffer) (start) (end current))
1063     (declare (simple-string string) (ignore start))
1064     (let ((found (position #\newline string :test #'char=
1065     :end end :from-end t)))
1066     (if found
1067     (- end (the fixnum found))
1068     current)))))
1069     (:element-type 'string-char)))
1070    
1071     ;;;; Indenting streams:
1072    
1073     (defstruct (indenting-stream (:include stream
1074     (out #'indenting-out)
1075     (sout #'indenting-sout)
1076     (misc #'indenting-misc))
1077     (:print-function %print-indenting-stream)
1078     (:constructor make-indenting-stream (stream)))
1079     ;; The stream we're based on:
1080     stream
1081     ;; How much we indent on each line:
1082     (indentation 0))
1083    
1084     (setf (documentation 'make-indenting-stream 'function)
1085     "Returns an ouput stream which indents its output by some amount.")
1086    
1087     (defun %print-indenting-stream (s stream d)
1088     (declare (ignore s d))
1089     (write-string "#<Indenting Stream>" stream))
1090    
1091     ;;; Indenting-Indent writes the right number of spaces needed to indent output on
1092     ;;; the given Stream based on the specified Sub-Stream.
1093    
1094     (defmacro indenting-indent (stream sub-stream)
1095     `(do ((i 0 (+ i 60))
1096     (indentation (indenting-stream-indentation ,stream)))
1097     ((>= i indentation))
1098     (funcall (stream-sout ,sub-stream) ,sub-stream
1099     " "
1100     0 (min 60 (- indentation i)))))
1101    
1102     ;;; Indenting-Out writes a character to an indenting stream.
1103    
1104     (defun indenting-out (stream char)
1105     (let ((sub-stream (indenting-stream-stream stream)))
1106     (funcall (stream-out sub-stream) sub-stream char)
1107     (if (char= char #\newline)
1108     (indenting-indent stream sub-stream))))
1109    
1110     ;;; Indenting-Sout writes a string to an indenting stream.
1111    
1112     (defun indenting-sout (stream string start end)
1113     (declare (simple-string string) (fixnum start end))
1114     (do ((i start)
1115     (sub-stream (indenting-stream-stream stream)))
1116     ((= i end))
1117     (let ((newline (position #\newline string :start i :end end)))
1118     (cond (newline
1119     (funcall (stream-sout sub-stream) sub-stream string i (1+ newline))
1120     (indenting-indent stream sub-stream)
1121     (setq i (+ newline 1)))
1122     (t
1123     (funcall (stream-sout sub-stream) sub-stream string i end)
1124     (setq i end))))))
1125    
1126     ;;; Indenting-Misc just treats just the :Line-Length message differently.
1127     ;;; Indenting-Charpos says the charpos is the charpos of the base stream minus
1128     ;;; the stream's indentation.
1129    
1130     (defun indenting-misc (stream operation &optional arg1 arg2)
1131     (let* ((sub-stream (indenting-stream-stream stream))
1132     (method (stream-misc sub-stream)))
1133     (case operation
1134     (:line-length
1135     (let ((line-length (funcall method sub-stream operation)))
1136     (if line-length
1137     (- line-length (indenting-stream-indentation stream)))))
1138     (:charpos
1139     (let* ((sub-stream (indenting-stream-stream stream))
1140     (charpos (funcall method sub-stream operation)))
1141     (if charpos
1142     (- charpos (indenting-stream-indentation stream)))))
1143     (t
1144     (funcall method sub-stream operation arg1 arg2)))))
1145    
1146 wlott 1.13 (proclaim '(maybe-inline read-char unread-char read-byte listen))
1147    
1148    
1149    
1150     ;;;; Case frobbing streams, used by format ~(...~).
1151    
1152     (defstruct (case-frob-stream
1153     (:include stream
1154     (:misc #'case-frob-misc))
1155     (:constructor %make-case-frob-stream (target out sout)))
1156     (target (required-argument) :type stream))
1157    
1158     (defun make-case-frob-stream (target kind)
1159     "Returns a stream that sends all output to the stream TARGET, but modifies
1160     the case of letters, depending on KIND, which should be one of:
1161     :upcase - convert to upper case.
1162     :downcase - convert to lower case.
1163     :capitalize - convert the first letter of words to upper case and the
1164     rest of the word to lower case.
1165     :capitalize-first - convert the first letter of the first word to upper
1166     case and everything else to lower case."
1167     (declare (type stream target)
1168     (type (member :upcase :downcase :capitalize :capitalize-first)
1169     kind)
1170     (values stream))
1171     (if (case-frob-stream-p target)
1172     ;; If we are going to be writing to a stream that already does case
1173     ;; frobbing, why bother frobbing the case just so it can frob it
1174     ;; again?
1175     target
1176     (multiple-value-bind
1177     (out sout)
1178     (ecase kind
1179     (:upcase
1180     (values #'case-frob-upcase-out
1181     #'case-frob-upcase-sout))
1182     (:downcase
1183     (values #'case-frob-downcase-out
1184     #'case-frob-downcase-sout))
1185     (:capitalize
1186     (values #'case-frob-capitalize-out
1187     #'case-frob-capitalize-sout))
1188     (:capitalize-first
1189     (values #'case-frob-capitalize-first-out
1190     #'case-frob-capitalize-first-sout)))
1191     (%make-case-frob-stream target out sout))))
1192    
1193     (defun case-frob-misc (stream op &optional arg1 arg2)
1194     (declare (type case-frob-stream stream))
1195     (case op
1196     (:close)
1197     (t
1198     (let ((target (case-frob-stream-target stream)))
1199     (funcall (stream-misc target) target op arg1 arg2)))))
1200    
1201    
1202     (defun case-frob-upcase-out (stream char)
1203     (declare (type case-frob-stream stream)
1204 ram 1.16 (type base-char char))
1205 wlott 1.13 (let ((target (case-frob-stream-target stream)))
1206     (funcall (stream-out target) target (char-upcase char))))
1207    
1208     (defun case-frob-upcase-sout (stream str start end)
1209     (declare (type case-frob-stream stream)
1210     (type simple-base-string str)
1211     (type index start)
1212     (type (or index null) end))
1213     (let* ((target (case-frob-stream-target stream))
1214     (len (length str))
1215     (end (or end len)))
1216     (funcall (stream-sout target) target
1217     (if (and (zerop start) (= len end))
1218     (string-upcase str)
1219     (nstring-upcase (subseq str start end)))
1220     0
1221     (- end start))))
1222    
1223     (defun case-frob-downcase-out (stream char)
1224     (declare (type case-frob-stream stream)
1225 ram 1.16 (type base-char char))
1226 wlott 1.13 (let ((target (case-frob-stream-target stream)))
1227     (funcall (stream-out target) target (char-downcase char))))
1228    
1229     (defun case-frob-downcase-sout (stream str start end)
1230     (declare (type case-frob-stream stream)
1231     (type simple-base-string str)
1232     (type index start)
1233     (type (or index null) end))
1234     (let* ((target (case-frob-stream-target stream))
1235     (len (length str))
1236     (end (or end len)))
1237     (funcall (stream-sout target) target
1238     (if (and (zerop start) (= len end))
1239     (string-downcase str)
1240     (nstring-downcase (subseq str start end)))
1241     0
1242     (- end start))))
1243    
1244     (defun case-frob-capitalize-out (stream char)
1245     (declare (type case-frob-stream stream)
1246 ram 1.16 (type base-char char))
1247 wlott 1.13 (let ((target (case-frob-stream-target stream)))
1248     (cond ((alphanumericp char)
1249     (funcall (stream-out target) target (char-upcase char))
1250     (setf (case-frob-stream-out stream)
1251     #'case-frob-capitalize-aux-out)
1252     (setf (case-frob-stream-sout stream)
1253     #'case-frob-capitalize-aux-sout))
1254     (t
1255     (funcall (stream-out target) target char)))))
1256    
1257     (defun case-frob-capitalize-sout (stream str start end)
1258     (declare (type case-frob-stream stream)
1259     (type simple-base-string str)
1260     (type index start)
1261     (type (or index null) end))
1262     (let* ((target (case-frob-stream-target stream))
1263     (str (subseq str start end))
1264     (len (length str))
1265     (inside-word nil))
1266     (dotimes (i len)
1267     (let ((char (schar str i)))
1268     (cond ((not (alphanumericp char))
1269     (setf inside-word nil))
1270     (inside-word
1271     (setf (schar str i) (char-downcase char)))
1272     (t
1273     (setf inside-word t)
1274     (setf (schar str i) (char-upcase char))))))
1275     (when inside-word
1276     (setf (case-frob-stream-out stream)
1277     #'case-frob-capitalize-aux-out)
1278     (setf (case-frob-stream-sout stream)
1279     #'case-frob-capitalize-aux-sout))
1280     (funcall (stream-sout target) target str 0 len)))
1281    
1282     (defun case-frob-capitalize-aux-out (stream char)
1283     (declare (type case-frob-stream stream)
1284 ram 1.16 (type base-char char))
1285 wlott 1.13 (let ((target (case-frob-stream-target stream)))
1286     (cond ((alphanumericp char)
1287     (funcall (stream-out target) target (char-downcase char)))
1288     (t
1289     (funcall (stream-out target) target char)
1290     (setf (case-frob-stream-out stream)
1291     #'case-frob-capitalize-out)
1292     (setf (case-frob-stream-sout stream)
1293     #'case-frob-capitalize-sout)))))
1294    
1295     (defun case-frob-capitalize-aux-sout (stream str start end)
1296     (declare (type case-frob-stream stream)
1297     (type simple-base-string str)
1298     (type index start)
1299     (type (or index null) end))
1300     (let* ((target (case-frob-stream-target stream))
1301     (str (subseq str start end))
1302     (len (length str))
1303     (inside-word t))
1304     (dotimes (i len)
1305     (let ((char (schar str i)))
1306     (cond ((not (alphanumericp char))
1307     (setf inside-word nil))
1308     (inside-word
1309     (setf (schar str i) (char-downcase char)))
1310     (t
1311     (setf inside-word t)
1312     (setf (schar str i) (char-upcase char))))))
1313     (unless inside-word
1314     (setf (case-frob-stream-out stream)
1315     #'case-frob-capitalize-out)
1316     (setf (case-frob-stream-sout stream)
1317     #'case-frob-capitalize-sout))
1318     (funcall (stream-sout target) target str 0 len)))
1319    
1320     (defun case-frob-capitalize-first-out (stream char)
1321     (declare (type case-frob-stream stream)
1322 ram 1.16 (type base-char char))
1323 wlott 1.13 (let ((target (case-frob-stream-target stream)))
1324     (cond ((alphanumericp char)
1325     (funcall (stream-out target) target (char-upcase char))
1326     (setf (case-frob-stream-out stream)
1327     #'case-frob-downcase-out)
1328     (setf (case-frob-stream-sout stream)
1329     #'case-frob-downcase-sout))
1330     (t
1331     (funcall (stream-out target) target char)))))
1332    
1333     (defun case-frob-capitalize-first-sout (stream str start end)
1334     (declare (type case-frob-stream stream)
1335     (type simple-base-string str)
1336     (type index start)
1337     (type (or index null) end))
1338     (let* ((target (case-frob-stream-target stream))
1339     (str (subseq str start end))
1340     (len (length str)))
1341     (dotimes (i len)
1342     (let ((char (schar str i)))
1343     (when (alphanumericp char)
1344     (setf (schar str i) (char-upcase char))
1345     (do ((i (1+ i) (1+ i)))
1346     ((= i len))
1347     (setf (schar str i) (char-downcase (schar str i))))
1348     (setf (case-frob-stream-out stream)
1349     #'case-frob-downcase-out)
1350     (setf (case-frob-stream-sout stream)
1351     #'case-frob-downcase-sout)
1352     (return))))
1353     (funcall (stream-sout target) target str 0 len)))
1354 chiles 1.12
1355    
1356     ;;;; Public interface from "EXTENSIONS" package.
1357    
1358     (defstruct (stream-command (:print-function print-stream-command)
1359     (:constructor make-stream-command
1360     (name &optional args)))
1361     (name nil :type symbol)
1362     (args nil :type list))
1363    
1364     (defun print-stream-command (obj str n)
1365     (declare (ignore n))
1366     (format str "#<Stream-Cmd ~S>" (stream-command-name obj)))
1367    
1368    
1369     ;;; GET-STREAM-COMMAND -- Public.
1370     ;;;
1371     ;;; We can't simply call the stream's misc method because because nil is an
1372     ;;; ambiguous return value: does it mean text arrived, or does it mean the
1373     ;;; stream's misc method had no :get-command implementation. We can't return
1374     ;;; nil until there is text input. We don't need to loop because any stream
1375     ;;; implementing :get-command would wait until it had some input. If the
1376     ;;; LISTEN fails, then we have some random stream we must wait on.
1377     ;;;
1378     (defun get-stream-command (stream)
1379     "This takes a stream and waits for text or a command to appear on it. If
1380     text appears before a command, this returns nil, and otherwise it returns
1381     a command."
1382     (let ((cmdp (funcall (lisp::stream-misc stream) stream :get-command)))
1383     (cond (cmdp)
1384     ((listen stream)
1385     nil)
1386     (t
1387     ;; This waits for input and returns nil when it arrives.
1388     (unread-char (read-char stream) stream)))))

  ViewVC Help
Powered by ViewVC 1.1.5