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

Contents of /src/code/stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5