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

Contents of /src/code/stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.57 - (hide annotations)
Thu Dec 12 19:09:46 2002 UTC (11 years, 4 months ago) by moore
Branch: MAIN
Changes since 1.56: +12 -4 lines
Fix a typo in apply-with-bindings.

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