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

Contents of /src/code/stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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