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

Contents of /src/code/stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.87.6.12 - (hide annotations)
Thu Oct 8 02:06:25 2009 UTC (4 years, 6 months ago) by rtoy
Branch: unicode-string-buffer-impl-branch
Changes since 1.87.6.11: +6 -4 lines
fd-stream.lisp:
o EF-COPY-STATE is only for unicode builds.

stream.lisp:
o %SET-FD-STREAM-EXTERNAL-FORMAT and FAST-READ-CHAR-STRING-REFILL are
  %only for unicode builds.

sysmacs.lisp:
o Combine the unicode and non-unicode versions of FAST-REACH-CHAR into
  one macro with one conditionalization internally for unicode.

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