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

Contents of /src/code/stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.89 - (hide annotations)
Sat Jan 23 18:02:05 2010 UTC (4 years, 2 months ago) by rtoy
Branch: MAIN
CVS Tags: intl-2-branch-base, pre-merge-intl-branch, snapshot-2010-03, snapshot-2010-02, intl-branch-base
Branch point for: intl-branch, intl-2-branch
Changes since 1.88: +5 -52 lines
Oops.  Last change to fd-stream doesn't actually compile because no
everything is defined yet.  Hence, add dummy
%SET-FD-STREAM-EXTERNAL-FORMAT and move the real one to
fd-stream-extfmt.lisp.  This builds.

code/fd-stream.lisp:
o Always call %SET-FD-STREAM-EXTERNAL-FORMAT, even if
  LISP::*ENABLE-STREAM-BUFFER-P* is NIL.

code/stream.lisp:
o Move %SET-FD-STREAM-EXTERNAL-FORMAT to fd-stream-extfmt.lisp.
o Add dummy implementation of %SET-FD-STREAM-EXTERNAL-FORMAT.

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