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

Contents of /src/code/stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.83.6.4.2.4 - (hide annotations)
Fri May 29 19:15:00 2009 UTC (4 years, 10 months ago) by rtoy
Branch: unicode-utf16-extfmt-branch
CVS Tags: unicode-snapshot-2009-06
Changes since 1.83.6.4.2.3: +7 -6 lines
WRITE-SEQUENCE can't use WRITE-INTO-SIMPLE-ARRAY for all vectors
because it doesn't handle vectors whose elements are all characters.
Hence put back the special case for SIMPLE-ARRAY and make the VECTOR
case use WRITE-INTO-VECTOR.

Same issue with READ-SEQUENCE.

A test case:

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