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

Contents of /src/code/stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.102 - (hide annotations)
Wed Jun 29 00:55:04 2011 UTC (2 years, 9 months ago) by rtoy
Branch: MAIN
CVS Tags: GIT-CONVERSION, snapshot-2011-09, snapshot-2011-07, HEAD
Changes since 1.101: +1 -7 lines
Fix Trac #43 again.

stream.lisp:
o Remove the old code that was the first attempt at fixing issue #43.
  This was wrong.

fd-stream.lisp:
o Fix issue #43.  Even if we have a string-buffer, we need to take
  into account any octets in the in-buffer (if it exists) that have
  not been processed.  This happens if the in-buffer does not have
  enough octets at the end to form a complete character for the given
  encoding.
o Some debugging prints added, but disabled.
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.102 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/stream.lisp,v 1.102 2011/06/29 00:55:04 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.100 ;;; FAST-READ-CHAR-STRING-REFILL -- Interface
727     ;;;
728     ;;; This function is called by the fast-read-char expansion to refill the
729     ;;; string-buffer for text streams. There is definitely a
730     ;;; string-buffer and an in-buffer, which implies there must be an
731     ;;; n-bin method.
732     ;;;
733 rtoy 1.88 #+unicode
734     (defun fast-read-char-string-refill (stream eof-errorp eof-value)
735     ;; Like fast-read-char-refill, but we don't need or want the
736     ;; in-buffer-extra.
737     (let* ((ibuf (lisp-stream-in-buffer stream))
738 rtoy 1.94 (index (lisp-stream-in-index stream))
739     (in-length (fd-stream-in-length stream)))
740     (declare (type (integer 0 #.in-buffer-length) index in-length))
741    
742     #+(or debug-frc-sr)
743     (progn
744     (format t "index = ~A~%" index)
745     (format t "in-length = ~A~%" in-length)
746 rtoy 1.97 (format t "ibuf before = ~A~%" ibuf)
747     (format t "sbuf before = ~S~%" (subseq (lisp-stream-string-buffer stream) 0
748     (lisp-stream-string-buffer-len stream))))
749    
750     ;; For debugging, clear out the stuff we've already read so we can
751     ;; see what's happening.
752     #+(or debug-frc-sr)
753     (fill ibuf 0 :start 0 :end index)
754 rtoy 1.88
755     ;; Copy the stuff we haven't read from in-buffer to the beginning
756     ;; of the buffer.
757 rtoy 1.94 (if (< index in-length)
758     (replace ibuf ibuf
759     :start1 0
760     :start2 index :end2 in-length)
761     (setf index in-length))
762 rtoy 1.97
763     ;; For debugging, clear out the stuff we've already read so we can
764     ;; see what's happening.
765     #+(or debug-frc-sr)
766     (when (< index (1- in-buffer-length))
767     (fill ibuf 0 :start (1+ index) :end in-buffer-length))
768    
769 rtoy 1.94 (setf index (- in-length index))
770    
771     #+(or debug-frc-sr)
772     (format t "ibuf after = ~A~%" ibuf)
773 rtoy 1.88
774 rtoy 1.98 (flet
775     ((get-octets (start)
776     (funcall (lisp-stream-n-bin stream) stream
777     ibuf start
778     (- in-buffer-length start)
779     nil))
780     (handle-eof ()
781     ;; Nothing left in the stream, so update our pointers to
782     ;; indicate we've read everything and call the stream-in
783     ;; function so that we do the right thing for eof.
784     (setf (lisp-stream-in-index stream) in-buffer-length)
785     (setf (lisp-stream-string-index stream)
786     (lisp-stream-string-buffer-len stream))
787     (funcall (lisp-stream-in stream) stream eof-errorp eof-value)))
788     (let ((count (get-octets index)))
789     (declare (type (integer 0 #.in-buffer-length) count))
790    
791     #+(or debug-frc-sr)
792     (progn
793     (format t "count = ~D~%" count)
794     (format t "new ibuf = ~A~%" ibuf))
795 rtoy 1.94
796 rtoy 1.98 (cond ((zerop count)
797     (handle-eof))
798     (t
799     (let ((sbuf (lisp-stream-string-buffer stream))
800     (slen (lisp-stream-string-buffer-len stream)))
801     (declare (simple-string sbuf)
802     (type (integer 0 #.(1+ in-buffer-length)) slen)
803     (optimize (speed 3)))
804    
805 rtoy 1.99 ;; Update in-length. This is needed if we change the
806     ;; external-format of the stream because we need to
807     ;; know how many octets are valid (in case
808     ;; end-of-file was reached)
809 rtoy 1.98 (setf (fd-stream-in-length stream) (+ count index))
810     #+(or debug-frc-sr)
811     (format t "in-length = ~D~%" (fd-stream-in-length stream))
812    
813     #+(or debug-frc-sr)
814     (format t "slen = ~A~%" slen)
815    
816     ;; Copy the last read character to the beginning of the
817     ;; buffer to support unreading.
818     (when (plusp slen)
819     (setf (schar sbuf 0) (schar sbuf (1- slen))))
820    
821     #+(or debug-frc-sr)
822     (progn
823     (format t "sbuf[0] = ~S~%" (schar sbuf 0))
824     (format t "index = ~S~%" index))
825    
826    
827     ;; Convert all the octets, including the ones that we
828     ;; haven't processed yet and the ones we just read in.
829     (flet
830     ((convert-buffer ()
831     (multiple-value-bind (s char-count octet-count new-state)
832     (stream::octets-to-string-counted
833     ibuf
834     (fd-stream-octet-count stream)
835     :start 0
836     :end (fd-stream-in-length stream)
837     :state (fd-stream-oc-state stream)
838     :string sbuf
839     :s-start 1
840     :external-format (fd-stream-external-format stream)
841     :error (fd-stream-octets-to-char-error stream))
842     (declare (ignore s)
843     (type (integer 0 #.in-buffer-length) char-count octet-count))
844 rtoy 1.97 #+(or debug-frc-sr)
845     (progn
846 rtoy 1.98 (format t "char-count = ~A~%" char-count)
847     (format t "octet-count = ~A~%" octet-count)
848     (format t "in-index = ~A~%" (lisp-stream-in-index stream)))
849     (when (> char-count 0)
850     (setf (fd-stream-oc-state stream) new-state)
851     (setf (lisp-stream-string-buffer-len stream) (1+ char-count))
852     (setf (lisp-stream-string-index stream) 2)
853     (setf (lisp-stream-in-index stream) octet-count)
854     #+(or debug-frc-sr)
855     (progn
856     (format t "new in-index = ~A~%" (lisp-stream-in-index stream))
857     (format t "new sbuf = ~S~%"
858     (subseq sbuf 0 (1+ char-count))))
859     (schar sbuf 1)))))
860     (let ((out (convert-buffer)))
861     (or out
862     ;; There weren't enough octets to convert at
863     ;; least one character. Try to read some more
864     ;; octets and try again. (If we still fail,
865     ;; what should we do then? Currently, just
866     ;; just return NIL and let other parts of Lisp
867     ;; catch that.)
868     ;;
869     ;; The in buffer holds unread octets up to
870     ;; index in-length. So start reading octets there.
871     (let* ((index (fd-stream-in-length stream))
872     (count (get-octets index)))
873     (declare (type (integer 0 #.in-buffer-length) count index))
874     (cond ((zerop count)
875     (handle-eof))
876     (t
877     ;; Adjust in-length to the total
878     ;; number of octets that are now in
879     ;; the buffer.
880     (setf (fd-stream-in-length stream) (+ count index))
881     (convert-buffer))))))))))))))
882 ram 1.18
883     ;;; FAST-READ-BYTE-REFILL -- Interface
884     ;;;
885     ;;; Similar to FAST-READ-CHAR-REFILL, but we don't have to leave room for
886     ;;; unreading.
887     ;;;
888     (defun fast-read-byte-refill (stream eof-errorp eof-value)
889 dtc 1.30 (let* ((ibuf (lisp-stream-in-buffer stream))
890     (count (funcall (lisp-stream-n-bin stream) stream
891 ram 1.18 ibuf 0 in-buffer-length
892     nil))
893     (start (- in-buffer-length count)))
894     (declare (type index start count))
895     (cond ((zerop count)
896 dtc 1.30 (setf (lisp-stream-in-index stream) in-buffer-length)
897     (funcall (lisp-stream-bin stream) stream eof-errorp eof-value))
898 ram 1.18 (t
899     (unless (zerop start)
900     (bit-bash-copy ibuf (* vm:vector-data-offset vm:word-bits)
901     ibuf (+ (the index (* start vm:byte-bits))
902     (* vm:vector-data-offset vm:word-bits))
903     (* count vm:byte-bits)))
904 dtc 1.30 (setf (lisp-stream-in-index stream) (1+ start))
905 ram 1.18 (aref ibuf start)))))
906    
907 ram 1.1
908     ;;; Output functions:
909    
910     (defun write-char (character &optional (stream *standard-output*))
911 rtoy 1.91 "Outputs the Character to the Stream."
912 toy 1.52 (declare (type streamlike stream))
913 toy 1.61 (let ((stream (out-synonym-of stream)))
914     (stream-dispatch stream
915     ;; simple-stream
916 toy 1.62 (stream::%write-char stream character)
917 toy 1.61 ;; lisp-stream
918     (funcall (lisp-stream-out stream) stream character)
919     ;; fundamental-stream
920     (stream-write-char stream character)))
921 ram 1.1 character)
922    
923     (defun terpri (&optional (stream *standard-output*))
924 rtoy 1.91 "Outputs a new line to the Stream."
925 toy 1.52 (declare (type streamlike stream))
926 toy 1.61 (let ((stream (out-synonym-of stream)))
927     (stream-dispatch stream
928     ;; simple-stream
929     (stream::%write-char stream #\Newline)
930     ;; lisp-stream
931     (funcall (lisp-stream-out stream) stream #\Newline)
932     ;; fundamental-stream
933     (stream-terpri stream)))
934 ram 1.1 nil)
935    
936     (defun fresh-line (&optional (stream *standard-output*))
937 rtoy 1.91 "Outputs a new line to the Stream if it is not positioned at the beginning of
938 ram 1.1 a line. Returns T if it output a new line, nil otherwise."
939 toy 1.52 (declare (type streamlike stream))
940 dtc 1.32 (let ((stream (out-synonym-of stream)))
941 toy 1.61 (stream-dispatch stream
942     ;; simple-stream
943     (stream::%fresh-line stream)
944     ;; lisp-stream
945     (when (/= (or (charpos stream) 1) 0)
946     (funcall (lisp-stream-out stream) stream #\newline)
947     t)
948     ;; fundamental-stream
949     (stream-fresh-line stream))))
950 ram 1.1
951     (defun write-string (string &optional (stream *standard-output*)
952 toy 1.50 &key (start 0) end)
953 rtoy 1.91 "Outputs the String to the given Stream."
954 toy 1.50 (write-string* string stream start (or end (length (the vector string)))))
955 ram 1.1
956     (defun write-string* (string &optional (stream *standard-output*)
957     (start 0) (end (length (the vector string))))
958 toy 1.61 (declare (type streamlike stream) (fixnum start end))
959 dtc 1.32 (let ((stream (out-synonym-of stream)))
960 toy 1.61 (stream-dispatch stream
961     ;; simple-stream
962 toy 1.62 (if (array-header-p string)
963     (with-array-data ((data string) (offset-start start)
964     (offset-end end))
965     (stream::%write-string stream data offset-start offset-end))
966     (stream::%write-string stream string start end))
967     ;; lisp-stream
968     (if (array-header-p string)
969     (with-array-data ((data string) (offset-start start)
970     (offset-end end))
971     (funcall (lisp-stream-sout stream)
972     stream data offset-start offset-end))
973     (funcall (lisp-stream-sout stream) stream string start end))
974 toy 1.61 ;; fundamental-stream
975 toy 1.62 (stream-write-string stream string start end)))
976     string)
977 ram 1.1
978     (defun write-line (string &optional (stream *standard-output*)
979     &key (start 0) (end (length string)))
980 rtoy 1.91 "Outputs the String to the given Stream, followed by a newline character."
981 toy 1.67 (write-line* string stream start (or end (length string))))
982 ram 1.1
983     (defun write-line* (string &optional (stream *standard-output*)
984     (start 0) (end (length string)))
985 toy 1.61 (declare (type streamlike stream) (fixnum start end))
986 dtc 1.32 (let ((stream (out-synonym-of stream)))
987 toy 1.61 (stream-dispatch stream
988     ;; simple-stream
989     (progn
990     (if (array-header-p string)
991     (with-array-data ((data string) (offset-start start)
992     (offset-end end))
993     (stream::%write-string stream data offset-start offset-end))
994     (stream::%write-string stream string start end))
995     (stream::%write-char stream #\Newline))
996     ;; lisp-stream
997     (progn
998     (if (array-header-p string)
999     (with-array-data ((data string) (offset-start start)
1000     (offset-end end))
1001     (funcall (lisp-stream-sout stream) stream data offset-start
1002     offset-end))
1003     (funcall (lisp-stream-sout stream) stream string start end))
1004     (funcall (lisp-stream-out stream) stream #\newline))
1005     ;; fundamental-stream
1006     (progn
1007     (stream-write-string stream string start end)
1008     (stream-write-char stream #\Newline)))
1009 dtc 1.30 string))
1010 ram 1.1
1011     (defun charpos (&optional (stream *standard-output*))
1012 rtoy 1.91 "Returns the number of characters on the current line of output of the given
1013 ram 1.1 Stream, or Nil if that information is not availible."
1014 toy 1.61 (declare (type streamlike stream))
1015     (let ((stream (out-synonym-of stream)))
1016     (stream-dispatch stream
1017     ;; simple-stream
1018     (stream::%charpos stream)
1019     ;; lisp-stream
1020     (funcall (lisp-stream-misc stream) stream :charpos)
1021     ;; fundamental-stream
1022     (stream-line-column stream))))
1023 ram 1.1
1024     (defun line-length (&optional (stream *standard-output*))
1025 rtoy 1.91 "Returns the number of characters that will fit on a line of output on the
1026 ram 1.1 given Stream, or Nil if that information is not available."
1027 toy 1.61 (declare (type streamlike stream))
1028     (let ((stream (out-synonym-of stream)))
1029     (stream-dispatch stream
1030     ;; simple-stream
1031     (stream::%line-length stream)
1032     ;; lisp-stream
1033     (funcall (lisp-stream-misc stream) stream :line-length)
1034     ;; fundamental-stream
1035     (stream-line-length stream))))
1036 ram 1.1
1037     (defun finish-output (&optional (stream *standard-output*))
1038 rtoy 1.91 "Attempts to ensure that all output sent to the Stream has reached its
1039 ram 1.1 destination, and only then returns."
1040 toy 1.52 (declare (type streamlike stream))
1041 toy 1.61 (let ((stream (out-synonym-of stream)))
1042     (stream-dispatch stream
1043     ;; simple-stream
1044     (stream::%finish-output stream)
1045     ;; lisp-stream
1046     (funcall (lisp-stream-misc stream) stream :finish-output)
1047     ;; fundamental-stream
1048     (stream-finish-output stream)))
1049 ram 1.1 nil)
1050    
1051     (defun force-output (&optional (stream *standard-output*))
1052 rtoy 1.91 "Attempts to force any buffered output to be sent."
1053 toy 1.52 (declare (type streamlike stream))
1054 toy 1.61 (let ((stream (out-synonym-of stream)))
1055     (stream-dispatch stream
1056     ;; simple-stream
1057     (stream::%force-output stream)
1058     ;; lisp-stream-misc
1059     (funcall (lisp-stream-misc stream) stream :force-output)
1060     ;; fundamental-stream
1061     (stream-force-output stream)))
1062 ram 1.1 nil)
1063    
1064     (defun clear-output (&optional (stream *standard-output*))
1065 rtoy 1.91 "Clears the given output Stream."
1066 toy 1.52 (declare (type streamlike stream))
1067 toy 1.61 (let ((stream (out-synonym-of stream)))
1068     (stream-dispatch stream
1069     ;; simple-stream
1070     (stream::%clear-output stream)
1071     ;; lisp-stream
1072     (funcall (lisp-stream-misc stream) stream :clear-output)
1073     ;; fundamental-stream
1074     (stream-force-output stream)))
1075 ram 1.1 nil)
1076    
1077     (defun write-byte (integer stream)
1078 rtoy 1.91 "Outputs the Integer to the binary Stream."
1079 toy 1.52 (declare (type stream stream))
1080 toy 1.61 (let ((stream (out-synonym-of stream)))
1081     (stream-dispatch stream
1082     ;; simple-stream
1083     (stream::%write-byte stream integer)
1084     ;; lisp-stream
1085     (funcall (lisp-stream-bout stream) stream integer)
1086     ;; fundamental-stream
1087     (stream-write-byte stream integer)))
1088 ram 1.1 integer)
1089    
1090 dtc 1.33
1091     ;;; Stream-misc-dispatch
1092     ;;;
1093 toy 1.61 ;;; Called from lisp-stream routines that encapsulate CLOS streams to
1094 dtc 1.33 ;;; handle the misc routines and dispatch to the appropriate Gray
1095     ;;; stream functions.
1096     ;;;
1097     (defun stream-misc-dispatch (stream operation &optional arg1 arg2)
1098     (declare (type fundamental-stream stream)
1099     (ignore arg2))
1100     (case operation
1101     (:listen
1102 rtoy 1.84 ;; Return true if input available, :eof for end-of-file, otherwise Nil.
1103 dtc 1.33 (let ((char (stream-read-char-no-hang stream)))
1104     (when (characterp char)
1105     (stream-unread-char stream char))
1106     char))
1107     (:unread
1108     (stream-unread-char stream arg1))
1109     (:close
1110     (close stream))
1111     (:clear-input
1112     (stream-clear-input stream))
1113     (:force-output
1114     (stream-force-output stream))
1115     (:finish-output
1116     (stream-finish-output stream))
1117     (:element-type
1118     (stream-element-type stream))
1119     (:interactive-p
1120     (interactive-stream-p stream))
1121     (:line-length
1122     (stream-line-length stream))
1123     (:charpos
1124     (stream-line-column stream))
1125     (:file-length
1126     (file-length stream))
1127     (:file-position
1128     (file-position stream arg1))))
1129    
1130    
1131 ram 1.1 ;;;; Broadcast streams:
1132    
1133 dtc 1.30 (defstruct (broadcast-stream (:include lisp-stream
1134 ram 1.1 (out #'broadcast-out)
1135     (bout #'broadcast-bout)
1136     (sout #'broadcast-sout)
1137     (misc #'broadcast-misc))
1138     (:print-function %print-broadcast-stream)
1139 toy 1.52 (:constructor %make-broadcast-stream (&rest streams)))
1140 ram 1.1 ;; This is a list of all the streams we broadcast to.
1141 ram 1.14 (streams () :type list :read-only t))
1142 ram 1.1
1143 toy 1.52 (defun make-broadcast-stream (&rest streams)
1144 rtoy 1.91 "Returns an output stream which sends its output to all of the given
1145 toy 1.52 streams."
1146     (dolist (s streams)
1147     (unless (output-stream-p s)
1148     (ill-out-any s)))
1149    
1150     (apply #'%make-broadcast-stream streams))
1151 ram 1.1
1152     (defun %print-broadcast-stream (s stream d)
1153     (declare (ignore s d))
1154     (write-string "#<Broadcast Stream>" stream))
1155    
1156 dtc 1.33 (macrolet ((out-fun (fun method stream-method &rest args)
1157 ram 1.1 `(defun ,fun (stream ,@args)
1158     (dolist (stream (broadcast-stream-streams stream))
1159 toy 1.61 (stream-dispatch stream
1160     ;; simple-stream
1161     (,stream-method stream ,@args) ; use gray-compat for now
1162     ;; lisp-stream
1163     (funcall (,method stream) stream ,@args)
1164     ;; fundamental-stream
1165     (,stream-method stream ,@args))))))
1166 dtc 1.33 (out-fun broadcast-out lisp-stream-out stream-write-char char)
1167     (out-fun broadcast-bout lisp-stream-bout stream-write-byte byte)
1168     (out-fun broadcast-sout lisp-stream-sout stream-write-string
1169     string start end))
1170 ram 1.1
1171     (defun broadcast-misc (stream operation &optional arg1 arg2)
1172     (let ((streams (broadcast-stream-streams stream)))
1173     (case operation
1174     (:charpos
1175 emarsden 1.70 (dolist (stream streams 0)
1176 dtc 1.33 (let ((charpos (charpos stream)))
1177 ram 1.1 (if charpos (return charpos)))))
1178     (:line-length
1179     (let ((min nil))
1180     (dolist (stream streams min)
1181 dtc 1.33 (let ((res (line-length stream)))
1182 ram 1.1 (when res (setq min (if min (min res min) res)))))))
1183 emarsden 1.71 ;; CLHS: The functions file-length, file-position, file-string-length, and
1184     ;; stream-external-format return the value from the last component
1185     ;; stream; if there are no component streams, file-length and
1186     ;; file-position return 0, file-string-length returns 1, and
1187     ;; stream-external-format returns :default.
1188     (:file-length
1189     (if (null streams) 0
1190 emarsden 1.73 (file-length (first (last streams)))))
1191 emarsden 1.71 (:file-position
1192     (if (null streams) 0
1193 emarsden 1.73 (file-position (first (last streams)))))
1194 ram 1.1 (:element-type
1195 emarsden 1.70 #+nil ; old, arguably more logical, version
1196 ram 1.1 (let (res)
1197 emarsden 1.69 (dolist (stream streams (if (> (length res) 1) `(and ,@res) t))
1198 emarsden 1.70 (pushnew (stream-element-type stream) res :test #'equal)))
1199     ;; ANSI-specified version (under System Class BROADCAST-STREAM)
1200     (let ((res t))
1201     (do ((streams streams (cdr streams)))
1202     ((null streams) res)
1203     (when (null (cdr streams))
1204     (setq res (stream-element-type (car streams)))))))
1205 wlott 1.25 (:close)
1206 ram 1.1 (t
1207     (let ((res nil))
1208     (dolist (stream streams res)
1209 dtc 1.33 (setq res
1210     (if (lisp-stream-p stream)
1211     (funcall (lisp-stream-misc stream) stream operation
1212     arg1 arg2)
1213     (stream-misc-dispatch stream operation arg1 arg2)))))))))
1214    
1215 ram 1.1
1216     ;;;; Synonym Streams:
1217    
1218 dtc 1.30 (defstruct (synonym-stream (:include lisp-stream
1219 ram 1.1 (in #'synonym-in)
1220     (bin #'synonym-bin)
1221     (n-bin #'synonym-n-bin)
1222     (out #'synonym-out)
1223     (bout #'synonym-bout)
1224     (sout #'synonym-sout)
1225     (misc #'synonym-misc))
1226     (:print-function %print-synonym-stream)
1227     (:constructor make-synonym-stream (symbol)))
1228     ;; This is the symbol, the value of which is the stream we are synonym to.
1229 wlott 1.15 (symbol nil :type symbol :read-only t))
1230 ram 1.1
1231     (defun %print-synonym-stream (s stream d)
1232     (declare (ignore d))
1233     (format stream "#<Synonym Stream to ~S>" (synonym-stream-symbol s)))
1234    
1235     (setf (documentation 'make-synonym-stream 'function)
1236 rtoy 1.90 _N"Returns a stream which performs its operations on the stream which is the
1237 ram 1.1 value of the dynamic variable named by Symbol.")
1238    
1239     ;;; The output simple output methods just call the corresponding method
1240     ;;; in the synonymed stream.
1241     ;;;
1242 dtc 1.33 (macrolet ((out-fun (name slot stream-method &rest args)
1243 ram 1.1 `(defun ,name (stream ,@args)
1244 ram 1.11 (declare (optimize (safety 1)))
1245 ram 1.1 (let ((syn (symbol-value (synonym-stream-symbol stream))))
1246 dtc 1.33 (if (lisp-stream-p syn)
1247     (funcall (,slot syn) syn ,@args)
1248     (,stream-method syn ,@args))))))
1249     (out-fun synonym-out lisp-stream-out stream-write-char ch)
1250     (out-fun synonym-bout lisp-stream-bout stream-write-byte n)
1251     (out-fun synonym-sout lisp-stream-sout stream-write-string string start end))
1252 ram 1.1
1253    
1254     ;;; Bind synonym stream to this so that SPIO can turn on the right frob in
1255     ;;; the icon when we are in a terminal input wait.
1256     ;;;
1257     (defvar *previous-stream* nil)
1258    
1259     ;;; For the input methods, we just call the corresponding function on the
1260     ;;; synonymed stream. These functions deal with getting input out of
1261     ;;; the In-Buffer if there is any.
1262     ;;;
1263     (macrolet ((in-fun (name fun &rest args)
1264     `(defun ,name (stream ,@args)
1265 ram 1.11 (declare (optimize (safety 1)))
1266 ram 1.1 (let ((*previous-stream* stream))
1267     (,fun (symbol-value (synonym-stream-symbol stream)) ,@args)))))
1268     (in-fun synonym-in read-char eof-errorp eof-value)
1269     (in-fun synonym-bin read-byte eof-errorp eof-value)
1270     (in-fun synonym-n-bin read-n-bytes buffer start numbytes eof-errorp))
1271    
1272    
1273     ;;; Synonym-Misc -- Internal
1274     ;;;
1275     ;;; We have to special-case the operations which could look at stuff in
1276     ;;; the in-buffer.
1277     ;;;
1278     (defun synonym-misc (stream operation &optional arg1 arg2)
1279 ram 1.11 (declare (optimize (safety 1)))
1280 ram 1.1 (let ((syn (symbol-value (synonym-stream-symbol stream)))
1281     (*previous-stream* stream))
1282 dtc 1.33 (if (lisp-stream-p syn)
1283     (case operation
1284     (:listen (or (/= (the fixnum (lisp-stream-in-index syn))
1285     in-buffer-length)
1286     (funcall (lisp-stream-misc syn) syn :listen)))
1287 dtc 1.42 (:clear-input (clear-input syn))
1288     (:unread (unread-char arg1 syn))
1289 dtc 1.33 (t
1290     (funcall (lisp-stream-misc syn) syn operation arg1 arg2)))
1291     (stream-misc-dispatch syn operation arg1 arg2))))
1292 ram 1.1
1293     ;;;; Two-Way streams:
1294    
1295     (defstruct (two-way-stream
1296 dtc 1.30 (:include lisp-stream
1297 ram 1.1 (in #'two-way-in)
1298     (bin #'two-way-bin)
1299     (n-bin #'two-way-n-bin)
1300     (out #'two-way-out)
1301     (bout #'two-way-bout)
1302     (sout #'two-way-sout)
1303     (misc #'two-way-misc))
1304     (:print-function %print-two-way-stream)
1305 toy 1.52 (:constructor %make-two-way-stream (input-stream output-stream)))
1306 ram 1.1 ;; We read from this stream...
1307 ram 1.14 (input-stream (required-argument) :type stream :read-only t)
1308 ram 1.1 ;; And write to this one
1309 ram 1.14 (output-stream (required-argument) :type stream :read-only t))
1310 ram 1.1
1311     (defun %print-two-way-stream (s stream d)
1312     (declare (ignore d))
1313     (format stream "#<Two-Way Stream, Input = ~S, Output = ~S>"
1314     (two-way-stream-input-stream s)
1315     (two-way-stream-output-stream s)))
1316    
1317 toy 1.52 (defun make-two-way-stream (input-stream output-stream)
1318 rtoy 1.91 "Returns a bidirectional stream which gets its input from Input-Stream and
1319 toy 1.52 sends its output to Output-Stream."
1320     (unless (input-stream-p input-stream)
1321     (ill-in-any input-stream))
1322     (unless (output-stream-p output-stream)
1323     (ill-out-any output-stream))
1324    
1325     (%make-two-way-stream input-stream output-stream))
1326 ram 1.1
1327 dtc 1.33 (macrolet ((out-fun (name slot stream-method &rest args)
1328 ram 1.1 `(defun ,name (stream ,@args)
1329     (let ((syn (two-way-stream-output-stream stream)))
1330 dtc 1.33 (if (lisp-stream-p syn)
1331     (funcall (,slot syn) syn ,@args)
1332     (,stream-method syn ,@args))))))
1333     (out-fun two-way-out lisp-stream-out stream-write-char ch)
1334     (out-fun two-way-bout lisp-stream-bout stream-write-byte n)
1335     (out-fun two-way-sout lisp-stream-sout stream-write-string string start end))
1336 ram 1.1
1337     (macrolet ((in-fun (name fun &rest args)
1338     `(defun ,name (stream ,@args)
1339 ram 1.10 (force-output (two-way-stream-output-stream stream))
1340 ram 1.1 (,fun (two-way-stream-input-stream stream) ,@args))))
1341     (in-fun two-way-in read-char eof-errorp eof-value)
1342     (in-fun two-way-bin read-byte eof-errorp eof-value)
1343     (in-fun two-way-n-bin read-n-bytes buffer start numbytes eof-errorp))
1344    
1345     (defun two-way-misc (stream operation &optional arg1 arg2)
1346     (let* ((in (two-way-stream-input-stream stream))
1347     (out (two-way-stream-output-stream stream))
1348 dtc 1.33 (in-lisp-stream-p (lisp-stream-p in))
1349     (out-lisp-stream-p (lisp-stream-p out)))
1350 ram 1.1 (case operation
1351 dtc 1.33 (:listen
1352     (if in-lisp-stream-p
1353     (or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length)
1354     (funcall (lisp-stream-misc in) in :listen))
1355     (stream-listen in)))
1356 ram 1.1 ((:finish-output :force-output :clear-output)
1357 dtc 1.33 (if out-lisp-stream-p
1358     (funcall (lisp-stream-misc out) out operation arg1 arg2)
1359     (stream-misc-dispatch out operation arg1 arg2)))
1360 dtc 1.42 (:clear-input (clear-input in))
1361     (:unread (unread-char arg1 in))
1362 ram 1.1 (:element-type
1363 dtc 1.33 (let ((in-type (stream-element-type in))
1364     (out-type (stream-element-type out)))
1365 ram 1.1 (if (equal in-type out-type)
1366     in-type `(and ,in-type ,out-type))))
1367 dtc 1.33 (:close
1368 ram 1.1 (set-closed-flame stream))
1369 rtoy 1.74 (:file-length
1370     (error 'type-error :datum stream :expected-type 'file-stream))
1371 rtoy 1.79 (:charpos
1372     (charpos out))
1373     (:line-length
1374     (line-length out))
1375 ram 1.1 (t
1376 dtc 1.33 (or (if in-lisp-stream-p
1377     (funcall (lisp-stream-misc in) in operation arg1 arg2)
1378     (stream-misc-dispatch in operation arg1 arg2))
1379     (if out-lisp-stream-p
1380     (funcall (lisp-stream-misc out) out operation arg1 arg2)
1381     (stream-misc-dispatch out operation arg1 arg2)))))))
1382    
1383 ram 1.1
1384     ;;;; Concatenated Streams:
1385    
1386     (defstruct (concatenated-stream
1387 dtc 1.30 (:include lisp-stream
1388 ram 1.1 (in #'concatenated-in)
1389     (bin #'concatenated-bin)
1390 pw 1.46 (n-bin #'concatenated-n-bin)
1391 ram 1.1 (misc #'concatenated-misc))
1392     (:print-function %print-concatenated-stream)
1393 toy 1.52 (:constructor %make-concatenated-stream (&rest streams)))
1394 dtc 1.40 ;; This is a list of all the streams. The car of this is the stream
1395     ;; we are reading from now.
1396     (streams nil :type list))
1397 ram 1.1
1398     (defun %print-concatenated-stream (s stream d)
1399     (declare (ignore d))
1400     (format stream "#<Concatenated Stream, Streams = ~S>"
1401     (concatenated-stream-streams s)))
1402    
1403 toy 1.52 (defun make-concatenated-stream (&rest streams)
1404 rtoy 1.91 "Returns a stream which takes its input from each of the Streams in turn,
1405 toy 1.52 going on to the next at EOF."
1406     (dolist (s streams)
1407     (unless (input-stream-p s)
1408     (ill-in-any s)))
1409     (apply #'%make-concatenated-stream streams))
1410 ram 1.1
1411     (macrolet ((in-fun (name fun)
1412     `(defun ,name (stream eof-errorp eof-value)
1413 dtc 1.40 (do ((current (concatenated-stream-streams stream)
1414     (cdr current)))
1415 ram 1.1 ((null current)
1416     (eof-or-lose stream eof-errorp eof-value))
1417     (let* ((stream (car current))
1418     (result (,fun stream nil nil)))
1419     (when result (return result)))
1420 dtc 1.40 (setf (concatenated-stream-streams stream) (cdr current))))))
1421 ram 1.1 (in-fun concatenated-in read-char)
1422     (in-fun concatenated-bin read-byte))
1423 pw 1.46
1424     (defun concatenated-n-bin (stream buffer start numbytes eof-errorp)
1425     (do ((current (concatenated-stream-streams stream) (cdr current))
1426     (current-start start)
1427     (remaining-bytes numbytes))
1428     ((null current)
1429     (if eof-errorp
1430     (error 'end-of-file :stream stream)
1431     (- numbytes remaining-bytes)))
1432     (let* ((stream (car current))
1433     (bytes-read (read-n-bytes stream buffer current-start
1434     remaining-bytes nil)))
1435     (incf current-start bytes-read)
1436     (decf remaining-bytes bytes-read)
1437     (when (zerop remaining-bytes) (return numbytes)))
1438     (setf (concatenated-stream-streams stream) (cdr current))))
1439 ram 1.1
1440     (defun concatenated-misc (stream operation &optional arg1 arg2)
1441 emarsden 1.72 (let ((current (first (concatenated-stream-streams stream))))
1442     (case operation
1443     (:listen
1444     (if current
1445     (loop
1446     (let ((stuff (if (lisp-stream-p current)
1447     (funcall (lisp-stream-misc current) current
1448     :listen)
1449     (stream-misc-dispatch current :listen))))
1450     (cond ((eq stuff :eof)
1451     ;; Advance current, and try again.
1452     (pop (concatenated-stream-streams stream))
1453     (setf current (first (concatenated-stream-streams stream)))
1454     (unless current (return :eof)))
1455     (stuff
1456     ;; Stuff's available.
1457     (return t))
1458     (t
1459     ;; Nothing available yet.
1460     (return nil)))))
1461     :eof))
1462     (:close
1463     (set-closed-flame stream))
1464     (:clear-input
1465     (when current (clear-input current)))
1466     (:unread
1467     (when current (unread-char arg1 current)))
1468 rtoy 1.74 (:file-length
1469     (error 'type-error :datum stream :expected-type 'file-stream))
1470 emarsden 1.72 (t
1471     (if (lisp-stream-p current)
1472     (funcall (lisp-stream-misc current) current operation arg1 arg2)
1473     (stream-misc-dispatch current operation arg1 arg2))))))
1474 dtc 1.33
1475 ram 1.1
1476     ;;;; Echo Streams:
1477    
1478     (defstruct (echo-stream
1479     (:include two-way-stream
1480     (in #'echo-in)
1481     (bin #'echo-bin)
1482     (misc #'echo-misc)
1483 rtoy 1.76 (n-bin #'echo-n-bin))
1484 ram 1.1 (:print-function %print-echo-stream)
1485 toy 1.52 (:constructor %make-echo-stream (input-stream output-stream)))
1486 wlott 1.8 unread-stuff)
1487 ram 1.1
1488 toy 1.52 (defun make-echo-stream (input-stream output-stream)
1489 rtoy 1.91 "Returns an echo stream that takes input from Input-stream and sends
1490 toy 1.52 output to Output-stream"
1491     (unless (input-stream-p input-stream)
1492     (ill-in-any input-stream))
1493     (unless (output-stream-p output-stream)
1494     (ill-out-any output-stream))
1495     (%make-echo-stream input-stream output-stream))
1496 ram 1.1
1497 dtc 1.38 (macrolet ((in-fun (name fun out-slot stream-method)
1498     `(defun ,name (stream eof-errorp eof-value)
1499 wlott 1.8 (or (pop (echo-stream-unread-stuff stream))
1500     (let* ((in (echo-stream-input-stream stream))
1501     (out (echo-stream-output-stream stream))
1502 dtc 1.38 (result (,fun in nil :eof)))
1503     (cond ((eq result :eof)
1504     (eof-or-lose stream eof-errorp eof-value))
1505     (t
1506     (if (lisp-stream-p out)
1507     (funcall (,out-slot out) out result)
1508     (,stream-method out result))
1509     result)))))))
1510     (in-fun echo-in read-char lisp-stream-out stream-write-char)
1511     (in-fun echo-bin read-byte lisp-stream-bout stream-write-byte))
1512 ram 1.1
1513 toy 1.56
1514 ram 1.1 (defun echo-misc (stream operation &optional arg1 arg2)
1515     (let* ((in (two-way-stream-input-stream stream))
1516 dtc 1.33 (out (two-way-stream-output-stream stream)))
1517 ram 1.1 (case operation
1518 dtc 1.33 (:listen
1519     (or (not (null (echo-stream-unread-stuff stream)))
1520     (if (lisp-stream-p in)
1521     (or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length)
1522     (funcall (lisp-stream-misc in) in :listen))
1523     (stream-misc-dispatch in :listen))))
1524 wlott 1.8 (:unread (push arg1 (echo-stream-unread-stuff stream)))
1525 ram 1.1 (:element-type
1526 dtc 1.33 (let ((in-type (stream-element-type in))
1527     (out-type (stream-element-type out)))
1528 ram 1.1 (if (equal in-type out-type)
1529     in-type `(and ,in-type ,out-type))))
1530     (:close
1531     (set-closed-flame stream))
1532 toy 1.56 (:peek-char
1533     ;; For the special case of peeking into an echo-stream
1534     ;; arg1 is peek-type, arg2 is (eof-errorp eof-value)
1535     ;; returns peeked-char, eof-value, or errors end-of-file
1536     (let ((unread-char-p nil))
1537     (destructuring-bind (eof-errorp eof-value)
1538     arg2
1539     (flet ((outfn (c)
1540     (unless unread-char-p
1541     (if (lisp-stream-p out)
1542     (funcall (lisp-stream-out out) out c)
1543     ;; gray-stream
1544     (stream-write-char out c))))
1545     (infn ()
1546     ;; Obtain input from unread buffer or input stream,
1547     ;; and set the flag appropriately.
1548     (cond ((not (null (echo-stream-unread-stuff stream)))
1549     (setf unread-char-p t)
1550     (pop (echo-stream-unread-stuff stream)))
1551     (t
1552     (setf unread-char-p nil)
1553 rtoy 1.80 (read-char in eof-errorp :eof)))))
1554 toy 1.56 (generalized-peeking-mechanism
1555     arg1 eof-value char
1556     (infn)
1557 rtoy 1.80 :eof
1558 toy 1.56 (unread-char char in)
1559 rtoy 1.82 :skipped-char-form (outfn char))))))
1560 rtoy 1.74 (:file-length
1561     (error 'type-error :datum stream :expected-type 'file-stream))
1562 ram 1.1 (t
1563 dtc 1.33 (or (if (lisp-stream-p in)
1564     (funcall (lisp-stream-misc in) in operation arg1 arg2)
1565     (stream-misc-dispatch in operation arg1 arg2))
1566     (if (lisp-stream-p out)
1567     (funcall (lisp-stream-misc out) out operation arg1 arg2)
1568     (stream-misc-dispatch out operation arg1 arg2)))))))
1569 rtoy 1.76
1570    
1571     (defun echo-n-bin (stream buffer start numbytes eof-error-p)
1572     (let ((new-start start)
1573     (read 0))
1574     (loop
1575     (let ((thing (pop (echo-stream-unread-stuff stream))))
1576     (cond
1577     (thing
1578     (setf (aref buffer new-start) thing)
1579     (incf new-start)
1580     (incf read)
1581     (when (= read numbytes)
1582     (return-from echo-n-bin numbytes)))
1583     (t (return nil)))))
1584     (let ((bytes-read (read-n-bytes (echo-stream-input-stream stream) buffer
1585     new-start (- numbytes read) nil)))
1586     (cond
1587     ((not eof-error-p)
1588     (write-sequence buffer (echo-stream-output-stream stream)
1589     :start new-start :end (+ new-start bytes-read))
1590     (+ bytes-read read))
1591     ((> numbytes (+ read bytes-read))
1592     (write-sequence buffer (echo-stream-output-stream stream)
1593     :start new-start :end (+ new-start bytes-read))
1594     (error 'end-of-file :stream stream))
1595     (t
1596     (write-sequence buffer (echo-stream-output-stream stream)
1597     :start new-start :end (+ new-start bytes-read))
1598     numbytes)))))
1599 ram 1.1
1600     (defun %print-echo-stream (s stream d)
1601     (declare (ignore d))
1602     (format stream "#<Echo Stream, Input = ~S, Output = ~S>"
1603     (two-way-stream-input-stream s)
1604     (two-way-stream-output-stream s)))
1605    
1606     (setf (documentation 'make-echo-stream 'function)
1607 rtoy 1.90 _N"Returns a bidirectional stream which gets its input from Input-Stream and
1608 ram 1.1 sends its output to Output-Stream. In addition, all input is echoed to
1609     the output stream")
1610    
1611 moore 1.57 ;;;; Superclass of all string streams
1612    
1613     (defstruct (string-stream
1614     (:include lisp-stream)
1615     (:constructor nil)
1616     (:copier nil)))
1617    
1618 ram 1.1 ;;;; String Input Streams:
1619    
1620     (defstruct (string-input-stream
1621 moore 1.57 (:include string-stream
1622 ram 1.21 (in #'string-inch)
1623     (bin #'string-binch)
1624     (n-bin #'string-stream-read-n-bytes)
1625     (misc #'string-in-misc))
1626     (:print-function %print-string-input-stream)
1627     ;(:constructor nil)
1628     (:constructor internal-make-string-input-stream
1629     (string current end)))
1630 ram 1.1 (string nil :type simple-string)
1631 dtc 1.31 (current nil :type index)
1632     (end nil :type index))
1633 ram 1.1
1634     (defun %print-string-input-stream (s stream d)
1635     (declare (ignore s d))
1636     (write-string "#<String-Input Stream>" stream))
1637    
1638     (defun string-inch (stream eof-errorp eof-value)
1639     (let ((string (string-input-stream-string stream))
1640     (index (string-input-stream-current stream)))
1641     (declare (simple-string string) (fixnum index))
1642 dtc 1.31 (cond ((= index (the index (string-input-stream-end stream)))
1643 ram 1.1 (eof-or-lose stream eof-errorp eof-value))
1644     (t
1645     (setf (string-input-stream-current stream) (1+ index))
1646     (aref string index)))))
1647 ram 1.21
1648     (defun string-binch (stream eof-errorp eof-value)
1649     (let ((string (string-input-stream-string stream))
1650     (index (string-input-stream-current stream)))
1651 dtc 1.31 (declare (simple-string string)
1652     (type index index))
1653     (cond ((= index (the index (string-input-stream-end stream)))
1654 ram 1.21 (eof-or-lose stream eof-errorp eof-value))
1655     (t
1656     (setf (string-input-stream-current stream) (1+ index))
1657     (char-code (aref string index))))))
1658    
1659     (defun string-stream-read-n-bytes (stream buffer start requested eof-errorp)
1660     (declare (type string-input-stream stream)
1661     (type index start requested))
1662 dtc 1.31 (let* ((string (string-input-stream-string stream))
1663     (index (string-input-stream-current stream))
1664     (available (- (string-input-stream-end stream) index))
1665     (copy (min available requested)))
1666     (declare (simple-string string)
1667     (type index index available copy))
1668     (when (plusp copy)
1669     (setf (string-input-stream-current stream)
1670     (truly-the index (+ index copy)))
1671     (system:without-gcing
1672     (system-area-copy (vector-sap string)
1673     (* index vm:byte-bits)
1674     (if (typep buffer 'system-area-pointer)
1675     buffer
1676     (vector-sap buffer))
1677     (* start vm:byte-bits)
1678     (* copy vm:byte-bits))))
1679     (if (and (> requested copy) eof-errorp)
1680     (error 'end-of-file :stream stream)
1681     copy)))
1682 ram 1.1
1683     (defun string-in-misc (stream operation &optional arg1 arg2)
1684 ram 1.18 (declare (ignore arg2))
1685 ram 1.1 (case operation
1686 ram 1.2 (:file-position
1687 ram 1.5 (if arg1
1688 rtoy 1.81 (setf (string-input-stream-current stream)
1689     (case arg1
1690     (:start 0)
1691     (:end (length (string-input-stream-string stream)))
1692     (t arg1)))
1693 ram 1.5 (string-input-stream-current stream)))
1694 emarsden 1.69 (:file-length
1695 rtoy 1.74 (error 'type-error :datum stream :expected-type 'file-stream))
1696 ram 1.1 (:unread (decf (string-input-stream-current stream)))
1697 ram 1.10 (:listen (or (/= (the fixnum (string-input-stream-current stream))
1698     (the fixnum (string-input-stream-end stream)))
1699     :eof))
1700 rtoy 1.84 (:element-type 'base-char)
1701     (:close
1702     (set-closed-flame stream))))
1703 ram 1.1
1704     (defun make-string-input-stream (string &optional
1705     (start 0) (end (length string)))
1706 rtoy 1.91 "Returns an input stream which will supply the characters of String between
1707 ram 1.1 Start and End in order."
1708 wlott 1.17 (declare (type string string)
1709     (type index start)
1710 ram 1.18 (type (or index null) end))
1711 wlott 1.17 (internal-make-string-input-stream (coerce string 'simple-string)
1712 rtoy 1.75 start (or end (length string))))
1713 ram 1.1
1714     ;;;; String Output Streams:
1715    
1716     (defstruct (string-output-stream
1717 moore 1.57 (:include string-stream
1718 ram 1.1 (out #'string-ouch)
1719     (sout #'string-sout)
1720     (misc #'string-out-misc))
1721     (:print-function %print-string-output-stream)
1722 toy 1.64 (:constructor %make-string-output-stream ()))
1723 ram 1.1 ;; The string we throw stuff in.
1724     (string (make-string 40) :type simple-string)
1725     ;; Index of the next location to use.
1726     (index 0 :type fixnum))
1727    
1728     (defun %print-string-output-stream (s stream d)
1729     (declare (ignore s d))
1730     (write-string "#<String-Output Stream>" stream))
1731    
1732 toy 1.64 (defun make-string-output-stream (&key (element-type 'character))
1733 rtoy 1.91 "Returns an Output stream which will accumulate all output given to it for
1734 toy 1.64 the benefit of the function Get-Output-Stream-String."
1735     (declare (ignore element-type))
1736     (%make-string-output-stream))
1737 ram 1.1
1738     (defun string-ouch (stream character)
1739     (let ((current (string-output-stream-index stream))
1740     (workspace (string-output-stream-string stream)))
1741     (declare (simple-string workspace) (fixnum current))
1742     (if (= current (the fixnum (length workspace)))
1743     (let ((new-workspace (make-string (* current 2))))
1744 wlott 1.17 (replace new-workspace workspace)
1745 ram 1.1 (setf (aref new-workspace current) character)
1746     (setf (string-output-stream-string stream) new-workspace))
1747     (setf (aref workspace current) character))
1748     (setf (string-output-stream-index stream) (1+ current))))
1749    
1750     (defun string-sout (stream string start end)
1751     (declare (simple-string string) (fixnum start end))
1752     (let* ((current (string-output-stream-index stream))
1753     (length (- end start))
1754     (dst-end (+ length current))
1755     (workspace (string-output-stream-string stream)))
1756     (declare (simple-string workspace)
1757     (fixnum current length dst-end))
1758     (if (> dst-end (the fixnum (length workspace)))
1759     (let ((new-workspace (make-string (+ (* current 2) length))))
1760 wlott 1.17 (replace new-workspace workspace :end2 current)
1761     (replace new-workspace string
1762     :start1 current :end1 dst-end
1763     :start2 start :end2 end)
1764 ram 1.1 (setf (string-output-stream-string stream) new-workspace))
1765 wlott 1.17 (replace workspace string
1766     :start1 current :end1 dst-end
1767     :start2 start :end2 end))
1768 ram 1.1 (setf (string-output-stream-index stream) dst-end)))
1769    
1770     (defun string-out-misc (stream operation &optional arg1 arg2)
1771 ram 1.3 (declare (ignore arg2))
1772 ram 1.1 (case operation
1773 ram 1.2 (:file-position
1774     (if (null arg1)
1775 ram 1.3 (string-output-stream-index stream)))
1776 rtoy 1.74 (:file-length
1777     (error 'type-error :datum stream :expected-type 'file-stream))
1778 ram 1.1 (:charpos
1779     (do ((index (1- (the fixnum (string-output-stream-index stream)))
1780     (1- index))
1781     (count 0 (1+ count))
1782     (string (string-output-stream-string stream)))
1783     ((< index 0) count)
1784     (declare (simple-string string)
1785     (fixnum index count))
1786     (if (char= (schar string index) #\newline)
1787     (return count))))
1788 rtoy 1.75 (:element-type 'base-char)
1789     (:close
1790     (set-closed-flame stream))))
1791 ram 1.1
1792     (defun get-output-stream-string (stream)
1793 rtoy 1.91 "Returns a string of all the characters sent to a stream made by
1794 ram 1.1 Make-String-Output-Stream since the last call to this function."
1795 wlott 1.17 (declare (type string-output-stream stream))
1796     (let* ((length (string-output-stream-index stream))
1797     (result (make-string length)))
1798     (replace result (string-output-stream-string stream))
1799     (setf (string-output-stream-index stream) 0)
1800     result))
1801 ram 1.1
1802     (defun dump-output-stream-string (in-stream out-stream)
1803 rtoy 1.91 "Dumps the characters buffer up in the In-Stream to the Out-Stream as
1804 ram 1.1 Get-Output-Stream-String would return them."
1805 dtc 1.30 (write-string* (string-output-stream-string in-stream) out-stream
1806     0 (string-output-stream-index in-stream))
1807 ram 1.1 (setf (string-output-stream-index in-stream) 0))
1808    
1809     ;;;; Fill-pointer streams:
1810     ;;;
1811     ;;; Fill pointer string output streams are not explicitly mentioned in
1812     ;;; the CLM, but they are required for the implementation of With-Output-To-String.
1813    
1814     (defstruct (fill-pointer-output-stream
1815 moore 1.57 (:include string-stream
1816 ram 1.1 (out #'fill-pointer-ouch)
1817     (sout #'fill-pointer-sout)
1818     (misc #'fill-pointer-misc))
1819     (:print-function
1820     (lambda (s stream d)
1821     (declare (ignore s d))
1822     (write-string "#<Fill-Pointer String Output Stream>" stream)))
1823     (:constructor make-fill-pointer-output-stream (string)))
1824     ;; The string we throw stuff in.
1825     string)
1826    
1827    
1828     (defun fill-pointer-ouch (stream character)
1829     (let* ((buffer (fill-pointer-output-stream-string stream))
1830 wlott 1.4 (current (fill-pointer buffer))
1831 ram 1.1 (current+1 (1+ current)))
1832     (declare (fixnum current))
1833     (with-array-data ((workspace buffer) (start) (end))
1834     (declare (simple-string workspace))
1835     (let ((offset-current (+ start current)))
1836     (declare (fixnum offset-current))
1837     (if (= offset-current end)
1838 pw 1.48 (let* ((new-length (if (zerop current) 1 (* current 2)))
1839 ram 1.1 (new-workspace (make-string new-length)))
1840     (declare (simple-string new-workspace))
1841 rtoy 1.84 (%primitive byte-blt workspace (* vm:char-bytes start)
1842     new-workspace 0 (* vm:char-bytes current))
1843 ram 1.1 (setf workspace new-workspace)
1844     (setf offset-current current)
1845     (set-array-header buffer workspace new-length
1846     current+1 0 new-length nil))
1847 wlott 1.4 (setf (fill-pointer buffer) current+1))
1848 ram 1.1 (setf (schar workspace offset-current) character)))
1849     current+1))
1850    
1851    
1852     (defun fill-pointer-sout (stream string start end)
1853     (declare (simple-string string) (fixnum start end))
1854     (let* ((buffer (fill-pointer-output-stream-string stream))
1855 wlott 1.4 (current (fill-pointer buffer))
1856 ram 1.1 (string-len (- end start))
1857     (dst-end (+ string-len current)))
1858     (declare (fixnum current dst-end string-len))
1859     (with-array-data ((workspace buffer) (dst-start) (dst-length))
1860     (declare (simple-string workspace))
1861     (let ((offset-dst-end (+ dst-start dst-end))
1862     (offset-current (+ dst-start current)))
1863     (declare (fixnum offset-dst-end offset-current))
1864     (if (> offset-dst-end dst-length)
1865     (let* ((new-length (+ (the fixnum (* current 2)) string-len))
1866     (new-workspace (make-string new-length)))
1867     (declare (simple-string new-workspace))
1868 rtoy 1.84 (%primitive byte-blt workspace (* vm:char-bytes dst-start)
1869     new-workspace 0 (* vm:char-bytes current))
1870 ram 1.1 (setf workspace new-workspace)
1871     (setf offset-current current)
1872     (setf offset-dst-end dst-end)
1873     (set-array-header buffer workspace new-length
1874     dst-end 0 new-length nil))
1875 wlott 1.4 (setf (fill-pointer buffer) dst-end))
1876 rtoy 1.84 (%primitive byte-blt string (* vm:char-bytes start)
1877     workspace (* vm:char-bytes offset-current)
1878     (* vm:char-bytes offset-dst-end))))
1879 ram 1.1 dst-end))
1880    
1881    
1882     (defun fill-pointer-misc (stream operation &optional arg1 arg2)
1883     (declare (ignore arg1 arg2))
1884     (case operation
1885     (:charpos
1886     (let* ((buffer (fill-pointer-output-stream-string stream))
1887 wlott 1.4 (current (fill-pointer buffer)))
1888 ram 1.1 (with-array-data ((string buffer) (start) (end current))
1889     (declare (simple-string string) (ignore start))
1890     (let ((found (position #\newline string :test #'char=
1891     :end end :from-end t)))
1892     (if found
1893     (- end (the fixnum found))
1894     current)))))
1895 pw 1.27 (:element-type 'base-char)))
1896 ram 1.1
1897     ;;;; Indenting streams:
1898    
1899 dtc 1.30 (defstruct (indenting-stream (:include lisp-stream
1900 ram 1.1 (out #'indenting-out)
1901     (sout #'indenting-sout)
1902     (misc #'indenting-misc))
1903     (:print-function %print-indenting-stream)
1904     (:constructor make-indenting-stream (stream)))
1905     ;; The stream we're based on:
1906     stream
1907     ;; How much we indent on each line:
1908     (indentation 0))
1909    
1910     (setf (documentation 'make-indenting-stream 'function)
1911 rtoy 1.90 _N"Returns an output stream which indents its output by some amount.")
1912 ram 1.1
1913     (defun %print-indenting-stream (s stream d)
1914     (declare (ignore s d))
1915     (write-string "#<Indenting Stream>" stream))
1916    
1917 toy 1.61 ;;; Indenting-Indent writes the right number of spaces needed to indent
1918     ;;; output on the given Stream based on the specified Sub-Stream.
1919 ram 1.1
1920     (defmacro indenting-indent (stream sub-stream)
1921     `(do ((i 0 (+ i 60))
1922     (indentation (indenting-stream-indentation ,stream)))
1923     ((>= i indentation))
1924 dtc 1.30 (write-string*
1925     " "
1926     ,sub-stream 0 (min 60 (- indentation i)))))
1927 ram 1.1
1928     ;;; Indenting-Out writes a character to an indenting stream.
1929    
1930     (defun indenting-out (stream char)
1931     (let ((sub-stream (indenting-stream-stream stream)))
1932 dtc 1.30 (write-char char sub-stream)
1933 ram 1.1 (if (char= char #\newline)
1934     (indenting-indent stream sub-stream))))
1935    
1936     ;;; Indenting-Sout writes a string to an indenting stream.
1937    
1938     (defun indenting-sout (stream string start end)
1939     (declare (simple-string string) (fixnum start end))
1940     (do ((i start)
1941     (sub-stream (indenting-stream-stream stream)))
1942     ((= i end))
1943     (let ((newline (position #\newline string :start i :end end)))
1944     (cond (newline
1945 dtc 1.30 (write-string* string sub-stream i (1+ newline))
1946 ram 1.1 (indenting-indent stream sub-stream)
1947     (setq i (+ newline 1)))
1948     (t
1949 dtc 1.30 (write-string* string sub-stream i end)
1950 ram 1.1 (setq i end))))))
1951    
1952     ;;; Indenting-Misc just treats just the :Line-Length message differently.
1953     ;;; Indenting-Charpos says the charpos is the charpos of the base stream minus
1954     ;;; the stream's indentation.
1955    
1956     (defun indenting-misc (stream operation &optional arg1 arg2)
1957 dtc 1.30 (let ((sub-stream (indenting-stream-stream stream)))
1958 dtc 1.33 (if (lisp-stream-p sub-stream)
1959     (let ((method (lisp-stream-misc sub-stream)))
1960     (case operation
1961     (:line-length
1962     (let ((line-length (funcall method sub-stream operation)))
1963     (if line-length
1964     (- line-length (indenting-stream-indentation stream)))))
1965     (:charpos
1966     (let ((charpos (funcall method sub-stream operation)))
1967     (if charpos
1968     (- charpos (indenting-stream-indentation stream)))))
1969     (t
1970     (funcall method sub-stream operation arg1 arg2))))
1971     ;; Fundamental-stream.
1972     (case operation
1973     (:line-length
1974     (let ((line-length (stream-line-length sub-stream)))
1975     (if line-length
1976     (- line-length (indenting-stream-indentation stream)))))
1977     (:charpos
1978     (let ((charpos (stream-line-column sub-stream)))
1979     (if charpos
1980     (- charpos (indenting-stream-indentation stream)))))
1981     (t
1982     (stream-misc-dispatch sub-stream operation arg1 arg2))))))
1983 dtc 1.30
1984 ram 1.1
1985 pw 1.45 (declaim (maybe-inline read-char unread-char read-byte listen))
1986 wlott 1.13
1987    
1988    
1989     ;;;; Case frobbing streams, used by format ~(...~).
1990    
1991     (defstruct (case-frob-stream
1992 dtc 1.30 (:include lisp-stream
1993 wlott 1.13 (:misc #'case-frob-misc))
1994     (:constructor %make-case-frob-stream (target out sout)))
1995     (target (required-argument) :type stream))
1996    
1997     (defun make-case-frob-stream (target kind)
1998 rtoy 1.91 "Returns a stream that sends all output to the stream TARGET, but modifies
1999 wlott 1.13 the case of letters, depending on KIND, which should be one of:
2000     :upcase - convert to upper case.
2001     :downcase - convert to lower case.
2002     :capitalize - convert the first letter of words to upper case and the
2003     rest of the word to lower case.
2004     :capitalize-first - convert the first letter of the first word to upper
2005     case and everything else to lower case."
2006     (declare (type stream target)
2007     (type (member :upcase :downcase :capitalize :capitalize-first)
2008     kind)
2009     (values stream))
2010     (if (case-frob-stream-p target)
2011     ;; If we are going to be writing to a stream that already does case
2012     ;; frobbing, why bother frobbing the case just so it can frob it
2013     ;; again?
2014     target
2015     (multiple-value-bind
2016     (out sout)
2017     (ecase kind
2018     (:upcase
2019     (values #'case-frob-upcase-out
2020     #'case-frob-upcase-sout))
2021     (:downcase
2022     (values #'case-frob-downcase-out
2023     #'case-frob-downcase-sout))
2024     (:capitalize
2025     (values #'case-frob-capitalize-out
2026     #'case-frob-capitalize-sout))
2027     (:capitalize-first
2028     (values #'case-frob-capitalize-first-out
2029     #'case-frob-capitalize-first-sout)))
2030     (%make-case-frob-stream target out sout))))
2031    
2032     (defun case-frob-misc (stream op &optional arg1 arg2)
2033     (declare (type case-frob-stream stream))
2034     (case op
2035     (:close)
2036     (t
2037