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

Contents of /src/code/stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.75 - (hide annotations)
Thu Apr 15 01:34:20 2004 UTC (10 years ago) by rtoy
Branch: MAIN
Changes since 1.74: +18 -10 lines
More ANSI test fixes:

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