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

Contents of /src/code/stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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