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

Contents of /src/code/stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.83.6.3 - (hide annotations)
Fri May 30 13:27:14 2008 UTC (5 years, 10 months ago) by rtoy
Branch: unicode-utf16-branch
Changes since 1.83.6.2: +6 -4 lines
For unicode, use %primitive byte-blt again instead of replace.  (Some
calls to replace were incorrect anyway.)
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     ;;;
7     (ext:file-comment
8 rtoy 1.83.6.3 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/stream.lisp,v 1.83.6.3 2008/05/30 13:27:14 rtoy Exp $")
9 ram 1.9 ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12     ;;; Stream functions for Spice Lisp.
13     ;;; Written by Skef Wholey and Rob MacLachlan.
14 dtc 1.33 ;;; Gray streams support by Douglas Crosher, 1998.
15 toy 1.61 ;;; Simple-streams support by Paul Foley, 2003.
16 ram 1.1 ;;;
17 ram 1.14 ;;; This file contains the OS-independent stream functions.
18 ram 1.1 ;;;
19 ram 1.2 (in-package "LISP")
20 ram 1.1
21 ram 1.14 (export '(broadcast-stream make-broadcast-stream broadcast-stream-streams
22     synonym-stream make-synonym-stream synonym-stream-symbol
23     concatenated-stream make-concatenated-stream
24     concatenated-stream-streams
25     two-way-stream make-two-way-stream two-way-stream-input-stream
26     two-way-stream-output-stream
27     echo-stream make-echo-stream echo-stream-input-stream
28     echo-stream-output-stream
29     make-string-input-stream make-string-output-stream
30 ram 1.1 get-output-stream-string stream-element-type input-stream-p
31 ram 1.14 output-stream-p open-stream-p interactive-stream-p
32 wlott 1.17 open-stream-p close read-line read-char
33 ram 1.1 unread-char peek-char listen read-char-no-hang clear-input read-byte
34     write-char write-string write-line terpri fresh-line
35     finish-output force-output clear-output write-byte
36 ram 1.14 stream streamp string-stream
37     *standard-input* *standard-output*
38 ram 1.1 *error-output* *query-io* *debug-io* *terminal-io* *trace-output*))
39    
40 ram 1.18 (in-package "SYSTEM")
41 ram 1.1 (export '(make-indenting-stream read-n-bytes))
42    
43 ram 1.18 (in-package "EXT")
44    
45     (export '(get-stream-command
46     stream-command stream-command-p stream-command-name
47     stream-command-args make-stream-command make-case-frob-stream))
48    
49     (in-package "LISP")
50 ram 1.14
51 ram 1.1 ;;;; Standard streams:
52     ;;;
53     ;;; The initialization of these streams is performed by Stream-Init,
54     ;;; which lives in the file of machine-specific stream functions.
55     ;;;
56     (defvar *terminal-io* () "Terminal I/O stream.")
57     (defvar *standard-input* () "Default input stream.")
58     (defvar *standard-output* () "Default output stream.")
59     (defvar *error-output* () "Error output stream.")
60     (defvar *query-io* () "Query I/O stream.")
61     (defvar *trace-output* () "Trace output stream.")
62     (defvar *debug-io* () "Interactive debugging stream.")
63    
64 toy 1.52 (defun ill-in-any (stream &rest ignore)
65     (declare (ignore ignore))
66     (error 'simple-type-error
67     :datum stream
68     :expected-type '(satisfies input-stream-p)
69     :format-control "~S is not an input stream."
70     :format-arguments (list stream)))
71     (defun ill-out-any (stream &rest ignore)
72     (declare (ignore ignore))
73     (error 'simple-type-error
74     :datum stream
75     :expected-type '(satisfies output-stream-p)
76     :format-control "~S is not an output stream."
77     :format-arguments (list stream)))
78 ram 1.1 (defun ill-in (stream &rest ignore)
79     (declare (ignore ignore))
80 pw 1.34 (error 'simple-type-error
81     :datum stream
82     :expected-type '(satisfies input-stream-p)
83     :format-control "~S is not a character input stream."
84     :format-arguments (list stream)))
85 ram 1.1 (defun ill-out (stream &rest ignore)
86     (declare (ignore ignore))
87 pw 1.34 (error 'simple-type-error
88     :datum stream
89     :expected-type '(satisfies output-stream-p)
90     :format-control "~S is not a character output stream."
91     :format-arguments (list stream)))
92 ram 1.1 (defun ill-bin (stream &rest ignore)
93     (declare (ignore ignore))
94 pw 1.34 (error 'simple-type-error
95     :datum stream
96     :expected-type '(satisfies input-stream-p)
97     :format-control "~S is not a binary input stream."
98     :format-arguments (list stream)))
99 toy 1.49 (defun ill-n-bin (stream &rest ignore)
100     (declare (ignore ignore))
101     (error 'simple-type-error
102     :datum stream
103     :expected-type '(satisfies input-stream-p)
104 toy 1.61 :format-control "~S is not a binary input stream ~
105     or does not support multi-byte read operations."
106 toy 1.49 :format-arguments (list stream)))
107 ram 1.1 (defun ill-bout (stream &rest ignore)
108     (declare (ignore ignore))
109 pw 1.34 (error 'simple-type-error
110     :datum stream
111     :expected-type '(satisfies output-stream-p)
112     :format-control "~S is not a binary output stream."
113     :format-arguments (list stream)))
114 ram 1.1 (defun closed-flame (stream &rest ignore)
115     (declare (ignore ignore))
116     (error "~S is closed." stream))
117     (defun do-nothing (&rest ignore)
118     (declare (ignore ignore)))
119 toy 1.61 (defun no-gray-streams (stream)
120     (error 'simple-type-error
121     :datum stream
122     :expected-type 'stream
123     :format-control "~S is an unsupported Gray stream."
124     :format-arguments (list stream)))
125 ram 1.1
126     (defun %print-stream (structure stream d)
127     (declare (ignore d structure))
128     (write-string "#<Bare Stream>" stream))
129    
130     ;;; HOW THE STREAM STRUCTURE IS USED:
131     ;;;
132     ;;; Many of the slots of the stream structure contain functions
133     ;;; which are called to perform some operation on the stream. Closed
134     ;;; streams have #'Closed-Flame in all of their function slots. If
135     ;;; one side of an I/O or echo stream is closed, the whole stream is
136     ;;; considered closed. The functions in the operation slots take
137     ;;; arguments as follows:
138     ;;;
139     ;;; In: Stream, Eof-Errorp, Eof-Value
140     ;;; Bin: Stream, Eof-Errorp, Eof-Value
141     ;;; N-Bin: Stream, Buffer, Start, Numbytes, Eof-Errorp
142     ;;; Out: Stream, Character
143     ;;; Bout: Stream, Integer
144     ;;; Sout: Stream, String, Start, End
145     ;;; Misc: Stream, Operation, &Optional Arg1, Arg2
146     ;;;
147     ;;; In order to save space, some of the less common stream operations
148     ;;; are handled by just one function, the Misc method. This function
149     ;;; is passed a keyword which indicates the operation to perform.
150     ;;; The following keywords are used:
151 toy 1.61 ;;;
152 ram 1.10 ;;; :listen - Return the following values:
153     ;;; t if any input waiting.
154     ;;; :eof if at eof.
155     ;;; nil if no input is available and not at eof.
156 ram 1.1 ;;; :unread - Unread the character Arg.
157     ;;; :close - Do any stream specific stuff to close the stream.
158     ;;; The methods are set to closed-flame by the close
159     ;;; function, so that need not be done by this
160     ;;; function.
161     ;;; :clear-input - Clear any unread input
162     ;;; :finish-output,
163     ;;; :force-output - Cause output to happen
164     ;;; :clear-output - Clear any undone output
165 toy 1.61 ;;; :element-type - Return the type of element the stream deals with.
166 ram 1.1 ;;; :line-length - Return the length of a line of output.
167     ;;; :charpos - Return current output position on the line.
168     ;;; :file-length - Return the file length of a file stream.
169     ;;; :file-position - Return or change the current position of a file stream.
170     ;;; :file-name - Return the name of an associated file.
171 ram 1.14 ;;; :interactive-p - Is this an interactive device?
172 ram 1.1 ;;;
173     ;;; In order to do almost anything useful, it is necessary to
174     ;;; define a new type of structure that includes stream, so that the
175     ;;; stream can have some state information.
176     ;;;
177     ;;; THE STREAM IN-BUFFER:
178     ;;;
179     ;;; The In-Buffer in the stream holds characters or bytes that
180     ;;; are ready to be read by some input function. If there is any
181     ;;; stuff in the In-Buffer, then the reading function can use it
182     ;;; without calling any stream method. Any stream may put stuff in
183     ;;; the In-Buffer, and may also assume that any input in the In-Buffer
184     ;;; has been consumed before any in-method is called. If a text
185     ;;; stream has in In-Buffer, then the first character should not be
186     ;;; used to buffer normal input so that it is free for unreading into.
187     ;;;
188     ;;; The In-Buffer slot is a vector In-Buffer-Length long. The
189     ;;; In-Index is the index in the In-Buffer of the first available
190     ;;; object. The available objects are thus between In-Index and the
191     ;;; length of the In-Buffer.
192     ;;;
193     ;;; When this buffer is only accessed by the normal stream
194     ;;; functions, the number of function calls is halved, thus
195     ;;; potentially doubling the speed of simple operations. If the
196     ;;; Fast-Read-Char and Fast-Read-Byte macros are used, nearly all
197     ;;; function call overhead is removed, vastly speeding up these
198     ;;; important operations.
199     ;;;
200     ;;; If a stream does not have an In-Buffer, then the In-Buffer slot
201     ;;; must be nil, and the In-Index must be In-Buffer-Length. These are
202     ;;; the default values for the slots.
203 ram 1.18
204 ram 1.1
205     ;;; Stream manipulation functions.
206    
207     (defun input-stream-p (stream)
208     "Returns non-nil if the given Stream can perform input operations."
209 toy 1.61 (declare (type stream stream))
210     ;; Note: Gray streams redefines this function; any changes made here need
211     ;; to be duplicated in .../pcl/gray-streams.lisp
212     (stream-dispatch stream
213     ;; simple-stream
214     (stream::%input-stream-p stream)
215     ;; lisp-stream
216 rtoy 1.75 (let ((stream (if (synonym-stream-p stream)
217     (symbol-value (synonym-stream-symbol stream))
218     stream)))
219     (and (not (eq (lisp-stream-in stream) #'closed-flame))
220     (or (not (eq (lisp-stream-in stream) #'ill-in))
221     (not (eq (lisp-stream-bin stream) #'ill-bin))
222     (not (eq (lisp-stream-n-bin stream) #'ill-n-bin)))))))
223 ram 1.1
224     (defun output-stream-p (stream)
225     "Returns non-nil if the given Stream can perform output operations."
226 toy 1.61 (declare (type stream stream))
227     ;; Note: Gray streams redefines this function; any changes made here need
228     ;; to be duplicated in .../pcl/gray-streams.lisp
229     (stream-dispatch stream
230     ;; simple-stream
231     (stream::%output-stream-p stream)
232     ;; lisp-stream
233 rtoy 1.75 (let ((stream (if (synonym-stream-p stream)
234     (symbol-value (synonym-stream-symbol stream))
235     stream)))
236     (and (not (eq (lisp-stream-in stream) #'closed-flame))
237     (or (not (eq (lisp-stream-out stream) #'ill-out))
238     (not (eq (lisp-stream-bout stream) #'ill-bout)))))))
239 ram 1.1
240 ram 1.14 (defun open-stream-p (stream)
241     "Return true if Stream is not closed."
242     (declare (type stream stream))
243 toy 1.61 ;; Note: Gray streams redefines this function; any changes made here need
244     ;; to be duplicated in .../pcl/gray-streams.lisp
245     (stream-dispatch stream
246     ;; simple-stream
247     (stream::%open-stream-p stream)
248     ;; lisp-stream
249     (not (eq (lisp-stream-in stream) #'closed-flame))))
250 ram 1.14
251 ram 1.1 (defun stream-element-type (stream)
252     "Returns a type specifier for the kind of object returned by the Stream."
253 wlott 1.17 (declare (type stream stream))
254 toy 1.61 ;; Note: Gray streams redefines this function; any changes made here need
255     ;; to be duplicated in .../pcl/gray-streams.lisp
256     (stream-dispatch stream
257     ;; simple-stream
258     '(unsigned-byte 8)
259     ;; lisp-stream
260     (funcall (lisp-stream-misc stream) stream :element-type)))
261 ram 1.1
262 ram 1.14 (defun interactive-stream-p (stream)
263     "Return true if Stream does I/O on a terminal or other interactive device."
264     (declare (type stream stream))
265 toy 1.61 (stream-dispatch stream
266     ;; simple-stream
267     (stream::%interactive-stream-p stream)
268     ;; lisp-stream
269     (funcall (lisp-stream-misc stream) stream :interactive-p)))
270 ram 1.14
271 toy 1.61 (defun (setf interactive-stream-p) (flag stream)
272     (declare (type stream stream))
273     (stream-dispatch stream
274     ;; simple-stream
275     (if flag
276     (stream::%interactive-stream-y stream)
277     (stream::%interactive-stream-n stream))
278     ;; lisp-stream
279     (error 'simple-type-error
280     :datum stream
281     :expected-type 'stream:simple-stream
282     :format-control "Can't set interactive flag on ~S."
283     :format-arguments (list stream))))
284    
285     (defun stream-external-format (stream)
286     "Returns the external format used by the given Stream."
287 wlott 1.17 (declare (type stream stream))
288 toy 1.61 (stream-dispatch stream
289     ;; simple-stream
290     (stream::%stream-external-format stream)
291     ;; lisp-stream
292     :default
293     ;; fundamental-stream
294     :default))
295 wlott 1.17
296 ram 1.1 (defun close (stream &key abort)
297     "Closes the given Stream. No more I/O may be performed, but inquiries
298     may still be made. If :Abort is non-nil, an attempt is made to clean
299     up the side effects of having created the stream."
300 wlott 1.17 (declare (type stream stream))
301 toy 1.61 ;; Note: Gray streams redefines this function; any changes made here need
302     ;; to be duplicated in .../pcl/gray-streams.lisp
303     (stream-dispatch stream
304     ;; simple-stream
305     (stream:device-close stream abort)
306     ;; lisp-stream
307     (when (open-stream-p stream)
308     (funcall (lisp-stream-misc stream) stream :close abort)))
309 ram 1.1 t)
310    
311     (defun set-closed-flame (stream)
312 toy 1.61 (declare (type lisp-stream stream))
313 dtc 1.30 (setf (lisp-stream-in stream) #'closed-flame)
314     (setf (lisp-stream-bin stream) #'closed-flame)
315     (setf (lisp-stream-n-bin stream) #'closed-flame)
316     (setf (lisp-stream-in stream) #'closed-flame)
317     (setf (lisp-stream-out stream) #'closed-flame)
318     (setf (lisp-stream-bout stream) #'closed-flame)
319     (setf (lisp-stream-sout stream) #'closed-flame)
320     (setf (lisp-stream-misc stream) #'closed-flame))
321 ram 1.18
322 ram 1.1
323 ram 1.18 ;;;; File position and file length.
324    
325     ;;; File-Position -- Public
326     ;;;
327     ;;; Call the misc method with the :file-position operation.
328     ;;;
329     (defun file-position (stream &optional position)
330     "With one argument returns the current position within the file
331 wlott 1.19 File-Stream is open to. If the second argument is supplied, then
332     this becomes the new file position. The second argument may also
333     be :start or :end for the start and end of the file, respectively."
334 emarsden 1.59 (declare (type stream stream)
335 toy 1.61 (type (or (integer 0 *) (member nil :start :end)) position))
336     (stream-dispatch stream
337     ;; simple-stream
338     (stream::%file-position stream position)
339     ;; lisp-stream
340     (cond
341     (position
342     (setf (lisp-stream-in-index stream) in-buffer-length)
343     (funcall (lisp-stream-misc stream) stream :file-position position))
344     (t
345     (let ((res (funcall (lisp-stream-misc stream) stream
346     :file-position nil)))
347     (when res
348     (- res (- in-buffer-length (lisp-stream-in-index stream)))))))))
349 ram 1.18
350    
351     ;;; File-Length -- Public
352     ;;;
353     ;;; Like File-Position, only use :file-length.
354     ;;;
355     (defun file-length (stream)
356     "This function returns the length of the file that File-Stream is open to."
357 toy 1.61 (stream-dispatch stream
358     ;; simple-stream
359     (stream::%file-length stream)
360     ;; lisp-stream
361     (funcall (lisp-stream-misc stream) stream :file-length)))
362 ram 1.18
363    
364 ram 1.1 ;;; Input functions:
365    
366     (defun read-line (&optional (stream *standard-input*) (eof-errorp t) eof-value
367     recursive-p)
368     "Returns a line of text read from the Stream as a string, discarding the
369     newline character."
370 dtc 1.32 (let ((stream (in-synonym-of stream)))
371 toy 1.61 (stream-dispatch stream
372     ;; simple-stream
373     (stream::%read-line stream eof-errorp eof-value recursive-p)
374     ;; lisp-stream
375     (prepare-for-fast-read-char stream
376     (let ((res (make-string 80))
377     (len 80)
378     (index 0))
379     (loop
380     (let ((ch (fast-read-char nil nil)))
381     (cond (ch
382     (when (char= ch #\newline)
383     (done-with-fast-read-char)
384     (return (values (shrink-vector res index) nil)))
385     (when (= index len)
386     (setq len (* len 2))
387     (let ((new (make-string len)))
388     (replace new res)
389     (setq res new)))
390     (setf (schar res index) ch)
391     (incf index))
392     ((zerop index)
393     (done-with-fast-read-char)
394     (return (values (eof-or-lose stream eof-errorp eof-value)
395     t)))
396     ;; since fast-read-char hit already the eof char, we
397     ;; shouldn't do another read-char
398     (t
399     (done-with-fast-read-char)
400     (return (values (shrink-vector res index) t))))))))
401     ;; fundamental-stream
402     (multiple-value-bind (string eof)
403     (stream-read-line stream)
404     (if (and eof (zerop (length string)))
405     (values (eof-or-lose stream eof-errorp eof-value) t)
406     (values string eof))))))
407 ram 1.10
408 ram 1.1 ;;; We proclaim them inline here, then proclaim them notinline at EOF,
409     ;;; so, except in this file, they are not inline by default, but they can be.
410     ;;;
411 pw 1.45 (declaim (inline read-char unread-char read-byte listen))
412 ram 1.1 (defun read-char (&optional (stream *standard-input*) (eof-errorp t) eof-value
413     recursive-p)
414     "Inputs a character from Stream and returns it."
415 dtc 1.32 (let ((stream (in-synonym-of stream)))
416 toy 1.61 (stream-dispatch stream
417     ;; simple-stream
418     (stream::%read-char stream eof-errorp eof-value recursive-p t)
419     ;; lisp-stream
420     (prepare-for-fast-read-char stream
421     (prog1
422     (fast-read-char eof-errorp eof-value)
423     (done-with-fast-read-char)))
424     ;; fundamental-stream
425     (let ((char (stream-read-char stream)))
426     (if (eq char :eof)
427     (eof-or-lose stream eof-errorp eof-value)
428     char)))))
429 ram 1.1
430     (defun unread-char (character &optional (stream *standard-input*))
431     "Puts the Character back on the front of the input Stream."
432 dtc 1.32 (let ((stream (in-synonym-of stream)))
433 toy 1.61 (stream-dispatch stream
434     ;; simple-stream
435     (stream::%unread-char stream character)
436     ;; lisp-stream
437     (let ((index (1- (lisp-stream-in-index stream)))
438     (buffer (lisp-stream-in-buffer stream)))
439     (declare (fixnum index))
440     (when (minusp index) (error "Nothing to unread."))
441     (cond (buffer
442     (setf (aref buffer index) (char-code character))
443     (setf (lisp-stream-in-index stream) index))
444     (t
445     (funcall (lisp-stream-misc stream) stream
446     :unread character))))
447     ;; fundamental-stream
448     (stream-unread-char stream character)))
449 ram 1.1 nil)
450    
451 toy 1.56 ;;; In the interest of ``once and only once'' this macro contains the
452     ;;; framework necessary to implement a peek-char function, which has
453     ;;; two special-cases (one for gray streams and one for echo streams)
454     ;;; in addition to the normal case.
455     ;;;
456     ;;; All arguments are forms which will be used for a specific purpose
457     ;;; PEEK-TYPE - the current peek-type as defined by ANSI CL
458     ;;; EOF-VALUE - the eof-value argument to peek-char
459     ;;; CHAR-VAR - the variable which will be used to store the current character
460     ;;; READ-FORM - the form which will be used to read a character
461 rtoy 1.80 ;;; READ-EOF - the result returned from READ-FORM when eof is reached.
462 toy 1.56 ;;; UNREAD-FORM - ditto for unread-char
463     ;;; SKIPPED-CHAR-FORM - the form to execute when skipping a character
464     ;;; EOF-DETECTED-FORM - the form to execute when EOF has been detected
465     ;;; (this will default to CHAR-VAR)
466 toy 1.61 (defmacro generalized-peeking-mechanism (peek-type eof-value char-var
467 rtoy 1.80 read-form read-eof unread-form
468 rtoy 1.82 &key (skipped-char-form nil)
469     (eof-detected-form nil))
470 toy 1.56 `(let ((,char-var ,read-form))
471 rtoy 1.80 (cond ((eql ,char-var ,read-eof)
472 toy 1.56 ,(if eof-detected-form
473     eof-detected-form
474 rtoy 1.80 eof-value))
475 toy 1.56 ((characterp ,peek-type)
476     (do ((,char-var ,char-var ,read-form))
477 rtoy 1.80 ((or (eql ,char-var ,read-eof)
478 toy 1.56 (char= ,char-var ,peek-type))
479 rtoy 1.80 (cond ((eql ,char-var ,read-eof)
480 toy 1.56 ,(if eof-detected-form
481     eof-detected-form
482 rtoy 1.80 eof-value))
483 toy 1.56 (t ,unread-form
484     ,char-var)))
485     ,skipped-char-form))
486     ((eql ,peek-type t)
487     (do ((,char-var ,char-var ,read-form))
488 rtoy 1.80 ((or (eql ,char-var ,read-eof)
489 toy 1.66 (not (eql (get-cat-entry ,char-var *readtable*) whitespace)))
490 rtoy 1.80 (cond ((eql ,char-var ,read-eof)
491 toy 1.56 ,(if eof-detected-form
492     eof-detected-form
493 rtoy 1.80 eof-value))
494 toy 1.56 (t ,unread-form
495     ,char-var)))
496     ,skipped-char-form))
497     ((null ,peek-type)
498     ,unread-form
499 toy 1.67 ,(if eof-detected-form
500 rtoy 1.80 (when (eql char-var read-eof)
501 toy 1.67 eof-detected-form))
502 toy 1.56 ,char-var)
503     (t
504     (error "Impossible case reached in PEEK-CHAR")))))
505    
506 ram 1.1 (defun peek-char (&optional (peek-type nil) (stream *standard-input*)
507     (eof-errorp t) eof-value recursive-p)
508     "Peeks at the next character in the input Stream. See manual for details."
509 toy 1.56 ;; FIXME: The type of PEEK-TYPE is also declared in a DEFKNOWN, but
510     ;; the compiler doesn't seem to be smart enough to go from there to
511     ;; imposing a type check. Figure out why (because PEEK-TYPE is an
512     ;; &OPTIONAL argument?) and fix it, and then this explicit type
513     ;; check can go away.
514     (unless (typep peek-type '(or character boolean))
515     (error 'simple-type-error
516     :datum peek-type
517     :expected-type '(or character boolean)
518     :format-control "~@<bad PEEK-TYPE=~S, ~_expected ~S~:>"
519     :format-arguments (list peek-type '(or character boolean))))
520 dtc 1.41 (let ((stream (in-synonym-of stream)))
521 toy 1.61 (if (typep stream 'echo-stream)
522     (echo-misc stream :peek-char peek-type (list eof-errorp eof-value))
523     (stream-dispatch stream
524     ;; simple-stream
525     (stream::%peek-char stream peek-type eof-errorp eof-value
526     recursive-p)
527     ;; lisp-stream
528     (generalized-peeking-mechanism
529     peek-type eof-value char
530 rtoy 1.80 (read-char stream eof-errorp :eof)
531     :eof
532 toy 1.67 (unread-char char stream)
533 rtoy 1.82 :skipped-char-form nil
534     :eof-detected-form (eof-or-lose stream (or eof-errorp recursive-p) eof-value))
535 toy 1.61 ;; fundamental-stream
536     (generalized-peeking-mechanism
537     peek-type :eof char
538     (if (null peek-type)
539     (stream-peek-char stream)
540     (stream-read-char stream))
541 rtoy 1.82 :eof
542 toy 1.61 (if (null peek-type)
543     ()
544     (stream-unread-char stream char))
545 rtoy 1.82 :skipped-char-form ()
546     :eof-detected-form (eof-or-lose stream eof-errorp eof-value))))))
547 ram 1.1
548 toy 1.61 (defun listen (&optional (stream *standard-input*) (width 1))
549     "Returns T if a character is available on the given Stream."
550     (declare (type streamlike stream))
551 dtc 1.32 (let ((stream (in-synonym-of stream)))
552 toy 1.61 (stream-dispatch stream
553     ;; simple-stream
554     (stream::%listen stream width)
555     ;; lisp-stream
556     (or (/= (the fixnum (lisp-stream-in-index stream)) in-buffer-length)
557     ;; Test for t explicitly since misc methods return :eof sometimes.
558     (eq (funcall (lisp-stream-misc stream) stream :listen) t))
559     ;; fundamental-stream
560     (stream-listen stream))))
561 ram 1.1
562     (defun read-char-no-hang (&optional (stream *standard-input*)
563     (eof-errorp t) eof-value recursive-p)
564 toy 1.61 "Returns the next character from the Stream if one is available, or nil."
565 dtc 1.32 (let ((stream (in-synonym-of stream)))
566 toy 1.61 (stream-dispatch stream
567     ;; simple-stream
568     (stream::%read-char stream eof-errorp eof-value recursive-p nil)
569     ;; lisp-stream
570     (if (funcall (lisp-stream-misc stream) stream :listen)
571     ;; On t or :eof get READ-CHAR to do the work.
572     (read-char stream eof-errorp eof-value)
573     nil)
574     ;; fundamental-stream
575     (let ((char (stream-read-char-no-hang stream)))
576     (if (eq char :eof)
577     (eof-or-lose stream eof-errorp eof-value)
578     char)))))
579 dtc 1.30
580 ram 1.1
581 toy 1.61 (defun clear-input (&optional (stream *standard-input*) buffer-only)
582 ram 1.1 "Clears any buffered input associated with the Stream."
583 toy 1.52 (declare (type streamlike stream))
584 dtc 1.32 (let ((stream (in-synonym-of stream)))
585 toy 1.61 (stream-dispatch stream
586     ;; simple-stream
587     (stream::%clear-input stream buffer-only)
588     ;; lisp-stream
589     (progn
590     (setf (lisp-stream-in-index stream) in-buffer-length)
591     (funcall (lisp-stream-misc stream) stream :clear-input))
592     ;; fundamental-stream
593     (stream-clear-input stream)))
594 dtc 1.30 nil)
595 ram 1.1
596     (defun read-byte (stream &optional (eof-errorp t) eof-value)
597     "Returns the next byte of the Stream."
598 toy 1.52 (declare (type stream stream))
599 dtc 1.32 (let ((stream (in-synonym-of stream)))
600 toy 1.61 (stream-dispatch stream
601     ;; simple-stream
602     (stream::%read-byte stream eof-errorp eof-value)
603     ;; lisp-stream
604     (prepare-for-fast-read-byte stream
605     (prog1
606     (fast-read-byte eof-errorp eof-value t)
607     (done-with-fast-read-byte)))
608     ;; fundamental-stream
609     (let ((char (stream-read-byte stream)))
610     (if (eq char :eof)
611     (eof-or-lose stream eof-errorp eof-value)
612     char)))))
613 ram 1.1
614     (defun read-n-bytes (stream buffer start numbytes &optional (eof-errorp t))
615 ram 1.24 "Reads Numbytes bytes into the Buffer starting at Start, returning the number
616     of bytes read.
617     -- If EOF-ERROR-P is true, an END-OF-FILE condition is signalled if
618     end-of-file is encountered before Count bytes have been read.
619 toy 1.61 -- If EOF-ERROR-P is false, READ-N-BYTES reads as much data as is currently
620     available (up to count bytes). On pipes or similar devices, this
621     function returns as soon as any data is available, even if the amount
622 ram 1.24 read is less than Count and eof has not been hit."
623 dtc 1.30 (declare (type lisp-stream stream)
624     (type index numbytes start)
625 ram 1.18 (type (or (simple-array * (*)) system-area-pointer) buffer))
626 dtc 1.32 (let* ((stream (in-synonym-of stream lisp-stream))
627 dtc 1.30 (in-buffer (lisp-stream-in-buffer stream))
628     (index (lisp-stream-in-index stream))
629 ram 1.1 (num-buffered (- in-buffer-length index)))
630     (declare (fixnum index num-buffered))
631     (cond
632 ram 1.2 ((not in-buffer)
633 toy 1.61 (funcall (lisp-stream-n-bin stream) stream
634     buffer start numbytes eof-errorp))
635 ram 1.1 ((<= numbytes num-buffered)
636     (%primitive byte-blt in-buffer index buffer start (+ start numbytes))
637 dtc 1.30 (setf (lisp-stream-in-index stream) (+ index numbytes))
638 ram 1.1 numbytes)
639     (t
640     (let ((end (+ start num-buffered)))
641     (%primitive byte-blt in-buffer index buffer start end)
642 dtc 1.30 (setf (lisp-stream-in-index stream) in-buffer-length)
643     (+ (funcall (lisp-stream-n-bin stream) stream buffer end
644 ram 1.18 (- numbytes num-buffered)
645     eof-errorp)
646 ram 1.1 num-buffered))))))
647 ram 1.18
648    
649     ;;; Amount of space we leave at the start of the in-buffer for unreading. 4
650     ;;; instead of 1 to allow word-aligned copies.
651     ;;;
652     (defconstant in-buffer-extra 4)
653    
654     ;;; FAST-READ-CHAR-REFILL -- Interface
655     ;;;
656     ;;; This function is called by the fast-read-char expansion to refill the
657     ;;; in-buffer for text streams. There is definitely an in-buffer, and hence
658     ;;; myst be an n-bin method.
659     ;;;
660     (defun fast-read-char-refill (stream eof-errorp eof-value)
661 dtc 1.30 (let* ((ibuf (lisp-stream-in-buffer stream))
662     (count (funcall (lisp-stream-n-bin stream) stream
663 ram 1.18 ibuf in-buffer-extra
664     (- in-buffer-length in-buffer-extra)
665     nil))
666     (start (- in-buffer-length count)))
667     (declare (type index start count))
668     (cond ((zerop count)
669 dtc 1.30 (setf (lisp-stream-in-index stream) in-buffer-length)
670     (funcall (lisp-stream-in stream) stream eof-errorp eof-value))
671 ram 1.18 (t
672     (when (/= start in-buffer-extra)
673     (bit-bash-copy ibuf (+ (* in-buffer-extra vm:byte-bits)
674     (* vm:vector-data-offset vm:word-bits))
675     ibuf (+ (the index (* start vm:byte-bits))
676     (* vm:vector-data-offset vm:word-bits))
677     (* count vm:byte-bits)))
678 dtc 1.30 (setf (lisp-stream-in-index stream) (1+ start))
679 ram 1.18 (code-char (aref ibuf start))))))
680    
681    
682     ;;; FAST-READ-BYTE-REFILL -- Interface
683     ;;;
684     ;;; Similar to FAST-READ-CHAR-REFILL, but we don't have to leave room for
685     ;;; unreading.
686     ;;;
687     (defun fast-read-byte-refill (stream eof-errorp eof-value)
688 dtc 1.30 (let* ((ibuf (lisp-stream-in-buffer stream))
689     (count (funcall (lisp-stream-n-bin stream) stream
690 ram 1.18 ibuf 0 in-buffer-length
691     nil))
692     (start (- in-buffer-length count)))
693     (declare (type index start count))
694     (cond ((zerop count)
695 dtc 1.30 (setf (lisp-stream-in-index stream) in-buffer-length)
696     (funcall (lisp-stream-bin stream) stream eof-errorp eof-value))
697 ram 1.18 (t
698     (unless (zerop start)
699     (bit-bash-copy ibuf (* vm:vector-data-offset vm:word-bits)
700     ibuf (+ (the index (* start vm:byte-bits))
701     (* vm:vector-data-offset vm:word-bits))
702     (* count vm:byte-bits)))
703 dtc 1.30 (setf (lisp-stream-in-index stream) (1+ start))
704 ram 1.18 (aref ibuf start)))))
705    
706 ram 1.1
707     ;;; Output functions:
708    
709     (defun write-char (character &optional (stream *standard-output*))
710     "Outputs the Character to the Stream."
711 toy 1.52 (declare (type streamlike stream))
712 toy 1.61 (let ((stream (out-synonym-of stream)))
713     (stream-dispatch stream
714     ;; simple-stream
715 toy 1.62 (stream::%write-char stream character)
716 toy 1.61 ;; lisp-stream
717     (funcall (lisp-stream-out stream) stream character)
718     ;; fundamental-stream
719     (stream-write-char stream character)))
720 ram 1.1 character)
721    
722     (defun terpri (&optional (stream *standard-output*))
723     "Outputs a new line to the Stream."
724 toy 1.52 (declare (type streamlike stream))
725 toy 1.61 (let ((stream (out-synonym-of stream)))
726     (stream-dispatch stream
727     ;; simple-stream
728     (stream::%write-char stream #\Newline)
729     ;; lisp-stream
730     (funcall (lisp-stream-out stream) stream #\Newline)
731     ;; fundamental-stream
732     (stream-terpri stream)))
733 ram 1.1 nil)
734    
735     (defun fresh-line (&optional (stream *standard-output*))
736 toy 1.61 "Outputs a new line to the Stream if it is not positioned at the beginning of
737 ram 1.1 a line. Returns T if it output a new line, nil otherwise."
738 toy 1.52 (declare (type streamlike stream))
739 dtc 1.32 (let ((stream (out-synonym-of stream)))
740 toy 1.61 (stream-dispatch stream
741     ;; simple-stream
742     (stream::%fresh-line stream)
743     ;; lisp-stream
744     (when (/= (or (charpos stream) 1) 0)
745     (funcall (lisp-stream-out stream) stream #\newline)
746     t)
747     ;; fundamental-stream
748     (stream-fresh-line stream))))
749 ram 1.1
750     (defun write-string (string &optional (stream *standard-output*)
751 toy 1.50 &key (start 0) end)
752 ram 1.1 "Outputs the String to the given Stream."
753 toy 1.50 (write-string* string stream start (or end (length (the vector string)))))
754 ram 1.1
755     (defun write-string* (string &optional (stream *standard-output*)
756     (start 0) (end (length (the vector string))))
757 toy 1.61 (declare (type streamlike stream) (fixnum start end))
758 dtc 1.32 (let ((stream (out-synonym-of stream)))
759 toy 1.61 (stream-dispatch stream
760     ;; simple-stream
761 toy 1.62 (if (array-header-p string)
762     (with-array-data ((data string) (offset-start start)
763     (offset-end end))
764     (stream::%write-string stream data offset-start offset-end))
765     (stream::%write-string stream string start end))
766     ;; lisp-stream
767     (if (array-header-p string)
768     (with-array-data ((data string) (offset-start start)
769     (offset-end end))
770     (funcall (lisp-stream-sout stream)
771     stream data offset-start offset-end))
772     (funcall (lisp-stream-sout stream) stream string start end))
773 toy 1.61 ;; fundamental-stream
774 toy 1.62 (stream-write-string stream string start end)))
775     string)
776 ram 1.1
777     (defun write-line (string &optional (stream *standard-output*)
778     &key (start 0) (end (length string)))
779     "Outputs the String to the given Stream, followed by a newline character."
780 toy 1.67 (write-line* string stream start (or end (length string))))
781 ram 1.1
782     (defun write-line* (string &optional (stream *standard-output*)
783     (start 0) (end (length string)))
784 toy 1.61 (declare (type streamlike stream) (fixnum start end))
785 dtc 1.32 (let ((stream (out-synonym-of stream)))
786 toy 1.61 (stream-dispatch stream
787     ;; simple-stream
788     (progn
789     (if (array-header-p string)
790     (with-array-data ((data string) (offset-start start)
791     (offset-end end))
792     (stream::%write-string stream data offset-start offset-end))
793     (stream::%write-string stream string start end))
794     (stream::%write-char stream #\Newline))
795     ;; lisp-stream
796     (progn
797     (if (array-header-p string)
798     (with-array-data ((data string) (offset-start start)
799     (offset-end end))
800     (funcall (lisp-stream-sout stream) stream data offset-start
801     offset-end))
802     (funcall (lisp-stream-sout stream) stream string start end))
803     (funcall (lisp-stream-out stream) stream #\newline))
804     ;; fundamental-stream
805     (progn
806     (stream-write-string stream string start end)
807     (stream-write-char stream #\Newline)))
808 dtc 1.30 string))
809 ram 1.1
810     (defun charpos (&optional (stream *standard-output*))
811     "Returns the number of characters on the current line of output of the given
812     Stream, or Nil if that information is not availible."
813 toy 1.61 (declare (type streamlike stream))
814     (let ((stream (out-synonym-of stream)))
815     (stream-dispatch stream
816     ;; simple-stream
817     (stream::%charpos stream)
818     ;; lisp-stream
819     (funcall (lisp-stream-misc stream) stream :charpos)
820     ;; fundamental-stream
821     (stream-line-column stream))))
822 ram 1.1
823     (defun line-length (&optional (stream *standard-output*))
824     "Returns the number of characters that will fit on a line of output on the
825     given Stream, or Nil if that information is not available."
826 toy 1.61 (declare (type streamlike stream))
827     (let ((stream (out-synonym-of stream)))
828     (stream-dispatch stream
829     ;; simple-stream
830     (stream::%line-length stream)
831     ;; lisp-stream
832     (funcall (lisp-stream-misc stream) stream :line-length)
833     ;; fundamental-stream
834     (stream-line-length stream))))
835 ram 1.1
836     (defun finish-output (&optional (stream *standard-output*))
837 dtc 1.28 "Attempts to ensure that all output sent to the Stream has reached its
838 ram 1.1 destination, and only then returns."
839 toy 1.52 (declare (type streamlike stream))
840 toy 1.61 (let ((stream (out-synonym-of stream)))
841     (stream-dispatch stream
842     ;; simple-stream
843     (stream::%finish-output stream)
844     ;; lisp-stream
845     (funcall (lisp-stream-misc stream) stream :finish-output)
846     ;; fundamental-stream
847     (stream-finish-output stream)))
848 ram 1.1 nil)
849    
850     (defun force-output (&optional (stream *standard-output*))
851     "Attempts to force any buffered output to be sent."
852 toy 1.52 (declare (type streamlike stream))
853 toy 1.61 (let ((stream (out-synonym-of stream)))
854     (stream-dispatch stream
855     ;; simple-stream
856     (stream::%force-output stream)
857     ;; lisp-stream-misc
858     (funcall (lisp-stream-misc stream) stream :force-output)
859     ;; fundamental-stream
860     (stream-force-output stream)))
861 ram 1.1 nil)
862    
863     (defun clear-output (&optional (stream *standard-output*))
864     "Clears the given output Stream."
865 toy 1.52 (declare (type streamlike stream))
866 toy 1.61 (let ((stream (out-synonym-of stream)))
867     (stream-dispatch stream
868     ;; simple-stream
869     (stream::%clear-output stream)
870     ;; lisp-stream
871     (funcall (lisp-stream-misc stream) stream :clear-output)
872     ;; fundamental-stream
873     (stream-force-output stream)))
874 ram 1.1 nil)
875    
876     (defun write-byte (integer stream)
877     "Outputs the Integer to the binary Stream."
878 toy 1.52 (declare (type stream stream))
879 toy 1.61 (let ((stream (out-synonym-of stream)))
880     (stream-dispatch stream
881     ;; simple-stream
882     (stream::%write-byte stream integer)
883     ;; lisp-stream
884     (funcall (lisp-stream-bout stream) stream integer)
885     ;; fundamental-stream
886     (stream-write-byte stream integer)))
887 ram 1.1 integer)
888    
889 dtc 1.33
890     ;;; Stream-misc-dispatch
891     ;;;
892 toy 1.61 ;;; Called from lisp-stream routines that encapsulate CLOS streams to
893 dtc 1.33 ;;; handle the misc routines and dispatch to the appropriate Gray
894     ;;; stream functions.
895     ;;;
896     (defun stream-misc-dispatch (stream operation &optional arg1 arg2)
897     (declare (type fundamental-stream stream)
898     (ignore arg2))
899     (case operation
900     (:listen
901     ;; Return true is input available, :eof for eof-of-file, otherwise Nil.
902     (let ((char (stream-read-char-no-hang stream)))
903     (when (characterp char)
904     (stream-unread-char stream char))
905     char))
906     (:unread
907     (stream-unread-char stream arg1))
908     (:close
909     (close stream))
910     (:clear-input
911     (stream-clear-input stream))
912     (:force-output
913     (stream-force-output stream))
914     (:finish-output
915     (stream-finish-output stream))
916     (:element-type
917     (stream-element-type stream))
918     (:interactive-p
919     (interactive-stream-p stream))
920     (:line-length
921     (stream-line-length stream))
922     (:charpos
923     (stream-line-column stream))
924     (:file-length
925     (file-length stream))
926     (:file-position
927     (file-position stream arg1))))
928    
929    
930 ram 1.1 ;;;; Broadcast streams:
931    
932 dtc 1.30 (defstruct (broadcast-stream (:include lisp-stream
933 ram 1.1 (out #'broadcast-out)
934     (bout #'broadcast-bout)
935     (sout #'broadcast-sout)
936     (misc #'broadcast-misc))
937     (:print-function %print-broadcast-stream)
938 toy 1.52 (:constructor %make-broadcast-stream (&rest streams)))
939 ram 1.1 ;; This is a list of all the streams we broadcast to.
940 ram 1.14 (streams () :type list :read-only t))
941 ram 1.1
942 toy 1.52 (defun make-broadcast-stream (&rest streams)
943     "Returns an output stream which sends its output to all of the given
944     streams."
945     (dolist (s streams)
946     (unless (output-stream-p s)
947     (ill-out-any s)))
948    
949     (apply #'%make-broadcast-stream streams))
950 ram 1.1
951     (defun %print-broadcast-stream (s stream d)
952     (declare (ignore s d))
953     (write-string "#<Broadcast Stream>" stream))
954    
955 dtc 1.33 (macrolet ((out-fun (fun method stream-method &rest args)
956 ram 1.1 `(defun ,fun (stream ,@args)
957     (dolist (stream (broadcast-stream-streams stream))
958 toy 1.61 (stream-dispatch stream
959     ;; simple-stream
960     (,stream-method stream ,@args) ; use gray-compat for now
961     ;; lisp-stream
962     (funcall (,method stream) stream ,@args)
963     ;; fundamental-stream
964     (,stream-method stream ,@args))))))
965 dtc 1.33 (out-fun broadcast-out lisp-stream-out stream-write-char char)
966     (out-fun broadcast-bout lisp-stream-bout stream-write-byte byte)
967     (out-fun broadcast-sout lisp-stream-sout stream-write-string
968     string start end))
969 ram 1.1
970     (defun broadcast-misc (stream operation &optional arg1 arg2)
971     (let ((streams (broadcast-stream-streams stream)))
972     (case operation
973     (:charpos
974 emarsden 1.70 (dolist (stream streams 0)
975 dtc 1.33 (let ((charpos (charpos stream)))
976 ram 1.1 (if charpos (return charpos)))))
977     (:line-length
978     (let ((min nil))
979     (dolist (stream streams min)
980 dtc 1.33 (let ((res (line-length stream)))
981 ram 1.1 (when res (setq min (if min (min res min) res)))))))
982 emarsden 1.71 ;; CLHS: The functions file-length, file-position, file-string-length, and
983     ;; stream-external-format return the value from the last component
984     ;; stream; if there are no component streams, file-length and
985     ;; file-position return 0, file-string-length returns 1, and
986     ;; stream-external-format returns :default.
987     (:file-length
988     (if (null streams) 0
989 emarsden 1.73 (file-length (first (last streams)))))
990 emarsden 1.71 (:file-position
991     (if (null streams) 0
992 emarsden 1.73 (file-position (first (last streams)))))
993 ram 1.1 (:element-type
994 emarsden 1.70 #+nil ; old, arguably more logical, version
995 ram 1.1 (let (res)
996 emarsden 1.69 (dolist (stream streams (if (> (length res) 1) `(and ,@res) t))
997 emarsden 1.70 (pushnew (stream-element-type stream) res :test #'equal)))
998     ;; ANSI-specified version (under System Class BROADCAST-STREAM)
999     (let ((res t))
1000     (do ((streams streams (cdr streams)))
1001     ((null streams) res)
1002     (when (null (cdr streams))
1003     (setq res (stream-element-type (car streams)))))))
1004 wlott 1.25 (:close)
1005 ram 1.1 (t
1006     (let ((res nil))
1007     (dolist (stream streams res)
1008 dtc 1.33 (setq res
1009     (if (lisp-stream-p stream)
1010     (funcall (lisp-stream-misc stream) stream operation
1011     arg1 arg2)
1012     (stream-misc-dispatch stream operation arg1 arg2)))))))))
1013    
1014 ram 1.1
1015     ;;;; Synonym Streams:
1016    
1017 dtc 1.30 (defstruct (synonym-stream (:include lisp-stream
1018 ram 1.1 (in #'synonym-in)
1019     (bin #'synonym-bin)
1020     (n-bin #'synonym-n-bin)
1021     (out #'synonym-out)
1022     (bout #'synonym-bout)
1023     (sout #'synonym-sout)
1024     (misc #'synonym-misc))
1025     (:print-function %print-synonym-stream)
1026     (:constructor make-synonym-stream (symbol)))
1027     ;; This is the symbol, the value of which is the stream we are synonym to.
1028 wlott 1.15 (symbol nil :type symbol :read-only t))
1029 ram 1.1
1030     (defun %print-synonym-stream (s stream d)
1031     (declare (ignore d))
1032     (format stream "#<Synonym Stream to ~S>" (synonym-stream-symbol s)))
1033    
1034     (setf (documentation 'make-synonym-stream 'function)
1035     "Returns a stream which performs its operations on the stream which is the
1036     value of the dynamic variable named by Symbol.")
1037    
1038     ;;; The output simple output methods just call the corresponding method
1039     ;;; in the synonymed stream.
1040     ;;;
1041 dtc 1.33 (macrolet ((out-fun (name slot stream-method &rest args)
1042 ram 1.1 `(defun ,name (stream ,@args)
1043 ram 1.11 (declare (optimize (safety 1)))
1044 ram 1.1 (let ((syn (symbol-value (synonym-stream-symbol stream))))
1045 dtc 1.33 (if (lisp-stream-p syn)
1046     (funcall (,slot syn) syn ,@args)
1047     (,stream-method syn ,@args))))))
1048     (out-fun synonym-out lisp-stream-out stream-write-char ch)
1049     (out-fun synonym-bout lisp-stream-bout stream-write-byte n)
1050     (out-fun synonym-sout lisp-stream-sout stream-write-string string start end))
1051 ram 1.1
1052    
1053     ;;; Bind synonym stream to this so that SPIO can turn on the right frob in
1054     ;;; the icon when we are in a terminal input wait.
1055     ;;;
1056     (defvar *previous-stream* nil)
1057    
1058     ;;; For the input methods, we just call the corresponding function on the
1059     ;;; synonymed stream. These functions deal with getting input out of
1060     ;;; the In-Buffer if there is any.
1061     ;;;
1062     (macrolet ((in-fun (name fun &rest args)
1063     `(defun ,name (stream ,@args)
1064 ram 1.11 (declare (optimize (safety 1)))
1065 ram 1.1 (let ((*previous-stream* stream))
1066     (,fun (symbol-value (synonym-stream-symbol stream)) ,@args)))))
1067     (in-fun synonym-in read-char eof-errorp eof-value)
1068     (in-fun synonym-bin read-byte eof-errorp eof-value)
1069     (in-fun synonym-n-bin read-n-bytes buffer start numbytes eof-errorp))
1070    
1071    
1072     ;;; Synonym-Misc -- Internal
1073     ;;;
1074     ;;; We have to special-case the operations which could look at stuff in
1075     ;;; the in-buffer.
1076     ;;;
1077     (defun synonym-misc (stream operation &optional arg1 arg2)
1078 ram 1.11 (declare (optimize (safety 1)))
1079 ram 1.1 (let ((syn (symbol-value (synonym-stream-symbol stream)))
1080     (*previous-stream* stream))
1081 dtc 1.33 (if (lisp-stream-p syn)
1082     (case operation
1083     (:listen (or (/= (the fixnum (lisp-stream-in-index syn))
1084     in-buffer-length)
1085     (funcall (lisp-stream-misc syn) syn :listen)))
1086 dtc 1.42 (:clear-input (clear-input syn))
1087     (:unread (unread-char arg1 syn))
1088 dtc 1.33 (t
1089     (funcall (lisp-stream-misc syn) syn operation arg1 arg2)))
1090     (stream-misc-dispatch syn operation arg1 arg2))))
1091 ram 1.1
1092     ;;;; Two-Way streams:
1093    
1094     (defstruct (two-way-stream
1095 dtc 1.30 (:include lisp-stream
1096 ram 1.1 (in #'two-way-in)
1097     (bin #'two-way-bin)
1098     (n-bin #'two-way-n-bin)
1099     (out #'two-way-out)
1100     (bout #'two-way-bout)
1101     (sout #'two-way-sout)
1102     (misc #'two-way-misc))
1103     (:print-function %print-two-way-stream)
1104 toy 1.52 (:constructor %make-two-way-stream (input-stream output-stream)))
1105 ram 1.1 ;; We read from this stream...
1106 ram 1.14 (input-stream (required-argument) :type stream :read-only t)
1107 ram 1.1 ;; And write to this one
1108 ram 1.14 (output-stream (required-argument) :type stream :read-only t))
1109 ram 1.1
1110     (defun %print-two-way-stream (s stream d)
1111     (declare (ignore d))
1112     (format stream "#<Two-Way Stream, Input = ~S, Output = ~S>"
1113     (two-way-stream-input-stream s)
1114     (two-way-stream-output-stream s)))
1115    
1116 toy 1.52 (defun make-two-way-stream (input-stream output-stream)
1117 ram 1.1 "Returns a bidirectional stream which gets its input from Input-Stream and
1118 toy 1.52 sends its output to Output-Stream."
1119     (unless (input-stream-p input-stream)
1120     (ill-in-any input-stream))
1121     (unless (output-stream-p output-stream)
1122     (ill-out-any output-stream))
1123    
1124     (%make-two-way-stream input-stream output-stream))
1125 ram 1.1
1126 dtc 1.33 (macrolet ((out-fun (name slot stream-method &rest args)
1127 ram 1.1 `(defun ,name (stream ,@args)
1128     (let ((syn (two-way-stream-output-stream stream)))
1129 dtc 1.33 (if (lisp-stream-p syn)
1130     (funcall (,slot syn) syn ,@args)
1131     (,stream-method syn ,@args))))))
1132     (out-fun two-way-out lisp-stream-out stream-write-char ch)
1133     (out-fun two-way-bout lisp-stream-bout stream-write-byte n)
1134     (out-fun two-way-sout lisp-stream-sout stream-write-string string start end))
1135 ram 1.1
1136     (macrolet ((in-fun (name fun &rest args)
1137     `(defun ,name (stream ,@args)
1138 ram 1.10 (force-output (two-way-stream-output-stream stream))
1139 ram 1.1 (,fun (two-way-stream-input-stream stream) ,@args))))
1140     (in-fun two-way-in read-char eof-errorp eof-value)
1141     (in-fun two-way-bin read-byte eof-errorp eof-value)
1142     (in-fun two-way-n-bin read-n-bytes buffer start numbytes eof-errorp))
1143    
1144     (defun two-way-misc (stream operation &optional arg1 arg2)
1145     (let* ((in (two-way-stream-input-stream stream))
1146     (out (two-way-stream-output-stream stream))
1147 dtc 1.33 (in-lisp-stream-p (lisp-stream-p in))
1148     (out-lisp-stream-p (lisp-stream-p out)))
1149 ram 1.1 (case operation
1150 dtc 1.33 (:listen
1151     (if in-lisp-stream-p
1152     (or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length)
1153     (funcall (lisp-stream-misc in) in :listen))
1154     (stream-listen in)))
1155 ram 1.1 ((:finish-output :force-output :clear-output)
1156 dtc 1.33 (if out-lisp-stream-p
1157     (funcall (lisp-stream-misc out) out operation arg1 arg2)
1158     (stream-misc-dispatch out operation arg1 arg2)))
1159 dtc 1.42 (:clear-input (clear-input in))
1160     (:unread (unread-char arg1 in))
1161 ram 1.1 (:element-type
1162 dtc 1.33 (let ((in-type (stream-element-type in))
1163     (out-type (stream-element-type out)))
1164 ram 1.1 (if (equal in-type out-type)
1165     in-type `(and ,in-type ,out-type))))
1166 dtc 1.33 (:close
1167 ram 1.1 (set-closed-flame stream))
1168 rtoy 1.74 (:file-length
1169     (error 'type-error :datum stream :expected-type 'file-stream))
1170 rtoy 1.79 (:charpos
1171     (charpos out))
1172     (:line-length
1173     (line-length out))
1174 ram 1.1 (t
1175 dtc 1.33 (or (if in-lisp-stream-p
1176     (funcall (lisp-stream-misc in) in operation arg1 arg2)
1177     (stream-misc-dispatch in operation arg1 arg2))
1178     (if out-lisp-stream-p
1179     (funcall (lisp-stream-misc out) out operation arg1 arg2)
1180     (stream-misc-dispatch out operation arg1 arg2)))))))
1181    
1182 ram 1.1
1183     ;;;; Concatenated Streams:
1184    
1185     (defstruct (concatenated-stream
1186 dtc 1.30 (:include lisp-stream
1187 ram 1.1 (in #'concatenated-in)
1188     (bin #'concatenated-bin)
1189 pw 1.46 (n-bin #'concatenated-n-bin)
1190 ram 1.1 (misc #'concatenated-misc))
1191     (:print-function %print-concatenated-stream)
1192 toy 1.52 (:constructor %make-concatenated-stream (&rest streams)))
1193 dtc 1.40 ;; This is a list of all the streams. The car of this is the stream
1194     ;; we are reading from now.
1195     (streams nil :type list))
1196 ram 1.1
1197     (defun %print-concatenated-stream (s stream d)
1198     (declare (ignore d))
1199     (format stream "#<Concatenated Stream, Streams = ~S>"
1200     (concatenated-stream-streams s)))
1201    
1202 toy 1.52 (defun make-concatenated-stream (&rest streams)
1203 ram 1.1 "Returns a stream which takes its input from each of the Streams in turn,
1204 toy 1.52 going on to the next at EOF."
1205     (dolist (s streams)
1206     (unless (input-stream-p s)
1207     (ill-in-any s)))
1208     (apply #'%make-concatenated-stream streams))
1209 ram 1.1
1210     (macrolet ((in-fun (name fun)
1211     `(defun ,name (stream eof-errorp eof-value)
1212 dtc 1.40 (do ((current (concatenated-stream-streams stream)
1213     (cdr current)))
1214 ram 1.1 ((null current)
1215     (eof-or-lose stream eof-errorp eof-value))
1216     (let* ((stream (car current))
1217     (result (,fun stream nil nil)))
1218     (when result (return result)))
1219 dtc 1.40 (setf (concatenated-stream-streams stream) (cdr current))))))
1220 ram 1.1 (in-fun concatenated-in read-char)
1221     (in-fun concatenated-bin read-byte))
1222 pw 1.46
1223     (defun concatenated-n-bin (stream buffer start numbytes eof-errorp)
1224     (do ((current (concatenated-stream-streams stream) (cdr current))
1225     (current-start start)
1226     (remaining-bytes numbytes))
1227     ((null current)
1228     (if eof-errorp
1229     (error 'end-of-file :stream stream)
1230     (- numbytes remaining-bytes)))
1231     (let* ((stream (car current))
1232     (bytes-read (read-n-bytes stream buffer current-start
1233     remaining-bytes nil)))
1234     (incf current-start bytes-read)
1235     (decf remaining-bytes bytes-read)
1236     (when (zerop remaining-bytes) (return numbytes)))
1237     (setf (concatenated-stream-streams stream) (cdr current))))
1238 ram 1.1
1239     (defun concatenated-misc (stream operation &optional arg1 arg2)
1240 emarsden 1.72 (let ((current (first (concatenated-stream-streams stream))))
1241     (case operation
1242     (:listen
1243     (if current
1244     (loop
1245     (let ((stuff (if (lisp-stream-p current)
1246     (funcall (lisp-stream-misc current) current
1247     :listen)
1248     (stream-misc-dispatch current :listen))))
1249     (cond ((eq stuff :eof)
1250     ;; Advance current, and try again.
1251     (pop (concatenated-stream-streams stream))
1252     (setf current (first (concatenated-stream-streams stream)))
1253     (unless current (return :eof)))
1254     (stuff
1255     ;; Stuff's available.
1256     (return t))
1257     (t
1258     ;; Nothing available yet.
1259     (return nil)))))
1260     :eof))
1261     (:close
1262     (set-closed-flame stream))
1263     (:clear-input
1264     (when current (clear-input current)))
1265     (:unread
1266     (when current (unread-char arg1 current)))
1267 rtoy 1.74 (:file-length
1268     (error 'type-error :datum stream :expected-type 'file-stream))
1269 emarsden 1.72 (t
1270     (if (lisp-stream-p current)
1271     (funcall (lisp-stream-misc current) current operation arg1 arg2)
1272     (stream-misc-dispatch current operation arg1 arg2))))))
1273 dtc 1.33
1274 ram 1.1
1275     ;;;; Echo Streams:
1276    
1277     (defstruct (echo-stream
1278     (:include two-way-stream
1279     (in #'echo-in)
1280     (bin #'echo-bin)
1281     (misc #'echo-misc)
1282 rtoy 1.76 (n-bin #'echo-n-bin))
1283 ram 1.1 (:print-function %print-echo-stream)
1284 toy 1.52 (:constructor %make-echo-stream (input-stream output-stream)))
1285 wlott 1.8 unread-stuff)
1286 ram 1.1
1287 toy 1.52 (defun make-echo-stream (input-stream output-stream)
1288     "Returns an echo stream that takes input from Input-stream and sends
1289     output to Output-stream"
1290     (unless (input-stream-p input-stream)
1291     (ill-in-any input-stream))
1292     (unless (output-stream-p output-stream)
1293     (ill-out-any output-stream))
1294     (%make-echo-stream input-stream output-stream))
1295 ram 1.1
1296 dtc 1.38 (macrolet ((in-fun (name fun out-slot stream-method)
1297     `(defun ,name (stream eof-errorp eof-value)
1298 wlott 1.8 (or (pop (echo-stream-unread-stuff stream))
1299     (let* ((in (echo-stream-input-stream stream))
1300     (out (echo-stream-output-stream stream))
1301 dtc 1.38 (result (,fun in nil :eof)))
1302     (cond ((eq result :eof)
1303     (eof-or-lose stream eof-errorp eof-value))
1304     (t
1305     (if (lisp-stream-p out)
1306     (funcall (,out-slot out) out result)
1307     (,stream-method out result))
1308     result)))))))
1309     (in-fun echo-in read-char lisp-stream-out stream-write-char)
1310     (in-fun echo-bin read-byte lisp-stream-bout stream-write-byte))
1311 ram 1.1
1312 toy 1.56
1313 ram 1.1 (defun echo-misc (stream operation &optional arg1 arg2)
1314     (let* ((in (two-way-stream-input-stream stream))
1315 dtc 1.33 (out (two-way-stream-output-stream stream)))
1316 ram 1.1 (case operation
1317 dtc 1.33 (:listen
1318     (or (not (null (echo-stream-unread-stuff stream)))
1319     (if (lisp-stream-p in)
1320     (or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length)
1321     (funcall (lisp-stream-misc in) in :listen))
1322     (stream-misc-dispatch in :listen))))
1323 wlott 1.8 (:unread (push arg1 (echo-stream-unread-stuff stream)))
1324 ram 1.1 (:element-type
1325 dtc 1.33 (let ((in-type (stream-element-type in))
1326     (out-type (stream-element-type out)))
1327 ram 1.1 (if (equal in-type out-type)
1328     in-type `(and ,in-type ,out-type))))
1329     (:close
1330     (set-closed-flame stream))
1331 toy 1.56 (:peek-char
1332     ;; For the special case of peeking into an echo-stream
1333     ;; arg1 is peek-type, arg2 is (eof-errorp eof-value)
1334     ;; returns peeked-char, eof-value, or errors end-of-file
1335     (let ((unread-char-p nil))
1336     (destructuring-bind (eof-errorp eof-value)
1337     arg2
1338     (flet ((outfn (c)
1339     (unless unread-char-p
1340     (if (lisp-stream-p out)
1341     (funcall (lisp-stream-out out) out c)
1342     ;; gray-stream
1343     (stream-write-char out c))))
1344     (infn ()
1345     ;; Obtain input from unread buffer or input stream,
1346     ;; and set the flag appropriately.
1347     (cond ((not (null (echo-stream-unread-stuff stream)))
1348     (setf unread-char-p t)
1349     (pop (echo-stream-unread-stuff stream)))
1350     (t
1351     (setf unread-char-p nil)
1352 rtoy 1.80 (read-char in eof-errorp :eof)))))
1353 toy 1.56 (generalized-peeking-mechanism
1354     arg1 eof-value char
1355     (infn)
1356 rtoy 1.80 :eof
1357 toy 1.56 (unread-char char in)
1358 rtoy 1.82 :skipped-char-form (outfn char))))))
1359 rtoy 1.74 (:file-length
1360     (error 'type-error :datum stream :expected-type 'file-stream))
1361 ram 1.1 (t
1362 dtc 1.33 (or (if (lisp-stream-p in)
1363     (funcall (lisp-stream-misc in) in operation arg1 arg2)
1364     (stream-misc-dispatch in operation arg1 arg2))
1365     (if (lisp-stream-p out)
1366     (funcall (lisp-stream-misc out) out operation arg1 arg2)
1367     (stream-misc-dispatch out operation arg1 arg2)))))))
1368 rtoy 1.76
1369    
1370     (defun echo-n-bin (stream buffer start numbytes eof-error-p)
1371     (let ((new-start start)
1372     (read 0))
1373     (loop
1374     (let ((thing (pop (echo-stream-unread-stuff stream))))
1375     (cond
1376     (thing
1377     (setf (aref buffer new-start) thing)
1378     (incf new-start)
1379     (incf read)
1380     (when (= read numbytes)
1381     (return-from echo-n-bin numbytes)))
1382     (t (return nil)))))
1383     (let ((bytes-read (read-n-bytes (echo-stream-input-stream stream) buffer
1384     new-start (- numbytes read) nil)))
1385     (cond
1386     ((not eof-error-p)
1387     (write-sequence buffer (echo-stream-output-stream stream)
1388     :start new-start :end (+ new-start bytes-read))
1389     (+ bytes-read read))
1390     ((> numbytes (+ read bytes-read))
1391     (write-sequence buffer (echo-stream-output-stream stream)
1392     :start new-start :end (+ new-start bytes-read))
1393     (error 'end-of-file :stream stream))
1394     (t
1395     (write-sequence buffer (echo-stream-output-stream stream)
1396     :start new-start :end (+ new-start bytes-read))
1397     numbytes)))))
1398 ram 1.1
1399     (defun %print-echo-stream (s stream d)
1400     (declare (ignore d))
1401     (format stream "#<Echo Stream, Input = ~S, Output = ~S>"
1402     (two-way-stream-input-stream s)
1403     (two-way-stream-output-stream s)))
1404    
1405     (setf (documentation 'make-echo-stream 'function)
1406     "Returns a bidirectional stream which gets its input from Input-Stream and
1407     sends its output to Output-Stream. In addition, all input is echoed to
1408     the output stream")
1409    
1410 moore 1.57 ;;;; Superclass of all string streams
1411    
1412     (defstruct (string-stream
1413     (:include lisp-stream)
1414     (:constructor nil)
1415     (:copier nil)))
1416    
1417 ram 1.1 ;;;; String Input Streams:
1418    
1419     (defstruct (string-input-stream
1420 moore 1.57 (:include string-stream
1421 ram 1.21 (in #'string-inch)
1422     (bin #'string-binch)
1423     (n-bin #'string-stream-read-n-bytes)
1424     (misc #'string-in-misc))
1425     (:print-function %print-string-input-stream)
1426     ;(:constructor nil)
1427     (:constructor internal-make-string-input-stream
1428     (string current end)))
1429 ram 1.1 (string nil :type simple-string)
1430 dtc 1.31 (current nil :type index)
1431     (end nil :type index))
1432 ram 1.1
1433     (defun %print-string-input-stream (s stream d)
1434     (declare (ignore s d))
1435     (write-string "#<String-Input Stream>" stream))
1436    
1437     (defun string-inch (stream eof-errorp eof-value)
1438     (let ((string (string-input-stream-string stream))
1439     (index (string-input-stream-current stream)))
1440     (declare (simple-string string) (fixnum index))
1441 dtc 1.31 (cond ((= index (the index (string-input-stream-end stream)))
1442 ram 1.1 (eof-or-lose stream eof-errorp eof-value))
1443     (t
1444     (setf (string-input-stream-current stream) (1+ index))
1445     (aref string index)))))
1446 ram 1.21
1447     (defun string-binch (stream eof-errorp eof-value)
1448     (let ((string (string-input-stream-string stream))
1449     (index (string-input-stream-current stream)))
1450 dtc 1.31 (declare (simple-string string)
1451     (type index index))
1452     (cond ((= index (the index (string-input-stream-end stream)))
1453 ram 1.21 (eof-or-lose stream eof-errorp eof-value))
1454     (t
1455     (setf (string-input-stream-current stream) (1+ index))
1456     (char-code (aref string index))))))
1457    
1458     (defun string-stream-read-n-bytes (stream buffer start requested eof-errorp)
1459     (declare (type string-input-stream stream)
1460     (type index start requested))
1461 dtc 1.31 (let* ((string (string-input-stream-string stream))
1462     (index (string-input-stream-current stream))
1463     (available (- (string-input-stream-end stream) index))
1464     (copy (min available requested)))
1465     (declare (simple-string string)
1466     (type index index available copy))
1467     (when (plusp copy)
1468     (setf (string-input-stream-current stream)
1469     (truly-the index (+ index copy)))
1470     (system:without-gcing
1471     (system-area-copy (vector-sap string)
1472     (* index vm:byte-bits)
1473     (if (typep buffer 'system-area-pointer)
1474     buffer
1475     (vector-sap buffer))
1476     (* start vm:byte-bits)
1477     (* copy vm:byte-bits))))
1478     (if (and (> requested copy) eof-errorp)
1479     (error 'end-of-file :stream stream)
1480     copy)))
1481 ram 1.1
1482     (defun string-in-misc (stream operation &optional arg1 arg2)
1483 ram 1.18 (declare (ignore arg2))
1484 ram 1.1 (case operation
1485 ram 1.2 (:file-position
1486 ram 1.5 (if arg1
1487 rtoy 1.81 (setf (string-input-stream-current stream)
1488     (case arg1
1489     (:start 0)
1490     (:end (length (string-input-stream-string stream)))
1491     (t arg1)))
1492 ram 1.5 (string-input-stream-current stream)))
1493 emarsden 1.69 (:file-length
1494 rtoy 1.74 (error 'type-error :datum stream :expected-type 'file-stream))
1495 ram 1.1 (:unread (decf (string-input-stream-current stream)))
1496 ram 1.10 (:listen (or (/= (the fixnum (string-input-stream-current stream))
1497     (the fixnum (string-input-stream-end stream)))
1498     :eof))
1499 pw 1.27 (:element-type 'base-char)))
1500 ram 1.1
1501     (defun make-string-input-stream (string &optional
1502     (start 0) (end (length string)))
1503     "Returns an input stream which will supply the characters of String between
1504     Start and End in order."
1505 wlott 1.17 (declare (type string string)
1506     (type index start)
1507 ram 1.18 (type (or index null) end))
1508 wlott 1.17 (internal-make-string-input-stream (coerce string 'simple-string)
1509 rtoy 1.75 start (or end (length string))))
1510 ram 1.1
1511     ;;;; String Output Streams:
1512    
1513     (defstruct (string-output-stream
1514 moore 1.57 (:include string-stream
1515 ram 1.1 (out #'string-ouch)
1516     (sout #'string-sout)
1517     (misc #'string-out-misc))
1518     (:print-function %print-string-output-stream)
1519 toy 1.64 (:constructor %make-string-output-stream ()))
1520 ram 1.1 ;; The string we throw stuff in.
1521     (string (make-string 40) :type simple-string)
1522     ;; Index of the next location to use.
1523     (index 0 :type fixnum))
1524    
1525     (defun %print-string-output-stream (s stream d)
1526     (declare (ignore s d))
1527     (write-string "#<String-Output Stream>" stream))
1528    
1529 toy 1.64 (defun make-string-output-stream (&key (element-type 'character))
1530 toy 1.61 "Returns an Output stream which will accumulate all output given to it for
1531 toy 1.64 the benefit of the function Get-Output-Stream-String."
1532     (declare (ignore element-type))
1533     (%make-string-output-stream))
1534 ram 1.1
1535     (defun string-ouch (stream character)
1536     (let ((current (string-output-stream-index stream))
1537     (workspace (string-output-stream-string stream)))
1538     (declare (simple-string workspace) (fixnum current))
1539     (if (= current (the fixnum (length workspace)))
1540     (let ((new-workspace (make-string (* current 2))))
1541 wlott 1.17 (replace new-workspace workspace)
1542 ram 1.1 (setf (aref new-workspace current) character)
1543     (setf (string-output-stream-string stream) new-workspace))
1544     (setf (aref workspace current) character))
1545     (setf (string-output-stream-index stream) (1+ current))))
1546    
1547     (defun string-sout (stream string start end)
1548     (declare (simple-string string) (fixnum start end))
1549     (let* ((current (string-output-stream-index stream))
1550     (length (- end start))
1551     (dst-end (+ length current))
1552     (workspace (string-output-stream-string stream)))
1553     (declare (simple-string workspace)
1554     (fixnum current length dst-end))
1555     (if (> dst-end (the fixnum (length workspace)))
1556     (let ((new-workspace (make-string (+ (* current 2) length))))
1557 wlott 1.17 (replace new-workspace workspace :end2 current)
1558     (replace new-workspace string
1559     :start1 current :end1 dst-end
1560     :start2 start :end2 end)
1561 ram 1.1 (setf (string-output-stream-string stream) new-workspace))
1562 wlott 1.17 (replace workspace string
1563     :start1 current :end1 dst-end
1564     :start2 start :end2 end))
1565 ram 1.1 (setf (string-output-stream-index stream) dst-end)))
1566    
1567     (defun string-out-misc (stream operation &optional arg1 arg2)
1568 ram 1.3 (declare (ignore arg2))
1569 ram 1.1 (case operation
1570 ram 1.2 (:file-position
1571     (if (null arg1)
1572 ram 1.3 (string-output-stream-index stream)))
1573 rtoy 1.74 (:file-length
1574     (error 'type-error :datum stream :expected-type 'file-stream))
1575 ram 1.1 (:charpos
1576     (do ((index (1- (the fixnum (string-output-stream-index stream)))
1577     (1- index))
1578     (count 0 (1+ count))
1579     (string (string-output-stream-string stream)))
1580     ((< index 0) count)
1581     (declare (simple-string string)
1582     (fixnum index count))
1583     (if (char= (schar string index) #\newline)
1584     (return count))))
1585 rtoy 1.75 (:element-type 'base-char)
1586     (:close
1587     (set-closed-flame stream))))
1588 ram 1.1
1589     (defun get-output-stream-string (stream)
1590     "Returns a string of all the characters sent to a stream made by
1591     Make-String-Output-Stream since the last call to this function."
1592 wlott 1.17 (declare (type string-output-stream stream))
1593     (let* ((length (string-output-stream-index stream))
1594     (result (make-string length)))
1595     (replace result (string-output-stream-string stream))
1596     (setf (string-output-stream-index stream) 0)
1597     result))
1598 ram 1.1
1599     (defun dump-output-stream-string (in-stream out-stream)
1600     "Dumps the characters buffer up in the In-Stream to the Out-Stream as
1601     Get-Output-Stream-String would return them."
1602 dtc 1.30 (write-string* (string-output-stream-string in-stream) out-stream
1603     0 (string-output-stream-index in-stream))
1604 ram 1.1 (setf (string-output-stream-index in-stream) 0))
1605    
1606     ;;;; Fill-pointer streams:
1607     ;;;
1608     ;;; Fill pointer string output streams are not explicitly mentioned in
1609     ;;; the CLM, but they are required for the implementation of With-Output-To-String.
1610    
1611     (defstruct (fill-pointer-output-stream
1612 moore 1.57 (:include string-stream
1613 ram 1.1 (out #'fill-pointer-ouch)
1614     (sout #'fill-pointer-sout)
1615     (misc #'fill-pointer-misc))
1616     (:print-function
1617     (lambda (s stream d)
1618     (declare (ignore s d))
1619     (write-string "#<Fill-Pointer String Output Stream>" stream)))
1620     (:constructor make-fill-pointer-output-stream (string)))
1621     ;; The string we throw stuff in.
1622     string)
1623    
1624    
1625     (defun fill-pointer-ouch (stream character)
1626     (let* ((buffer (fill-pointer-output-stream-string stream))
1627 wlott 1.4 (current (fill-pointer buffer))
1628 ram 1.1 (current+1 (1+ current)))
1629     (declare (fixnum current))
1630     (with-array-data ((workspace buffer) (start) (end))
1631     (declare (simple-string workspace))
1632     (let ((offset-current (+ start current)))
1633     (declare (fixnum offset-current))
1634     (if (= offset-current end)
1635 pw 1.48 (let* ((new-length (if (zerop current) 1 (* current 2)))
1636 ram 1.1 (new-workspace (make-string new-length)))
1637     (declare (simple-string new-workspace))
1638 rtoy 1.83.6.1 #-unicode
1639 ram 1.1 (%primitive byte-blt workspace start new-workspace 0 current)
1640 rtoy 1.83.6.1 #+unicode
1641 rtoy 1.83.6.3 (%primitive byte-blt workspace (* 2 start) new-workspace 0 (* 2 current))
1642 ram 1.1 (setf workspace new-workspace)
1643     (setf offset-current current)
1644     (set-array-header buffer workspace new-length
1645     current+1 0 new-length nil))
1646 wlott 1.4 (setf (fill-pointer buffer) current+1))
1647 ram 1.1 (setf (schar workspace offset-current) character)))
1648     current+1))
1649    
1650    
1651     (defun fill-pointer-sout (stream string start end)
1652     (declare (simple-string string) (fixnum start end))
1653     (let* ((buffer (fill-pointer-output-stream-string stream))
1654 wlott 1.4 (current (fill-pointer buffer))
1655 ram 1.1 (string-len (- end start))
1656     (dst-end (+ string-len current)))
1657     (declare (fixnum current dst-end string-len))
1658     (with-array-data ((workspace buffer) (dst-start) (dst-length))
1659     (declare (simple-string workspace))
1660     (let ((offset-dst-end (+ dst-start dst-end))
1661     (offset-current (+ dst-start current)))
1662     (declare (fixnum offset-dst-end offset-current))
1663     (if (> offset-dst-end dst-length)
1664     (let* ((new-length (+ (the fixnum (* current 2)) string-len))
1665     (new-workspace (make-string new-length)))
1666     (declare (simple-string new-workspace))
1667 rtoy 1.83.6.1 #-unicode
1668 ram 1.1 (%primitive byte-blt workspace dst-start new-workspace 0 current)
1669 rtoy 1.83.6.1 #+unicode
1670 rtoy 1.83.6.3 (%primitive byte-blt workspace (* 2 dst-start)
1671     new-workspace 0 (* 2 current))
1672 ram 1.1 (setf workspace new-workspace)
1673     (setf offset-current current)
1674     (setf offset-dst-end dst-end)
1675     (set-array-header buffer workspace new-length
1676     dst-end 0 new-length nil))
1677 wlott 1.4 (setf (fill-pointer buffer) dst-end))
1678 rtoy 1.83.6.1 #-unicode
1679 ram 1.1 (%primitive byte-blt string start
1680 rtoy 1.83.6.1 workspace offset-current offset-dst-end)
1681     #+unicode
1682 rtoy 1.83.6.3 (%primitive byte-blt string (* 2 start)
1683     workspace (* 2 offset-current) (* 2 offset-dst-end))))
1684 ram 1.1 dst-end))
1685    
1686    
1687     (defun fill-pointer-misc (stream operation &optional arg1 arg2)
1688     (declare (ignore arg1 arg2))
1689     (case operation
1690     (:charpos
1691     (let* ((buffer (fill-pointer-output-stream-string stream))
1692 wlott 1.4 (current (fill-pointer buffer)))
1693 ram 1.1 (with-array-data ((string buffer) (start) (end current))
1694     (declare (simple-string string) (ignore start))
1695     (let ((found (position #\newline string :test #'char=
1696     :end end :from-end t)))
1697     (if found
1698     (- end (the fixnum found))
1699     current)))))
1700 pw 1.27 (:element-type 'base-char)))
1701 ram 1.1
1702     ;;;; Indenting streams:
1703    
1704 dtc 1.30 (defstruct (indenting-stream (:include lisp-stream
1705 ram 1.1 (out #'indenting-out)
1706     (sout #'indenting-sout)
1707     (misc #'indenting-misc))
1708     (:print-function %print-indenting-stream)
1709     (:constructor make-indenting-stream (stream)))
1710     ;; The stream we're based on:
1711     stream
1712     ;; How much we indent on each line:
1713     (indentation 0))
1714    
1715     (setf (documentation 'make-indenting-stream 'function)
1716 pw 1.47 "Returns an output stream which indents its output by some amount.")
1717 ram 1.1
1718     (defun %print-indenting-stream (s stream d)
1719     (declare (ignore s d))
1720     (write-string "#<Indenting Stream>" stream))
1721    
1722 toy 1.61 ;;; Indenting-Indent writes the right number of spaces needed to indent
1723     ;;; output on the given Stream based on the specified Sub-Stream.
1724 ram 1.1
1725     (defmacro indenting-indent (stream sub-stream)
1726     `(do ((i 0 (+ i 60))
1727     (indentation (indenting-stream-indentation ,stream)))
1728     ((>= i indentation))
1729 dtc 1.30 (write-string*
1730     " "
1731     ,sub-stream 0 (min 60 (- indentation i)))))
1732 ram 1.1
1733     ;;; Indenting-Out writes a character to an indenting stream.
1734    
1735     (defun indenting-out (stream char)
1736     (let ((sub-stream (indenting-stream-stream stream)))
1737 dtc 1.30 (write-char char sub-stream)
1738 ram 1.1 (if (char= char #\newline)
1739     (indenting-indent stream sub-stream))))
1740    
1741     ;;; Indenting-Sout writes a string to an indenting stream.
1742    
1743     (defun indenting-sout (stream string start end)
1744     (declare (simple-string string) (fixnum start end))
1745     (do ((i start)
1746     (sub-stream (indenting-stream-stream stream)))
1747     ((= i end))
1748     (let ((newline (position #\newline string :start i :end end)))
1749     (cond (newline
1750 dtc 1.30 (write-string* string sub-stream i (1+ newline))
1751 ram 1.1 (indenting-indent stream sub-stream)
1752     (setq i (+ newline 1)))
1753     (t
1754 dtc 1.30 (write-string* string sub-stream i end)
1755 ram 1.1 (setq i end))))))
1756    
1757     ;;; Indenting-Misc just treats just the :Line-Length message differently.
1758     ;;; Indenting-Charpos says the charpos is the charpos of the base stream minus
1759     ;;; the stream's indentation.
1760    
1761     (defun indenting-misc (stream operation &optional arg1 arg2)
1762 dtc 1.30 (let ((sub-stream (indenting-stream-stream stream)))
1763 dtc 1.33 (if (lisp-stream-p sub-stream)
1764     (let ((method (lisp-stream-misc sub-stream)))
1765     (case operation
1766     (:line-length
1767     (let ((line-length (funcall method sub-stream operation)))
1768     (if line-length
1769     (- line-length (indenting-stream-indentation stream)))))
1770     (:charpos
1771     (let ((charpos (funcall method sub-stream operation)))
1772     (if charpos
1773     (- charpos (indenting-stream-indentation stream)))))
1774     (t
1775     (funcall method sub-stream operation arg1 arg2))))
1776     ;; Fundamental-stream.
1777     (case operation
1778     (:line-length
1779     (let ((line-length (stream-line-length sub-stream)))
1780     (if line-length
1781     (- line-length (indenting-stream-indentation stream)))))
1782     (:charpos
1783     (let ((charpos (stream-line-column sub-stream)))
1784     (if charpos
1785     (- charpos (indenting-stream-indentation stream)))))
1786     (t
1787     (stream-misc-dispatch sub-stream operation arg1 arg2))))))
1788 dtc 1.30
1789 ram 1.1
1790 pw 1.45 (declaim (maybe-inline read-char unread-char read-byte listen))
1791 wlott 1.13
1792    
1793    
1794     ;;;; Case frobbing streams, used by format ~(...~).
1795    
1796     (defstruct (case-frob-stream
1797 dtc 1.30 (:include lisp-stream
1798 wlott 1.13 (:misc #'case-frob-misc))
1799     (:constructor %make-case-frob-stream (target out sout)))
1800     (target (required-argument) :type stream))
1801    
1802     (defun make-case-frob-stream (target kind)
1803     "Returns a stream that sends all output to the stream TARGET, but modifies
1804     the case of letters, depending on KIND, which should be one of:
1805     :upcase - convert to upper case.
1806     :downcase - convert to lower case.
1807     :capitalize - convert the first letter of words to upper case and the
1808     rest of the word to lower case.
1809     :capitalize-first - convert the first letter of the first word to upper
1810     case and everything else to lower case."
1811     (declare (type stream target)
1812     (type (member :upcase :downcase :capitalize :capitalize-first)
1813     kind)
1814     (values stream))
1815     (if (case-frob-stream-p target)
1816     ;; If we are going to be writing to a stream that already does case
1817     ;; frobbing, why bother frobbing the case just so it can frob it
1818     ;; again?
1819     target
1820     (multiple-value-bind
1821     (out sout)
1822     (ecase kind
1823     (:upcase
1824     (values #'case-frob-upcase-out
1825     #'case-frob-upcase-sout))
1826     (:downcase
1827     (values #'case-frob-downcase-out
1828     #'case-frob-downcase-sout))
1829     (:capitalize
1830     (values #'case-frob-capitalize-out
1831     #'case-frob-capitalize-sout))
1832     (:capitalize-first
1833     (values #'case-frob-capitalize-first-out
1834     #'case-frob-capitalize-first-sout)))
1835     (%make-case-frob-stream target out sout))))
1836    
1837     (defun case-frob-misc (stream op &optional arg1 arg2)
1838     (declare (type case-frob-stream stream))
1839     (case op
1840     (:close)
1841     (t
1842     (let ((target (case-frob-stream-target stream)))
1843 dtc 1.33 (if (lisp-stream-p target)
1844     (funcall (lisp-stream-misc target) target op arg1 arg2)
1845     (stream-misc-dispatch target op arg1 arg2))))))
1846 wlott 1.13
1847     (defun case-frob-upcase-out (stream char)
1848     (declare (type case-frob-stream stream)
1849 ram 1.16 (type base-char char))
1850 dtc 1.33 (let ((target (case-frob-stream-target stream))
1851     (char (char-upcase char)))
1852     (if (lisp-stream-p target)
1853     (funcall (lisp-stream-out target) target char)
1854     (stream-write-char target char))))
1855 wlott 1.13
1856     (defun case-frob-upcase-sout (stream str start end)
1857     (declare (type case-frob-stream stream)
1858     (type simple-base-string str)
1859     (type index start)
1860     (type (or index null) end))
1861     (let* ((target (case-frob-stream-target stream))
1862     (len (length str))
1863 dtc 1.33 (end (or end len))
1864     (string (if (and (zerop start) (= len end))
1865     (string-upcase str)
1866     (nstring-upcase (subseq str start end))))
1867     (string-len (- end start)))
1868     (if (lisp-stream-p target)
1869     (funcall (lisp-stream-sout target) target string 0 string-len)
1870     (stream-write-string target string 0 string-len))))
1871 wlott 1.13
1872     (defun case-frob-downcase-out (stream char)
1873     (declare (type case-frob-stream stream)
1874 ram 1.16 (type base-char char))
1875 dtc 1.33 (let ((target (case-frob-stream-target stream))
1876     (char (char-downcase char)))
1877     (if (lisp-stream-p target)
1878     (funcall (lisp-stream-out target) target char)
1879     (stream-write-char target char))))
1880 wlott 1.13
1881     (defun case-frob-downcase-sout (stream str start end)
1882     (declare (type case-frob-stream stream)
1883     (type simple-base-string str)
1884     (type index start)
1885     (type (or index null) end))
1886     (let* ((target (case-frob-stream-target stream))
1887     (len (length str))
1888 dtc 1.33 (end (or end len))
1889     (string (if (and (zerop start) (= len end))
1890     (string-downcase str)
1891     (nstring-downcase (subseq str start end))))
1892     (string-len (- end start)))
1893     (if (lisp-stream-p target)
1894     (funcall (lisp-stream-sout target) target string 0 string-len)
1895     (stream-write-string target string 0 string-len))))
1896 wlott 1.13
1897     (defun case-frob-capitalize-out (stream char)
1898     (declare (type case-frob-stream stream)
1899 ram 1.16 (type base-char char))
1900 wlott 1.13 (let ((target (case-frob-stream-target stream)))
1901     (cond ((alphanumericp char)
1902 dtc 1.33 (let ((char (char-upcase char)))
1903     (if (lisp-stream-p target)
1904     (funcall (lisp-stream-out target) target char)
1905     (stream-write-char target char)))
1906     (setf (case-frob-stream-out stream) #'case-frob-capitalize-aux-out)
1907 wlott 1.13 (setf (case-frob-stream-sout stream)
1908     #'case-frob-capitalize-aux-sout))
1909     (t
1910 dtc 1.33 (if (lisp-stream-p target)
1911     (funcall (lisp-stream-out target) target char)
1912     (stream-write-char target char))))))
1913 wlott 1.13
1914     (defun case-frob-capitalize-sout (stream str start end)
1915     (declare (type case-frob-stream stream)
1916     (type simple-base-string str)
1917     (type index start)
1918     (type (or index null) end))
1919     (let* ((target (case-frob-stream-target stream))
1920     (str (subseq str start end))
1921     (len (length str))
1922     (inside-word nil))
1923     (dotimes (i len)
1924     (let ((char (schar str i)))
1925     (cond ((not (alphanumericp char))
1926     (setf inside-word nil))
1927     (inside-word
1928     (setf (schar str i) (char-downcase char)))
1929     (t
1930     (setf inside-word t)
1931     (setf (schar str i) (char-upcase char))))))
1932     (when inside-word
1933     (setf (case-frob-stream-out stream)
1934     #'case-frob-capitalize-aux-out)
1935     (setf (case-frob-stream-sout stream)
1936     #'case-frob-capitalize-aux-sout))
1937 dtc 1.33 (if (lisp-stream-p target)
1938     (funcall (lisp-stream-sout target) target str 0 len)
1939     (stream-write-string target str 0 len))))
1940 wlott 1.13
1941     (defun case-frob-capitalize-aux-out (stream char)
1942     (declare (type case-frob-stream stream)
1943 ram 1.16 (type base-char char))
1944 wlott 1.13 (let ((target (case-frob-stream-target stream)))
1945     (cond ((alphanumericp char)
1946 dtc 1.33 (let ((char (char-downcase char)))
1947     (if (lisp-stream-p target)
1948     (funcall (lisp-stream-out target) target char)
1949     (stream-write-char target char))))
1950 wlott 1.13 (t
1951 dtc 1.33 (if (lisp-stream-p target)
1952     (funcall (lisp-stream-out target) target char)
1953     (stream-write-char target char))
1954 wlott 1.13 (setf (case-frob-stream-out stream)
1955     #'case-frob-capitalize-out)
1956     (setf (case-frob-stream-sout stream)
1957     #'case-frob-capitalize-sout)))))
1958    
1959     (defun case-frob-capitalize-aux-sout (stream str start end)
1960     (declare (type case-frob-stream stream)
1961     (type simple-base-string str)
1962     (type index start)
1963     (type (or index null) end))
1964     (let* ((target (case-frob-stream-target stream))
1965     (str (subseq str start end))
1966     (len (length str))
1967     (inside-word t))
1968     (dotimes (i len)
1969     (let ((char (schar str i)))
1970     (cond ((not (alphanumericp char))
1971     (setf inside-word nil))
1972     (inside-word
1973     (setf (schar str i) (char-downcase char)))
1974     (t
1975     (setf inside-word t)
1976     (setf (schar str i) (char-upcase char))))))
1977     (unless inside-word
1978     (setf (case-frob-stream-out stream)
1979     #'case-frob-capitalize-out)
1980     (setf (case-frob-stream-sout stream)
1981     #'case-frob-capitalize-sout))
1982 dtc 1.33 (if (lisp-stream-p target)
1983     (funcall (lisp-stream-sout target) target str 0 len)
1984     (stream-write-string target str 0 len))))
1985 wlott 1.13
1986     (defun case-frob-capitalize-first-out (stream char)
1987     (declare (type case-frob-stream stream)
1988 ram 1.16 (type base-char char))
1989 wlott 1.13 (let ((target (case-frob-stream-target stream)))
1990     (cond ((alphanumericp char)
1991 dtc 1.33 (let ((char (char-upcase char)))
1992     (if (lisp-stream-p target)
1993     (funcall (lisp-stream-out target) target char)
1994     (stream-write-char target char)))
1995 wlott 1.13 (setf (case-frob-stream-out stream)
1996     #'case-frob-downcase-out)
1997     (setf (case-frob-stream-sout stream)
1998     #'case-frob-downcase-sout))
1999     (t
2000 dtc 1.33 (if (lisp-stream-p target)
2001     (funcall (lisp-stream-out target) target char)
2002     (stream-write-char target char))))))
2003 wlott 1.13
2004     (defun case-frob-capitalize-first-sout (stream str start end)
2005     (declare (type case-frob-stream stream)
2006     (type simple-base-string str)
2007     (type index start)
2008     (type (or index null) end))
2009     (let* ((target (case-frob-stream-target stream))
2010     (str (subseq str start end))
2011     (len (length str)))
2012     (dotimes (i len)
2013     (let ((char (schar str i)))
2014     (when (alphanumericp char)
2015     (setf (schar str i) (char-upcase char))
2016     (do