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

Contents of /src/code/stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.87.6.5 - (show annotations)
Fri Sep 25 18:47:31 2009 UTC (4 years, 6 months ago) by rtoy
Branch: unicode-string-buffer-impl-branch
Changes since 1.87.6.4: +3 -1 lines
When EOF is reached, we need to set the string-buffer index to the end
of the string buffer to mark that there's nothing left in the buffer.
1 ;;; -*- Package: Lisp -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; 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 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/stream.lisp,v 1.87.6.5 2009/09/25 18:47:31 rtoy Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Stream functions for Spice Lisp.
13 ;;; Written by Skef Wholey and Rob MacLachlan.
14 ;;; Gray streams support by Douglas Crosher, 1998.
15 ;;; Simple-streams support by Paul Foley, 2003.
16 ;;;
17 ;;; This file contains the OS-independent stream functions.
18 ;;;
19 (in-package "LISP")
20
21 (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 get-output-stream-string stream-element-type input-stream-p
31 output-stream-p open-stream-p interactive-stream-p
32 open-stream-p close read-line read-char
33 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 stream streamp string-stream
37 *standard-input* *standard-output*
38 *error-output* *query-io* *debug-io* *terminal-io* *trace-output*))
39
40 (in-package "SYSTEM")
41 (export '(make-indenting-stream read-n-bytes))
42
43 (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
51 ;;;; 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 (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 (defun ill-in (stream &rest ignore)
79 (declare (ignore ignore))
80 (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 (defun ill-out (stream &rest ignore)
86 (declare (ignore ignore))
87 (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 (defun ill-bin (stream &rest ignore)
93 (declare (ignore ignore))
94 (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 (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 :format-control "~S is not a binary input stream ~
105 or does not support multi-byte read operations."
106 :format-arguments (list stream)))
107 (defun ill-bout (stream &rest ignore)
108 (declare (ignore ignore))
109 (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 (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 (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
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 ;;;
152 ;;; :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 ;;; :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 ;;; :element-type - Return the type of element the stream deals with.
166 ;;; :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 ;;; :interactive-p - Is this an interactive device?
172 ;;;
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
204
205 ;;; Stream manipulation functions.
206
207 (defun input-stream-p (stream)
208 "Returns non-nil if the given Stream can perform input operations."
209 (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 (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
224 (defun output-stream-p (stream)
225 "Returns non-nil if the given Stream can perform output operations."
226 (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 (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
240 (defun open-stream-p (stream)
241 "Return true if Stream is not closed."
242 (declare (type stream stream))
243 ;; 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
251 (defun stream-element-type (stream)
252 "Returns a type specifier for the kind of object returned by the Stream."
253 (declare (type stream stream))
254 ;; 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
262 (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 (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
271 (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 (declare (type stream stream))
288 (stream-dispatch stream
289 ;; simple-stream
290 (stream::%stream-external-format stream)
291 ;; lisp-stream
292 (typecase stream
293 #+unicode
294 (fd-stream (fd-stream-external-format stream))
295 (synonym-stream (stream-external-format
296 (symbol-value (synonym-stream-symbol stream))))
297 (t :default))
298 ;; fundamental-stream
299 :default))
300
301 (defun %set-fd-stream-external-format (stream extfmt)
302 (declare (type fd-stream stream))
303 (setf (fd-stream-external-format stream)
304 (stream::ef-name (stream::find-external-format extfmt))
305 (fd-stream-oc-state stream) nil
306 (fd-stream-co-state stream) nil)
307 (when (fd-stream-ibuf-sap stream) ; input stream
308 (setf (fd-stream-in stream) (ef-cin extfmt)))
309 (when (fd-stream-obuf-sap stream) ; output stream
310 (setf (fd-stream-out stream) (ef-cout extfmt)
311 ;;@@ (fd-stream-sout stream) (ef-sout extfmt)
312 ))
313 extfmt)
314
315 ;; This is only used while building; it's reimplemented in
316 ;; fd-stream-extfmt.lisp
317 (defun (setf stream-external-format) (extfmt stream)
318 (declare (ignore stream))
319 extfmt)
320
321 (defun close (stream &key abort)
322 "Closes the given Stream. No more I/O may be performed, but inquiries
323 may still be made. If :Abort is non-nil, an attempt is made to clean
324 up the side effects of having created the stream."
325 (declare (type stream stream))
326 ;; Note: Gray streams redefines this function; any changes made here need
327 ;; to be duplicated in .../pcl/gray-streams.lisp
328 (stream-dispatch stream
329 ;; simple-stream
330 (stream:device-close stream abort)
331 ;; lisp-stream
332 (when (open-stream-p stream)
333 (funcall (lisp-stream-misc stream) stream :close abort)))
334 t)
335
336 (defun set-closed-flame (stream)
337 (declare (type lisp-stream stream))
338 (setf (lisp-stream-in stream) #'closed-flame)
339 (setf (lisp-stream-bin stream) #'closed-flame)
340 (setf (lisp-stream-n-bin stream) #'closed-flame)
341 (setf (lisp-stream-in stream) #'closed-flame)
342 (setf (lisp-stream-out stream) #'closed-flame)
343 (setf (lisp-stream-bout stream) #'closed-flame)
344 (setf (lisp-stream-sout stream) #'closed-flame)
345 (setf (lisp-stream-misc stream) #'closed-flame))
346
347
348 ;;;; File position and file length.
349
350 ;;; File-Position -- Public
351 ;;;
352 ;;; Call the misc method with the :file-position operation.
353 ;;;
354 (defun file-position (stream &optional position)
355 "With one argument returns the current position within the file
356 File-Stream is open to. If the second argument is supplied, then
357 this becomes the new file position. The second argument may also
358 be :start or :end for the start and end of the file, respectively."
359 (declare (type stream stream)
360 (type (or (integer 0 *) (member nil :start :end)) position))
361 (stream-dispatch stream
362 ;; simple-stream
363 (stream::%file-position stream position)
364 ;; lisp-stream
365 (cond
366 (position
367 (setf (lisp-stream-in-index stream) in-buffer-length)
368 (funcall (lisp-stream-misc stream) stream :file-position position))
369 (t
370 (let ((res (funcall (lisp-stream-misc stream) stream
371 :file-position nil)))
372 (when res
373 (- res (- in-buffer-length (lisp-stream-in-index stream)))))))))
374
375
376 ;;; File-Length -- Public
377 ;;;
378 ;;; Like File-Position, only use :file-length.
379 ;;;
380 (defun file-length (stream)
381 "This function returns the length of the file that File-Stream is open to."
382 (stream-dispatch stream
383 ;; simple-stream
384 (stream::%file-length stream)
385 ;; lisp-stream
386 (funcall (lisp-stream-misc stream) stream :file-length)))
387
388
389 ;;; Input functions:
390
391 (defun read-line (&optional (stream *standard-input*) (eof-errorp t) eof-value
392 recursive-p)
393 "Returns a line of text read from the Stream as a string, discarding the
394 newline character."
395 (let ((stream (in-synonym-of stream)))
396 (stream-dispatch stream
397 ;; simple-stream
398 (stream::%read-line stream eof-errorp eof-value recursive-p)
399 ;; lisp-stream
400 (prepare-for-fast-read-char stream
401 (let ((res (make-string 80))
402 (len 80)
403 (index 0))
404 (loop
405 (let ((ch (fast-read-char nil nil)))
406 (cond (ch
407 (when (char= ch #\newline)
408 (done-with-fast-read-char)
409 (return (values (shrink-vector res index) nil)))
410 (when (= index len)
411 (setq len (* len 2))
412 (let ((new (make-string len)))
413 (replace new res)
414 (setq res new)))
415 (setf (schar res index) ch)
416 (incf index))
417 ((zerop index)
418 (done-with-fast-read-char)
419 (return (values (eof-or-lose stream eof-errorp eof-value)
420 t)))
421 ;; since fast-read-char hit already the eof char, we
422 ;; shouldn't do another read-char
423 (t
424 (done-with-fast-read-char)
425 (return (values (shrink-vector res index) t))))))))
426 ;; fundamental-stream
427 (multiple-value-bind (string eof)
428 (stream-read-line stream)
429 (if (and eof (zerop (length string)))
430 (values (eof-or-lose stream eof-errorp eof-value) t)
431 (values string eof))))))
432
433 ;;; We proclaim them inline here, then proclaim them notinline at EOF,
434 ;;; so, except in this file, they are not inline by default, but they can be.
435 ;;;
436 (declaim (inline read-char unread-char read-byte listen))
437 (defun read-char (&optional (stream *standard-input*) (eof-errorp t) eof-value
438 recursive-p)
439 "Inputs a character from Stream and returns it."
440 (let ((stream (in-synonym-of stream)))
441 (stream-dispatch stream
442 ;; simple-stream
443 (stream::%read-char stream eof-errorp eof-value recursive-p t)
444 ;; lisp-stream
445 (prepare-for-fast-read-char stream
446 (prog1
447 (fast-read-char eof-errorp eof-value)
448 (done-with-fast-read-char)))
449 ;; fundamental-stream
450 (let ((char (stream-read-char stream)))
451 (if (eq char :eof)
452 (eof-or-lose stream eof-errorp eof-value)
453 char)))))
454
455 (defun unread-char (character &optional (stream *standard-input*))
456 "Puts the Character back on the front of the input Stream."
457 (let ((stream (in-synonym-of stream)))
458 (stream-dispatch stream
459 ;; simple-stream
460 (stream::%unread-char stream character)
461 ;; lisp-stream
462 #-unicode
463 (let ((index (1- (lisp-stream-in-index stream)))
464 (buffer (lisp-stream-in-buffer stream)))
465 (declare (fixnum index))
466 (when (minusp index) (error "Nothing to unread."))
467 (cond (buffer
468 (setf (aref buffer index) (char-code character))
469 (setf (lisp-stream-in-index stream) index))
470 (t
471 (funcall (lisp-stream-misc stream) stream
472 :unread character))))
473 #+unicode
474 (let ((sbuf (lisp-stream-string-buffer stream))
475 (ibuf (lisp-stream-in-buffer stream)))
476 (cond (sbuf
477 (let ((index (1- (lisp-stream-string-index stream))))
478 (when (minusp index)
479 (error "Nothing to unread."))
480 (setf (aref sbuf index) character)
481 (setf (lisp-stream-string-index stream) index)))
482 (ibuf
483 (let ((index (1- (lisp-stream-in-index stream))))
484 (when (minusp index)
485 (error "Nothing to unread."))
486 ;; This only works for iso8859-1!
487 (setf (aref ibuf index) (char-code character))
488 (setf (lisp-stream-in-index stream) index)))
489 (t
490 (funcall (lisp-stream-misc stream) stream
491 :unread character))))
492 ;; fundamental-stream
493 (stream-unread-char stream character)))
494 nil)
495
496 ;;; In the interest of ``once and only once'' this macro contains the
497 ;;; framework necessary to implement a peek-char function, which has
498 ;;; two special-cases (one for gray streams and one for echo streams)
499 ;;; in addition to the normal case.
500 ;;;
501 ;;; All arguments are forms which will be used for a specific purpose
502 ;;; PEEK-TYPE - the current peek-type as defined by ANSI CL
503 ;;; EOF-VALUE - the eof-value argument to peek-char
504 ;;; CHAR-VAR - the variable which will be used to store the current character
505 ;;; READ-FORM - the form which will be used to read a character
506 ;;; READ-EOF - the result returned from READ-FORM when eof is reached.
507 ;;; UNREAD-FORM - ditto for unread-char
508 ;;; SKIPPED-CHAR-FORM - the form to execute when skipping a character
509 ;;; EOF-DETECTED-FORM - the form to execute when EOF has been detected
510 ;;; (this will default to CHAR-VAR)
511 (defmacro generalized-peeking-mechanism (peek-type eof-value char-var
512 read-form read-eof unread-form
513 &key (skipped-char-form nil)
514 (eof-detected-form nil))
515 `(let ((,char-var ,read-form))
516 (cond ((eql ,char-var ,read-eof)
517 ,(if eof-detected-form
518 eof-detected-form
519 eof-value))
520 ((characterp ,peek-type)
521 (do ((,char-var ,char-var ,read-form))
522 ((or (eql ,char-var ,read-eof)
523 (char= ,char-var ,peek-type))
524 (cond ((eql ,char-var ,read-eof)
525 ,(if eof-detected-form
526 eof-detected-form
527 eof-value))
528 (t ,unread-form
529 ,char-var)))
530 ,skipped-char-form))
531 ((eql ,peek-type t)
532 (do ((,char-var ,char-var ,read-form))
533 ((or (eql ,char-var ,read-eof)
534 (not (eql (get-cat-entry ,char-var *readtable*) whitespace)))
535 (cond ((eql ,char-var ,read-eof)
536 ,(if eof-detected-form
537 eof-detected-form
538 eof-value))
539 (t ,unread-form
540 ,char-var)))
541 ,skipped-char-form))
542 ((null ,peek-type)
543 ,unread-form
544 ,(if eof-detected-form
545 (when (eql char-var read-eof)
546 eof-detected-form))
547 ,char-var)
548 (t
549 (error "Impossible case reached in PEEK-CHAR")))))
550
551 (defun peek-char (&optional (peek-type nil) (stream *standard-input*)
552 (eof-errorp t) eof-value recursive-p)
553 "Peeks at the next character in the input Stream. See manual for details."
554 ;; FIXME: The type of PEEK-TYPE is also declared in a DEFKNOWN, but
555 ;; the compiler doesn't seem to be smart enough to go from there to
556 ;; imposing a type check. Figure out why (because PEEK-TYPE is an
557 ;; &OPTIONAL argument?) and fix it, and then this explicit type
558 ;; check can go away.
559 (unless (typep peek-type '(or character boolean))
560 (error 'simple-type-error
561 :datum peek-type
562 :expected-type '(or character boolean)
563 :format-control "~@<bad PEEK-TYPE=~S, ~_expected ~S~:>"
564 :format-arguments (list peek-type '(or character boolean))))
565 (let ((stream (in-synonym-of stream)))
566 (if (typep stream 'echo-stream)
567 (echo-misc stream :peek-char peek-type (list eof-errorp eof-value))
568 (stream-dispatch stream
569 ;; simple-stream
570 (stream::%peek-char stream peek-type eof-errorp eof-value
571 recursive-p)
572 ;; lisp-stream
573 (generalized-peeking-mechanism
574 peek-type eof-value char
575 (read-char stream eof-errorp :eof)
576 :eof
577 (unread-char char stream)
578 :skipped-char-form nil
579 :eof-detected-form (eof-or-lose stream (or eof-errorp recursive-p) eof-value))
580 ;; fundamental-stream
581 (generalized-peeking-mechanism
582 peek-type :eof char
583 (if (null peek-type)
584 (stream-peek-char stream)
585 (stream-read-char stream))
586 :eof
587 (if (null peek-type)
588 ()
589 (stream-unread-char stream char))
590 :skipped-char-form ()
591 :eof-detected-form (eof-or-lose stream eof-errorp eof-value))))))
592
593 (defun listen (&optional (stream *standard-input*) (width 1))
594 "Returns T if a character is available on the given Stream."
595 (declare (type streamlike stream))
596 (let ((stream (in-synonym-of stream)))
597 (stream-dispatch stream
598 ;; simple-stream
599 (stream::%listen stream width)
600 ;; lisp-stream
601 (or (/= (the fixnum (lisp-stream-in-index stream)) in-buffer-length)
602 ;; Test for t explicitly since misc methods return :eof sometimes.
603 (eq (funcall (lisp-stream-misc stream) stream :listen) t))
604 ;; fundamental-stream
605 (stream-listen stream))))
606
607 (defun read-char-no-hang (&optional (stream *standard-input*)
608 (eof-errorp t) eof-value recursive-p)
609 "Returns the next character from the Stream if one is available, or nil."
610 (let ((stream (in-synonym-of stream)))
611 (stream-dispatch stream
612 ;; simple-stream
613 (stream::%read-char stream eof-errorp eof-value recursive-p nil)
614 ;; lisp-stream
615 (if (funcall (lisp-stream-misc stream) stream :listen)
616 ;; On t or :eof get READ-CHAR to do the work.
617 (read-char stream eof-errorp eof-value)
618 nil)
619 ;; fundamental-stream
620 (let ((char (stream-read-char-no-hang stream)))
621 (if (eq char :eof)
622 (eof-or-lose stream eof-errorp eof-value)
623 char)))))
624
625
626 (defun clear-input (&optional (stream *standard-input*) buffer-only)
627 "Clears any buffered input associated with the Stream."
628 (declare (type streamlike stream))
629 (let ((stream (in-synonym-of stream)))
630 (stream-dispatch stream
631 ;; simple-stream
632 (stream::%clear-input stream buffer-only)
633 ;; lisp-stream
634 (progn
635 (setf (lisp-stream-in-index stream) in-buffer-length)
636 (funcall (lisp-stream-misc stream) stream :clear-input))
637 ;; fundamental-stream
638 (stream-clear-input stream)))
639 nil)
640
641 (defun read-byte (stream &optional (eof-errorp t) eof-value)
642 "Returns the next byte of the Stream."
643 (declare (type stream stream))
644 (let ((stream (in-synonym-of stream)))
645 (stream-dispatch stream
646 ;; simple-stream
647 (stream::%read-byte stream eof-errorp eof-value)
648 ;; lisp-stream
649 (prepare-for-fast-read-byte stream
650 (prog1
651 (fast-read-byte eof-errorp eof-value t)
652 (done-with-fast-read-byte)))
653 ;; fundamental-stream
654 (let ((char (stream-read-byte stream)))
655 (if (eq char :eof)
656 (eof-or-lose stream eof-errorp eof-value)
657 char)))))
658
659 (defun read-n-bytes (stream buffer start numbytes &optional (eof-errorp t))
660 "Reads Numbytes bytes into the Buffer starting at Start, returning the number
661 of bytes read.
662 -- If EOF-ERROR-P is true, an END-OF-FILE condition is signalled if
663 end-of-file is encountered before Count bytes have been read.
664 -- If EOF-ERROR-P is false, READ-N-BYTES reads as much data as is currently
665 available (up to count bytes). On pipes or similar devices, this
666 function returns as soon as any data is available, even if the amount
667 read is less than Count and eof has not been hit."
668 (declare (type lisp-stream stream)
669 (type index numbytes start)
670 (type (or (simple-array * (*)) system-area-pointer) buffer))
671 (let* ((stream (in-synonym-of stream lisp-stream))
672 (in-buffer (lisp-stream-in-buffer stream))
673 (index (lisp-stream-in-index stream))
674 (num-buffered (- in-buffer-length index)))
675 (declare (fixnum index num-buffered))
676 (cond
677 ((not in-buffer)
678 (funcall (lisp-stream-n-bin stream) stream
679 buffer start numbytes eof-errorp))
680 ((<= numbytes num-buffered)
681 (%primitive byte-blt in-buffer index buffer start (+ start numbytes))
682 (setf (lisp-stream-in-index stream) (+ index numbytes))
683 numbytes)
684 (t
685 (let ((end (+ start num-buffered)))
686 (%primitive byte-blt in-buffer index buffer start end)
687 (setf (lisp-stream-in-index stream) in-buffer-length)
688 (+ (funcall (lisp-stream-n-bin stream) stream buffer end
689 (- numbytes num-buffered)
690 eof-errorp)
691 num-buffered))))))
692
693
694 ;;; Amount of space we leave at the start of the in-buffer for unreading. 4
695 ;;; instead of 1 to allow word-aligned copies.
696 ;;;
697 (defconstant in-buffer-extra 4)
698
699 ;;; FAST-READ-CHAR-REFILL -- Interface
700 ;;;
701 ;;; This function is called by the fast-read-char expansion to refill the
702 ;;; in-buffer for text streams. There is definitely an in-buffer, and hence
703 ;;; must be an n-bin method.
704 ;;;
705 (defun fast-read-char-refill (stream eof-errorp eof-value)
706 (let* ((ibuf (lisp-stream-in-buffer stream))
707 (count (funcall (lisp-stream-n-bin stream) stream
708 ibuf in-buffer-extra
709 (- in-buffer-length in-buffer-extra)
710 nil))
711 (start (- in-buffer-length count)))
712 (declare (type index start count))
713 (cond ((zerop count)
714 (setf (lisp-stream-in-index stream) in-buffer-length)
715 (funcall (lisp-stream-in stream) stream eof-errorp eof-value))
716 (t
717 (when (/= start in-buffer-extra)
718 (bit-bash-copy ibuf (+ (* in-buffer-extra vm:byte-bits)
719 (* vm:vector-data-offset vm:word-bits))
720 ibuf (+ (the index (* start vm:byte-bits))
721 (* vm:vector-data-offset vm:word-bits))
722 (* count vm:byte-bits)))
723 (setf (lisp-stream-in-index stream) (1+ start))
724 (code-char (aref ibuf start))))))
725
726 (defun fast-read-char-string-refill (stream eof-errorp eof-value)
727 #+debug-frcs
728 (progn
729 (format *debug-io* "fast-read-char-refill. Stream before refill:~%")
730 (describe stream))
731
732 ;; Like fast-read-char-refill, but we don't need or want the
733 ;; in-buffer-extra.
734 (let* ((ibuf (lisp-stream-in-buffer stream))
735 (index (lisp-stream-in-index stream)))
736 (declare (type index))
737 ;; Copy the stuff we haven't read to the beginning of the buffer.
738 (replace ibuf ibuf
739 :start1 0
740 :start2 index :end2 in-buffer-length)
741 (let ((count (funcall (lisp-stream-n-bin stream) stream
742 ibuf (- in-buffer-length index)
743 index
744 nil)))
745 (declare (type index count))
746 #+nil
747 (format *debug-io* "### Refill. index = ~D, count = ~D~%" index count)
748
749 (cond ((zerop count)
750 (setf (lisp-stream-in-index stream) in-buffer-length)
751 (setf (lisp-stream-string-index stream)
752 (lisp-stream-string-buffer-len stream))
753 (funcall (lisp-stream-in stream) stream eof-errorp eof-value))
754 (t
755 #+debug-frcs
756 (progn
757 (format *debug-io* "~& Stream after refill:~%")
758 (describe stream))
759
760 (setf (lisp-stream-in-index stream) 0)
761 (let ((sbuf (lisp-stream-string-buffer stream))
762 (slen (lisp-stream-string-buffer-len stream)))
763
764 ;; Copy the last read character to the beginning of the
765 ;; buffer to support unreading.
766 (when (plusp slen)
767 (setf (schar sbuf 0) (schar sbuf (1- slen))))
768
769 ;; Convert all the octets, including the ones that we
770 ;; haven't read and the ones we just read in.
771 (multiple-value-bind (s char-count octet-count)
772 (octets-to-string ibuf
773 :start 0
774 :end (+ count (- in-buffer-length index))
775 :string sbuf
776 :s-start 1
777 :external-format (fd-stream-external-format stream))
778 (declare (ignore s))
779
780 (setf (lisp-stream-string-buffer-len stream) char-count)
781 (setf (lisp-stream-string-index stream) 2)
782 (incf (lisp-stream-in-index stream) octet-count)
783 #+nil
784 (progn
785 (format *debug-io* "~& ### After refill, char-count, octet-count, string len = ~S ~S~%"
786 char-count octet-count)
787 (format *debug-io* "String = ~S~%" (subseq (lisp-stream-string-buffer stream)
788 1 char-count))
789 (format *debug-io* "~& Stream after OS~%")
790 (describe stream))
791 (schar (lisp-stream-string-buffer stream) 1))))))))
792
793
794 ;;; FAST-READ-BYTE-REFILL -- Interface
795 ;;;
796 ;;; Similar to FAST-READ-CHAR-REFILL, but we don't have to leave room for
797 ;;; unreading.
798 ;;;
799 (defun fast-read-byte-refill (stream eof-errorp eof-value)
800 (let* ((ibuf (lisp-stream-in-buffer stream))
801 (count (funcall (lisp-stream-n-bin stream) stream
802 ibuf 0 in-buffer-length
803 nil))
804 (start (- in-buffer-length count)))
805 (declare (type index start count))
806 (cond ((zerop count)
807 (setf (lisp-stream-in-index stream) in-buffer-length)
808 (funcall (lisp-stream-bin stream) stream eof-errorp eof-value))
809 (t
810 (unless (zerop start)
811 (bit-bash-copy ibuf (* vm:vector-data-offset vm:word-bits)
812 ibuf (+ (the index (* start vm:byte-bits))
813 (* vm:vector-data-offset vm:word-bits))
814 (* count vm:byte-bits)))
815 (setf (lisp-stream-in-index stream) (1+ start))
816 (aref ibuf start)))))
817
818
819 ;;; Output functions:
820
821 (defun write-char (character &optional (stream *standard-output*))
822 "Outputs the Character to the Stream."
823 (declare (type streamlike stream))
824 (let ((stream (out-synonym-of stream)))
825 (stream-dispatch stream
826 ;; simple-stream
827 (stream::%write-char stream character)
828 ;; lisp-stream
829 (funcall (lisp-stream-out stream) stream character)
830 ;; fundamental-stream
831 (stream-write-char stream character)))
832 character)
833
834 (defun terpri (&optional (stream *standard-output*))
835 "Outputs a new line to the Stream."
836 (declare (type streamlike stream))
837 (let ((stream (out-synonym-of stream)))
838 (stream-dispatch stream
839 ;; simple-stream
840 (stream::%write-char stream #\Newline)
841 ;; lisp-stream
842 (funcall (lisp-stream-out stream) stream #\Newline)
843 ;; fundamental-stream
844 (stream-terpri stream)))
845 nil)
846
847 (defun fresh-line (&optional (stream *standard-output*))
848 "Outputs a new line to the Stream if it is not positioned at the beginning of
849 a line. Returns T if it output a new line, nil otherwise."
850 (declare (type streamlike stream))
851 (let ((stream (out-synonym-of stream)))
852 (stream-dispatch stream
853 ;; simple-stream
854 (stream::%fresh-line stream)
855 ;; lisp-stream
856 (when (/= (or (charpos stream) 1) 0)
857 (funcall (lisp-stream-out stream) stream #\newline)
858 t)
859 ;; fundamental-stream
860 (stream-fresh-line stream))))
861
862 (defun write-string (string &optional (stream *standard-output*)
863 &key (start 0) end)
864 "Outputs the String to the given Stream."
865 (write-string* string stream start (or end (length (the vector string)))))
866
867 (defun write-string* (string &optional (stream *standard-output*)
868 (start 0) (end (length (the vector string))))
869 (declare (type streamlike stream) (fixnum start end))
870 (let ((stream (out-synonym-of stream)))
871 (stream-dispatch stream
872 ;; simple-stream
873 (if (array-header-p string)
874 (with-array-data ((data string) (offset-start start)
875 (offset-end end))
876 (stream::%write-string stream data offset-start offset-end))
877 (stream::%write-string stream string start end))
878 ;; lisp-stream
879 (if (array-header-p string)
880 (with-array-data ((data string) (offset-start start)
881 (offset-end end))
882 (funcall (lisp-stream-sout stream)
883 stream data offset-start offset-end))
884 (funcall (lisp-stream-sout stream) stream string start end))
885 ;; fundamental-stream
886 (stream-write-string stream string start end)))
887 string)
888
889 (defun write-line (string &optional (stream *standard-output*)
890 &key (start 0) (end (length string)))
891 "Outputs the String to the given Stream, followed by a newline character."
892 (write-line* string stream start (or end (length string))))
893
894 (defun write-line* (string &optional (stream *standard-output*)
895 (start 0) (end (length string)))
896 (declare (type streamlike stream) (fixnum start end))
897 (let ((stream (out-synonym-of stream)))
898 (stream-dispatch stream
899 ;; simple-stream
900 (progn
901 (if (array-header-p string)
902 (with-array-data ((data string) (offset-start start)
903 (offset-end end))
904 (stream::%write-string stream data offset-start offset-end))
905 (stream::%write-string stream string start end))
906 (stream::%write-char stream #\Newline))
907 ;; lisp-stream
908 (progn
909 (if (array-header-p string)
910 (with-array-data ((data string) (offset-start start)
911 (offset-end end))
912 (funcall (lisp-stream-sout stream) stream data offset-start
913 offset-end))
914 (funcall (lisp-stream-sout stream) stream string start end))
915 (funcall (lisp-stream-out stream) stream #\newline))
916 ;; fundamental-stream
917 (progn
918 (stream-write-string stream string start end)
919 (stream-write-char stream #\Newline)))
920 string))
921
922 (defun charpos (&optional (stream *standard-output*))
923 "Returns the number of characters on the current line of output of the given
924 Stream, or Nil if that information is not availible."
925 (declare (type streamlike stream))
926 (let ((stream (out-synonym-of stream)))
927 (stream-dispatch stream
928 ;; simple-stream
929 (stream::%charpos stream)
930 ;; lisp-stream
931 (funcall (lisp-stream-misc stream) stream :charpos)
932 ;; fundamental-stream
933 (stream-line-column stream))))
934
935 (defun line-length (&optional (stream *standard-output*))
936 "Returns the number of characters that will fit on a line of output on the
937 given Stream, or Nil if that information is not available."
938 (declare (type streamlike stream))
939 (let ((stream (out-synonym-of stream)))
940 (stream-dispatch stream
941 ;; simple-stream
942 (stream::%line-length stream)
943 ;; lisp-stream
944 (funcall (lisp-stream-misc stream) stream :line-length)
945 ;; fundamental-stream
946 (stream-line-length stream))))
947
948 (defun finish-output (&optional (stream *standard-output*))
949 "Attempts to ensure that all output sent to the Stream has reached its
950 destination, and only then returns."
951 (declare (type streamlike stream))
952 (let ((stream (out-synonym-of stream)))
953 (stream-dispatch stream
954 ;; simple-stream
955 (stream::%finish-output stream)
956 ;; lisp-stream
957 (funcall (lisp-stream-misc stream) stream :finish-output)
958 ;; fundamental-stream
959 (stream-finish-output stream)))
960 nil)
961
962 (defun force-output (&optional (stream *standard-output*))
963 "Attempts to force any buffered output to be sent."
964 (declare (type streamlike stream))
965 (let ((stream (out-synonym-of stream)))
966 (stream-dispatch stream
967 ;; simple-stream
968 (stream::%force-output stream)
969 ;; lisp-stream-misc
970 (funcall (lisp-stream-misc stream) stream :force-output)
971 ;; fundamental-stream
972 (stream-force-output stream)))
973 nil)
974
975 (defun clear-output (&optional (stream *standard-output*))
976 "Clears the given output Stream."
977 (declare (type streamlike stream))
978 (let ((stream (out-synonym-of stream)))
979 (stream-dispatch stream
980 ;; simple-stream
981 (stream::%clear-output stream)
982 ;; lisp-stream
983 (funcall (lisp-stream-misc stream) stream :clear-output)
984 ;; fundamental-stream
985 (stream-force-output stream)))
986 nil)
987
988 (defun write-byte (integer stream)
989 "Outputs the Integer to the binary Stream."
990 (declare (type stream stream))
991 (let ((stream (out-synonym-of stream)))
992 (stream-dispatch stream
993 ;; simple-stream
994 (stream::%write-byte stream integer)
995 ;; lisp-stream
996 (funcall (lisp-stream-bout stream) stream integer)
997 ;; fundamental-stream
998 (stream-write-byte stream integer)))
999 integer)
1000
1001
1002 ;;; Stream-misc-dispatch
1003 ;;;
1004 ;;; Called from lisp-stream routines that encapsulate CLOS streams to
1005 ;;; handle the misc routines and dispatch to the appropriate Gray
1006 ;;; stream functions.
1007 ;;;
1008 (defun stream-misc-dispatch (stream operation &optional arg1 arg2)
1009 (declare (type fundamental-stream stream)
1010 (ignore arg2))
1011 (case operation
1012 (:listen
1013 ;; Return true if input available, :eof for end-of-file, otherwise Nil.
1014 (let ((char (stream-read-char-no-hang stream)))
1015 (when (characterp char)
1016 (stream-unread-char stream char))
1017 char))
1018 (:unread
1019 (stream-unread-char stream arg1))
1020 (:close
1021 (close stream))
1022 (:clear-input
1023 (stream-clear-input stream))
1024 (:force-output
1025 (stream-force-output stream))
1026 (:finish-output
1027 (stream-finish-output stream))
1028 (:element-type
1029 (stream-element-type stream))
1030 (:interactive-p
1031 (interactive-stream-p stream))
1032 (:line-length
1033 (stream-line-length stream))
1034 (:charpos
1035 (stream-line-column stream))
1036 (:file-length
1037 (file-length stream))
1038 (:file-position
1039 (file-position stream arg1))))
1040
1041
1042 ;;;; Broadcast streams:
1043
1044 (defstruct (broadcast-stream (:include lisp-stream
1045 (out #'broadcast-out)
1046 (bout #'broadcast-bout)
1047 (sout #'broadcast-sout)
1048 (misc #'broadcast-misc))
1049 (:print-function %print-broadcast-stream)
1050 (:constructor %make-broadcast-stream (&rest streams)))
1051 ;; This is a list of all the streams we broadcast to.
1052 (streams () :type list :read-only t))
1053
1054 (defun make-broadcast-stream (&rest streams)
1055 "Returns an output stream which sends its output to all of the given
1056 streams."
1057 (dolist (s streams)
1058 (unless (output-stream-p s)
1059 (ill-out-any s)))
1060
1061 (apply #'%make-broadcast-stream streams))
1062
1063 (defun %print-broadcast-stream (s stream d)
1064 (declare (ignore s d))
1065 (write-string "#<Broadcast Stream>" stream))
1066
1067 (macrolet ((out-fun (fun method stream-method &rest args)
1068 `(defun ,fun (stream ,@args)
1069 (dolist (stream (broadcast-stream-streams stream))
1070 (stream-dispatch stream
1071 ;; simple-stream
1072 (,stream-method stream ,@args) ; use gray-compat for now
1073 ;; lisp-stream
1074 (funcall (,method stream) stream ,@args)
1075 ;; fundamental-stream
1076 (,stream-method stream ,@args))))))
1077 (out-fun broadcast-out lisp-stream-out stream-write-char char)
1078 (out-fun broadcast-bout lisp-stream-bout stream-write-byte byte)
1079 (out-fun broadcast-sout lisp-stream-sout stream-write-string
1080 string start end))
1081
1082 (defun broadcast-misc (stream operation &optional arg1 arg2)
1083 (let ((streams (broadcast-stream-streams stream)))
1084 (case operation
1085 (:charpos
1086 (dolist (stream streams 0)
1087 (let ((charpos (charpos stream)))
1088 (if charpos (return charpos)))))
1089 (:line-length
1090 (let ((min nil))
1091 (dolist (stream streams min)
1092 (let ((res (line-length stream)))
1093 (when res (setq min (if min (min res min) res)))))))
1094 ;; CLHS: The functions file-length, file-position, file-string-length, and
1095 ;; stream-external-format return the value from the last component
1096 ;; stream; if there are no component streams, file-length and
1097 ;; file-position return 0, file-string-length returns 1, and
1098 ;; stream-external-format returns :default.
1099 (:file-length
1100 (if (null streams) 0
1101 (file-length (first (last streams)))))
1102 (:file-position
1103 (if (null streams) 0
1104 (file-position (first (last streams)))))
1105 (:element-type
1106 #+nil ; old, arguably more logical, version
1107 (let (res)
1108 (dolist (stream streams (if (> (length res) 1) `(and ,@res) t))
1109 (pushnew (stream-element-type stream) res :test #'equal)))
1110 ;; ANSI-specified version (under System Class BROADCAST-STREAM)
1111 (let ((res t))
1112 (do ((streams streams (cdr streams)))
1113 ((null streams) res)
1114 (when (null (cdr streams))
1115 (setq res (stream-element-type (car streams)))))))
1116 (:close)
1117 (t
1118 (let ((res nil))
1119 (dolist (stream streams res)
1120 (setq res
1121 (if (lisp-stream-p stream)
1122 (funcall (lisp-stream-misc stream) stream operation
1123 arg1 arg2)
1124 (stream-misc-dispatch stream operation arg1 arg2)))))))))
1125
1126
1127 ;;;; Synonym Streams:
1128
1129 (defstruct (synonym-stream (:include lisp-stream
1130 (in #'synonym-in)
1131 (bin #'synonym-bin)
1132 (n-bin #'synonym-n-bin)
1133 (out #'synonym-out)
1134 (bout #'synonym-bout)
1135 (sout #'synonym-sout)
1136 (misc #'synonym-misc))
1137 (:print-function %print-synonym-stream)
1138 (:constructor make-synonym-stream (symbol)))
1139 ;; This is the symbol, the value of which is the stream we are synonym to.
1140 (symbol nil :type symbol :read-only t))
1141
1142 (defun %print-synonym-stream (s stream d)
1143 (declare (ignore d))
1144 (format stream "#<Synonym Stream to ~S>" (synonym-stream-symbol s)))
1145
1146 (setf (documentation 'make-synonym-stream 'function)
1147 "Returns a stream which performs its operations on the stream which is the
1148 value of the dynamic variable named by Symbol.")
1149
1150 ;;; The output simple output methods just call the corresponding method
1151 ;;; in the synonymed stream.
1152 ;;;
1153 (macrolet ((out-fun (name slot stream-method &rest args)
1154 `(defun ,name (stream ,@args)
1155 (declare (optimize (safety 1)))
1156 (let ((syn (symbol-value (synonym-stream-symbol stream))))
1157 (if (lisp-stream-p syn)
1158 (funcall (,slot syn) syn ,@args)
1159 (,stream-method syn ,@args))))))
1160 (out-fun synonym-out lisp-stream-out stream-write-char ch)
1161 (out-fun synonym-bout lisp-stream-bout stream-write-byte n)
1162 (out-fun synonym-sout lisp-stream-sout stream-write-string string start end))
1163
1164
1165 ;;; Bind synonym stream to this so that SPIO can turn on the right frob in
1166 ;;; the icon when we are in a terminal input wait.
1167 ;;;
1168 (defvar *previous-stream* nil)
1169
1170 ;;; For the input methods, we just call the corresponding function on the
1171 ;;; synonymed stream. These functions deal with getting input out of
1172 ;;; the In-Buffer if there is any.
1173 ;;;
1174 (macrolet ((in-fun (name fun &rest args)
1175 `(defun ,name (stream ,@args)
1176 (declare (optimize (safety 1)))
1177 (let ((*previous-stream* stream))
1178 (,fun (symbol-value (synonym-stream-symbol stream)) ,@args)))))
1179 (in-fun synonym-in read-char eof-errorp eof-value)
1180 (in-fun synonym-bin read-byte eof-errorp eof-value)
1181 (in-fun synonym-n-bin read-n-bytes buffer start numbytes eof-errorp))
1182
1183
1184 ;;; Synonym-Misc -- Internal
1185 ;;;
1186 ;;; We have to special-case the operations which could look at stuff in
1187 ;;; the in-buffer.
1188 ;;;
1189 (defun synonym-misc (stream operation &optional arg1 arg2)
1190 (declare (optimize (safety 1)))
1191 (let ((syn (symbol-value (synonym-stream-symbol stream)))
1192 (*previous-stream* stream))
1193 (if (lisp-stream-p syn)
1194 (case operation
1195 (:listen (or (/= (the fixnum (lisp-stream-in-index syn))
1196 in-buffer-length)
1197 (funcall (lisp-stream-misc syn) syn :listen)))
1198 (:clear-input (clear-input syn))
1199 (:unread (unread-char arg1 syn))
1200 (t
1201 (funcall (lisp-stream-misc syn) syn operation arg1 arg2)))
1202 (stream-misc-dispatch syn operation arg1 arg2))))
1203
1204 ;;;; Two-Way streams:
1205
1206 (defstruct (two-way-stream
1207 (:include lisp-stream
1208 (in #'two-way-in)
1209 (bin #'two-way-bin)
1210 (n-bin #'two-way-n-bin)
1211 (out #'two-way-out)
1212 (bout #'two-way-bout)
1213 (sout #'two-way-sout)
1214 (misc #'two-way-misc))
1215 (:print-function %print-two-way-stream)
1216 (:constructor %make-two-way-stream (input-stream output-stream)))
1217 ;; We read from this stream...
1218 (input-stream (required-argument) :type stream :read-only t)
1219 ;; And write to this one
1220 (output-stream (required-argument) :type stream :read-only t))
1221
1222 (defun %print-two-way-stream (s stream d)
1223 (declare (ignore d))
1224 (format stream "#<Two-Way Stream, Input = ~S, Output = ~S>"
1225 (two-way-stream-input-stream s)
1226 (two-way-stream-output-stream s)))
1227
1228 (defun make-two-way-stream (input-stream output-stream)
1229 "Returns a bidirectional stream which gets its input from Input-Stream and
1230 sends its output to Output-Stream."
1231 (unless (input-stream-p input-stream)
1232 (ill-in-any input-stream))
1233 (unless (output-stream-p output-stream)
1234 (ill-out-any output-stream))
1235
1236 (%make-two-way-stream input-stream output-stream))
1237
1238 (macrolet ((out-fun (name slot stream-method &rest args)
1239 `(defun ,name (stream ,@args)
1240 (let ((syn (two-way-stream-output-stream stream)))
1241 (if (lisp-stream-p syn)
1242 (funcall (,slot syn) syn ,@args)
1243 (,stream-method syn ,@args))))))
1244 (out-fun two-way-out lisp-stream-out stream-write-char ch)
1245 (out-fun two-way-bout lisp-stream-bout stream-write-byte n)
1246 (out-fun two-way-sout lisp-stream-sout stream-write-string string start end))
1247
1248 (macrolet ((in-fun (name fun &rest args)
1249 `(defun ,name (stream ,@args)
1250 (force-output (two-way-stream-output-stream stream))
1251 (,fun (two-way-stream-input-stream stream) ,@args))))
1252 (in-fun two-way-in read-char eof-errorp eof-value)
1253 (in-fun two-way-bin read-byte eof-errorp eof-value)
1254 (in-fun two-way-n-bin read-n-bytes buffer start numbytes eof-errorp))
1255
1256 (defun two-way-misc (stream operation &optional arg1 arg2)
1257 (let* ((in (two-way-stream-input-stream stream))
1258 (out (two-way-stream-output-stream stream))
1259 (in-lisp-stream-p (lisp-stream-p in))
1260 (out-lisp-stream-p (lisp-stream-p out)))
1261 (case operation
1262 (:listen
1263 (if in-lisp-stream-p
1264 (or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length)
1265 (funcall (lisp-stream-misc in) in :listen))
1266 (stream-listen in)))
1267 ((:finish-output :force-output :clear-output)
1268 (if out-lisp-stream-p
1269 (funcall (lisp-stream-misc out) out operation arg1 arg2)
1270 (stream-misc-dispatch out operation arg1 arg2)))
1271 (:clear-input (clear-input in))
1272 (:unread (unread-char arg1 in))
1273 (:element-type
1274 (let ((in-type (stream-element-type in))
1275 (out-type (stream-element-type out)))
1276 (if (equal in-type out-type)
1277 in-type `(and ,in-type ,out-type))))
1278 (:close
1279 (set-closed-flame stream))
1280 (:file-length
1281 (error 'type-error :datum stream :expected-type 'file-stream))
1282 (:charpos
1283 (charpos out))
1284 (:line-length
1285 (line-length out))
1286 (t
1287 (or (if in-lisp-stream-p
1288 (funcall (lisp-stream-misc in) in operation arg1 arg2)
1289 (stream-misc-dispatch in operation arg1 arg2))
1290 (if out-lisp-stream-p
1291 (funcall (lisp-stream-misc out) out operation arg1 arg2)
1292 (stream-misc-dispatch out operation arg1 arg2)))))))
1293
1294
1295 ;;;; Concatenated Streams:
1296
1297 (defstruct (concatenated-stream
1298 (:include lisp-stream
1299 (in #'concatenated-in)
1300 (bin #'concatenated-bin)
1301 (n-bin #'concatenated-n-bin)
1302 (misc #'concatenated-misc))
1303 (:print-function %print-concatenated-stream)
1304 (:constructor %make-concatenated-stream (&rest streams)))
1305 ;; This is a list of all the streams. The car of this is the stream
1306 ;; we are reading from now.
1307 (streams nil :type list))
1308
1309 (defun %print-concatenated-stream (s stream d)
1310 (declare (ignore d))
1311 (format stream "#<Concatenated Stream, Streams = ~S>"
1312 (concatenated-stream-streams s)))
1313
1314 (defun make-concatenated-stream (&rest streams)
1315 "Returns a stream which takes its input from each of the Streams in turn,
1316 going on to the next at EOF."
1317 (dolist (s streams)
1318 (unless (input-stream-p s)
1319 (ill-in-any s)))
1320 (apply #'%make-concatenated-stream streams))
1321
1322 (macrolet ((in-fun (name fun)
1323 `(defun ,name (stream eof-errorp eof-value)
1324 (do ((current (concatenated-stream-streams stream)
1325 (cdr current)))
1326 ((null current)
1327 (eof-or-lose stream eof-errorp eof-value))
1328 (let* ((stream (car current))
1329 (result (,fun stream nil nil)))
1330 (when result (return result)))
1331 (setf (concatenated-stream-streams stream) (cdr current))))))
1332 (in-fun concatenated-in read-char)
1333 (in-fun concatenated-bin read-byte))
1334
1335 (defun concatenated-n-bin (stream buffer start numbytes eof-errorp)
1336 (do ((current (concatenated-stream-streams stream) (cdr current))
1337 (current-start start)
1338 (remaining-bytes numbytes))
1339 ((null current)
1340 (if eof-errorp
1341 (error 'end-of-file :stream stream)
1342 (- numbytes remaining-bytes)))
1343 (let* ((stream (car current))
1344 (bytes-read (read-n-bytes stream buffer current-start
1345 remaining-bytes nil)))
1346 (incf current-start bytes-read)
1347 (decf remaining-bytes bytes-read)
1348 (when (zerop remaining-bytes) (return numbytes)))
1349 (setf (concatenated-stream-streams stream) (cdr current))))
1350
1351 (defun concatenated-misc (stream operation &optional arg1 arg2)
1352 (let ((current (first (concatenated-stream-streams stream))))
1353 (case operation
1354 (:listen
1355 (if current
1356 (loop
1357 (let ((stuff (if (lisp-stream-p current)
1358 (funcall (lisp-stream-misc current) current
1359 :listen)
1360 (stream-misc-dispatch current :listen))))
1361 (cond ((eq stuff :eof)
1362 ;; Advance current, and try again.
1363 (pop (concatenated-stream-streams stream))
1364 (setf current (first (concatenated-stream-streams stream)))
1365 (unless current (return :eof)))
1366 (stuff
1367 ;; Stuff's available.
1368 (return t))
1369 (t
1370 ;; Nothing available yet.
1371 (return nil)))))
1372 :eof))
1373 (:close
1374 (set-closed-flame stream))
1375 (:clear-input
1376 (when current (clear-input current)))
1377 (:unread
1378 (when current (unread-char arg1 current)))
1379 (:file-length
1380 (error 'type-error :datum stream :expected-type 'file-stream))
1381 (t
1382 (if (lisp-stream-p current)
1383 (funcall (lisp-stream-misc current) current operation arg1 arg2)
1384 (stream-misc-dispatch current operation arg1 arg2))))))
1385
1386
1387 ;;;; Echo Streams:
1388
1389 (defstruct (echo-stream
1390 (:include two-way-stream
1391 (in #'echo-in)
1392 (bin #'echo-bin)
1393 (misc #'echo-misc)
1394 (n-bin #'echo-n-bin))
1395 (:print-function %print-echo-stream)
1396 (:constructor %make-echo-stream (input-stream output-stream)))
1397 unread-stuff)
1398
1399 (defun make-echo-stream (input-stream output-stream)
1400 "Returns an echo stream that takes input from Input-stream and sends
1401 output to Output-stream"
1402 (unless (input-stream-p input-stream)
1403 (ill-in-any input-stream))
1404 (unless (output-stream-p output-stream)
1405 (ill-out-any output-stream))
1406 (%make-echo-stream input-stream output-stream))
1407
1408 (macrolet ((in-fun (name fun out-slot stream-method)
1409 `(defun ,name (stream eof-errorp eof-value)
1410 (or (pop (echo-stream-unread-stuff stream))
1411 (let* ((in (echo-stream-input-stream stream))
1412 (out (echo-stream-output-stream stream))
1413 (result (,fun in nil :eof)))
1414 (cond ((eq result :eof)
1415 (eof-or-lose stream eof-errorp eof-value))
1416 (t
1417 (if (lisp-stream-p out)
1418 (funcall (,out-slot out) out result)
1419 (,stream-method out result))
1420 result)))))))
1421 (in-fun echo-in read-char lisp-stream-out stream-write-char)
1422 (in-fun echo-bin read-byte lisp-stream-bout stream-write-byte))
1423
1424
1425 (defun echo-misc (stream operation &optional arg1 arg2)
1426 (let* ((in (two-way-stream-input-stream stream))
1427 (out (two-way-stream-output-stream stream)))
1428 (case operation
1429 (:listen
1430 (or (not (null (echo-stream-unread-stuff stream)))
1431 (if (lisp-stream-p in)
1432 (or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length)
1433 (funcall (lisp-stream-misc in) in :listen))
1434 (stream-misc-dispatch in :listen))))
1435 (:unread (push arg1 (echo-stream-unread-stuff stream)))
1436 (:element-type
1437 (let ((in-type (stream-element-type in))
1438 (out-type (stream-element-type out)))
1439 (if (equal in-type out-type)
1440 in-type `(and ,in-type ,out-type))))
1441 (:close
1442 (set-closed-flame stream))
1443 (:peek-char
1444 ;; For the special case of peeking into an echo-stream
1445 ;; arg1 is peek-type, arg2 is (eof-errorp eof-value)
1446 ;; returns peeked-char, eof-value, or errors end-of-file
1447 (let ((unread-char-p nil))
1448 (destructuring-bind (eof-errorp eof-value)
1449 arg2
1450 (flet ((outfn (c)
1451 (unless unread-char-p
1452 (if (lisp-stream-p out)
1453 (funcall (lisp-stream-out out) out c)
1454 ;; gray-stream
1455 (stream-write-char out c))))
1456 (infn ()
1457 ;; Obtain input from unread buffer or input stream,
1458 ;; and set the flag appropriately.
1459 (cond ((not (null (echo-stream-unread-stuff stream)))
1460 (setf unread-char-p t)
1461 (pop (echo-stream-unread-stuff stream)))
1462 (t
1463 (setf unread-char-p nil)
1464 (read-char in eof-errorp :eof)))))
1465 (generalized-peeking-mechanism
1466 arg1 eof-value char
1467 (infn)
1468 :eof
1469 (unread-char char in)
1470 :skipped-char-form (outfn char))))))
1471 (:file-length
1472 (error 'type-error :datum stream :expected-type 'file-stream))
1473 (t
1474 (or (if (lisp-stream-p in)
1475 (funcall (lisp-stream-misc in) in operation arg1 arg2)
1476 (stream-misc-dispatch in operation arg1 arg2))
1477 (if (lisp-stream-p out)
1478 (funcall (lisp-stream-misc out) out operation arg1 arg2)
1479 (stream-misc-dispatch out operation arg1 arg2)))))))
1480
1481
1482 (defun echo-n-bin (stream buffer start numbytes eof-error-p)
1483 (let ((new-start start)
1484 (read 0))
1485 (loop
1486 (let ((thing (pop (echo-stream-unread-stuff stream))))
1487 (cond
1488 (thing
1489 (setf (aref buffer new-start) thing)
1490 (incf new-start)
1491 (incf read)
1492 (when (= read numbytes)
1493 (return-from echo-n-bin numbytes)))
1494 (t (return nil)))))
1495 (let ((bytes-read (read-n-bytes (echo-stream-input-stream stream) buffer
1496 new-start (- numbytes read) nil)))
1497 (cond
1498 ((not eof-error-p)
1499 (write-sequence buffer (echo-stream-output-stream stream)
1500 :start new-start :end (+ new-start bytes-read))
1501 (+ bytes-read read))
1502 ((> numbytes (+ read bytes-read))
1503 (write-sequence buffer (echo-stream-output-stream stream)
1504 :start new-start :end (+ new-start bytes-read))
1505 (error 'end-of-file :stream stream))
1506 (t
1507 (write-sequence buffer (echo-stream-output-stream stream)
1508 :start new-start :end (+ new-start bytes-read))
1509 numbytes)))))
1510
1511 (defun %print-echo-stream (s stream d)
1512 (declare (ignore d))
1513 (format stream "#<Echo Stream, Input = ~S, Output = ~S>"
1514 (two-way-stream-input-stream s)
1515 (two-way-stream-output-stream s)))
1516
1517 (setf (documentation 'make-echo-stream 'function)
1518 "Returns a bidirectional stream which gets its input from Input-Stream and
1519 sends its output to Output-Stream. In addition, all input is echoed to
1520 the output stream")
1521
1522 ;;;; Superclass of all string streams
1523
1524 (defstruct (string-stream
1525 (:include lisp-stream)
1526 (:constructor nil)
1527 (:copier nil)))
1528
1529 ;;;; String Input Streams:
1530
1531 (defstruct (string-input-stream
1532 (:include string-stream
1533 (in #'string-inch)
1534 (bin #'string-binch)
1535 (n-bin #'string-stream-read-n-bytes)
1536 (misc #'string-in-misc))
1537 (:print-function %print-string-input-stream)
1538 ;(:constructor nil)
1539 (:constructor internal-make-string-input-stream
1540 (string current end)))
1541 (string nil :type simple-string)
1542 (current nil :type index)
1543 (end nil :type index))
1544
1545 (defun %print-string-input-stream (s stream d)
1546 (declare (ignore s d))
1547 (write-string "#<String-Input Stream>" stream))
1548
1549 (defun string-inch (stream eof-errorp eof-value)
1550 (let ((string (string-input-stream-string stream))
1551 (index (string-input-stream-current stream)))
1552 (declare (simple-string string) (fixnum index))
1553 (cond ((= index (the index (string-input-stream-end stream)))
1554 (eof-or-lose stream eof-errorp eof-value))
1555 (t
1556 (setf (string-input-stream-current stream) (1+ index))
1557 (aref string index)))))
1558
1559 (defun string-binch (stream eof-errorp eof-value)
1560 (let ((string (string-input-stream-string stream))
1561 (index (string-input-stream-current stream)))
1562 (declare (simple-string string)
1563 (type index index))
1564 (cond ((= index (the index (string-input-stream-end stream)))
1565 (eof-or-lose stream eof-errorp eof-value))
1566 (t
1567 (setf (string-input-stream-current stream) (1+ index))
1568 (char-code (aref string index))))))
1569
1570 (defun string-stream-read-n-bytes (stream buffer start requested eof-errorp)
1571 (declare (type string-input-stream stream)
1572 (type index start requested))
1573 (let* ((string (string-input-stream-string stream))
1574 (index (string-input-stream-current stream))
1575 (available (- (string-input-stream-end stream) index))
1576 (copy (min available requested)))
1577 (declare (simple-string string)
1578 (type index index available copy))
1579 (when (plusp copy)
1580 (setf (string-input-stream-current stream)
1581 (truly-the index (+ index copy)))
1582 (system:without-gcing
1583 (system-area-copy (vector-sap string)
1584 (* index vm:byte-bits)
1585 (if (typep buffer 'system-area-pointer)
1586 buffer
1587 (vector-sap buffer))
1588 (* start vm:byte-bits)
1589 (* copy vm:byte-bits))))
1590 (if (and (> requested copy) eof-errorp)
1591 (error 'end-of-file :stream stream)
1592 copy)))
1593
1594 (defun string-in-misc (stream operation &optional arg1 arg2)
1595 (declare (ignore arg2))
1596 (case operation
1597 (:file-position
1598 (if arg1
1599 (setf (string-input-stream-current stream)
1600 (case arg1
1601 (:start 0)
1602 (:end (length (string-input-stream-string stream)))
1603 (t arg1)))
1604 (string-input-stream-current stream)))
1605 (:file-length
1606 (error 'type-error :datum stream :expected-type 'file-stream))
1607 (:unread (decf (string-input-stream-current stream)))
1608 (:listen (or (/= (the fixnum (string-input-stream-current stream))
1609 (the fixnum (string-input-stream-end stream)))
1610 :eof))
1611 (:element-type 'base-char)
1612 (:close
1613 (set-closed-flame stream))))
1614
1615 (defun make-string-input-stream (string &optional
1616 (start 0) (end (length string)))
1617 "Returns an input stream which will supply the characters of String between
1618 Start and End in order."
1619 (declare (type string string)
1620 (type index start)
1621 (type (or index null) end))
1622 (internal-make-string-input-stream (coerce string 'simple-string)
1623 start (or end (length string))))
1624
1625 ;;;; String Output Streams:
1626
1627 (defstruct (string-output-stream
1628 (:include string-stream
1629 (out #'string-ouch)
1630 (sout #'string-sout)
1631 (misc #'string-out-misc))
1632 (:print-function %print-string-output-stream)
1633 (:constructor %make-string-output-stream ()))
1634 ;; The string we throw stuff in.
1635 (string (make-string 40) :type simple-string)
1636 ;; Index of the next location to use.
1637 (index 0 :type fixnum))
1638
1639 (defun %print-string-output-stream (s stream d)
1640 (declare (ignore s d))
1641 (write-string "#<String-Output Stream>" stream))
1642
1643 (defun make-string-output-stream (&key (element-type 'character))
1644 "Returns an Output stream which will accumulate all output given to it for
1645 the benefit of the function Get-Output-Stream-String."
1646 (declare (ignore element-type))
1647 (%make-string-output-stream))
1648
1649 (defun string-ouch (stream character)
1650 (let ((current (string-output-stream-index stream))
1651 (workspace (string-output-stream-string stream)))
1652 (declare (simple-string workspace) (fixnum current))
1653 (if (= current (the fixnum (length workspace)))
1654 (let ((new-workspace (make-string (* current 2))))
1655 (replace new-workspace workspace)
1656 (setf (aref new-workspace current) character)
1657 (setf (string-output-stream-string stream) new-workspace))
1658 (setf (aref workspace current) character))
1659 (setf (string-output-stream-index stream) (1+ current))))
1660
1661 (defun string-sout (stream string start end)
1662 (declare (simple-string string) (fixnum start end))
1663 (let* ((current (string-output-stream-index stream))
1664 (length (- end start))
1665 (dst-end (+ length current))
1666 (workspace (string-output-stream-string stream)))
1667 (declare (simple-string workspace)
1668 (fixnum current length dst-end))
1669 (if (> dst-end (the fixnum (length workspace)))
1670 (let ((new-workspace (make-string (+ (* current 2) length))))
1671 (replace new-workspace workspace :end2 current)
1672 (replace new-workspace string
1673 :start1 current :end1 dst-end
1674 :start2 start :end2 end)
1675 (setf (string-output-stream-string stream) new-workspace))
1676 (replace workspace string
1677 :start1 current :end1 dst-end
1678 :start2 start :end2 end))
1679 (setf (string-output-stream-index stream) dst-end)))
1680
1681 (defun string-out-misc (stream operation &optional arg1 arg2)
1682 (declare (ignore arg2))
1683 (case operation
1684 (:file-position
1685 (if (null arg1)
1686 (string-output-stream-index stream)))
1687 (:file-length
1688 (error 'type-error :datum stream :expected-type 'file-stream))
1689 (:charpos
1690 (do ((index (1- (the fixnum (string-output-stream-index stream)))
1691 (1- index))
1692 (count 0 (1+ count))
1693 (string (string-output-stream-string stream)))
1694 ((< index 0) count)
1695 (declare (simple-string string)
1696 (fixnum index count))
1697 (if (char= (schar string index) #\newline)
1698 (return count))))
1699 (:element-type 'base-char)
1700 (:close
1701 (set-closed-flame stream))))
1702
1703 (defun get-output-stream-string (stream)
1704 "Returns a string of all the characters sent to a stream made by
1705 Make-String-Output-Stream since the last call to this function."
1706 (declare (type string-output-stream stream))
1707 (let* ((length (string-output-stream-index stream))
1708 (result (make-string length)))
1709 (replace result (string-output-stream-string stream))
1710 (setf (string-output-stream-index stream) 0)
1711 result))
1712
1713 (defun dump-output-stream-string (in-stream out-stream)
1714 "Dumps the characters buffer up in the In-Stream to the Out-Stream as
1715 Get-Output-Stream-String would return them."
1716 (write-string* (string-output-stream-string in-stream) out-stream
1717 0 (string-output-stream-index in-stream))
1718 (setf (string-output-stream-index in-stream) 0))
1719
1720 ;;;; Fill-pointer streams:
1721 ;;;
1722 ;;; Fill pointer string output streams are not explicitly mentioned in
1723 ;;; the CLM, but they are required for the implementation of With-Output-To-String.
1724
1725 (defstruct (fill-pointer-output-stream
1726 (:include string-stream
1727 (out #'fill-pointer-ouch)
1728 (sout #'fill-pointer-sout)
1729 (misc #'fill-pointer-misc))
1730 (:print-function
1731 (lambda (s stream d)
1732 (declare (ignore s d))
1733 (write-string "#<Fill-Pointer String Output Stream>" stream)))
1734 (:constructor make-fill-pointer-output-stream (string)))
1735 ;; The string we throw stuff in.
1736 string)
1737
1738
1739 (defun fill-pointer-ouch (stream character)
1740 (let* ((buffer (fill-pointer-output-stream-string stream))
1741 (current (fill-pointer buffer))
1742 (current+1 (1+ current)))
1743 (declare (fixnum current))
1744 (with-array-data ((workspace buffer) (start) (end))
1745 (declare (simple-string workspace))
1746 (let ((offset-current (+ start current)))
1747 (declare (fixnum offset-current))
1748 (if (= offset-current end)
1749 (let* ((new-length (if (zerop current) 1 (* current 2)))
1750 (new-workspace (make-string new-length)))
1751 (declare (simple-string new-workspace))
1752 (%primitive byte-blt workspace (* vm:char-bytes start)
1753 new-workspace 0 (* vm:char-bytes current))
1754 (setf workspace new-workspace)
1755 (setf offset-current current)
1756 (set-array-header buffer workspace new-length
1757 current+1 0 new-length nil))
1758 (setf (fill-pointer buffer) current+1))
1759 (setf (schar workspace offset-current) character)))
1760 current+1))
1761
1762
1763 (defun fill-pointer-sout (stream string start end)
1764 (declare (simple-string string) (fixnum start end))
1765 (let* ((buffer (fill-pointer-output-stream-string stream))
1766 (current (fill-pointer buffer))
1767 (string-len (- end start))
1768 (dst-end (+ string-len current)))
1769 (declare (fixnum current dst-end string-len))
1770 (with-array-data ((workspace buffer) (dst-start) (dst-length))
1771 (declare (simple-string workspace))
1772 (let ((offset-dst-end (+ dst-start dst-end))
1773 (offset-current (+ dst-start current)))
1774 (declare (fixnum offset-dst-end offset-current))
1775 (if (> offset-dst-end dst-length)
1776 (let* ((new-length (+ (the fixnum (* current 2)) string-len))
1777 (new-workspace (make-string new-length)))
1778 (declare (simple-string new-workspace))
1779 (%primitive byte-blt workspace (* vm:char-bytes dst-start)
1780 new-workspace 0 (* vm:char-bytes current))
1781 (setf workspace new-workspace)
1782 (setf offset-current current)
1783 (setf offset-dst-end dst-end)
1784 (set-array-header buffer workspace new-length
1785 dst-end 0 new-length nil))
1786 (setf (fill-pointer buffer) dst-end))
1787 (%primitive byte-blt string (* vm:char-bytes start)
1788 workspace (* vm:char-bytes offset-current)
1789 (* vm:char-bytes offset-dst-end))))
1790 dst-end))
1791
1792
1793 (defun fill-pointer-misc (stream operation &optional arg1 arg2)
1794 (declare (ignore arg1 arg2))
1795 (case operation
1796 (:charpos
1797 (let* ((buffer (fill-pointer-output-stream-string stream))
1798 (current (fill-pointer buffer)))
1799 (with-array-data ((string buffer) (start) (end current))
1800 (declare (simple-string string) (ignore start))
1801 (let ((found (position #\newline string :test #'char=
1802 :end end :from-end t)))
1803 (if found
1804 (- end (the fixnum found))
1805 current)))))
1806 (:element-type 'base-char)))
1807
1808 ;;;; Indenting streams:
1809
1810 (defstruct (indenting-stream (:include lisp-stream
1811 (out #'indenting-out)
1812 (sout #'indenting-sout)
1813 (misc #'indenting-misc))
1814 (:print-function %print-indenting-stream)
1815 (:constructor make-indenting-stream (stream)))
1816 ;; The stream we're based on:
1817 stream
1818 ;; How much we indent on each line:
1819 (indentation 0))
1820
1821 (setf (documentation 'make-indenting-stream 'function)
1822 "Returns an output stream which indents its output by some amount.")
1823
1824 (defun %print-indenting-stream (s stream d)
1825 (declare (ignore s d))
1826 (write-string "#<Indenting Stream>" stream))
1827
1828 ;;; Indenting-Indent writes the right number of spaces needed to indent
1829 ;;; output on the given Stream based on the specified Sub-Stream.
1830
1831 (defmacro indenting-indent (stream sub-stream)
1832 `(do ((i 0 (+ i 60))
1833 (indentation (indenting-stream-indentation ,stream)))
1834 ((>= i indentation))
1835 (write-string*
1836 " "
1837 ,sub-stream 0 (min 60 (- indentation i)))))
1838
1839 ;;; Indenting-Out writes a character to an indenting stream.
1840
1841 (defun indenting-out (stream char)
1842 (let ((sub-stream (indenting-stream-stream stream)))
1843 (write-char char sub-stream)
1844 (if (char= char #\newline)
1845 (indenting-indent stream sub-stream))))
1846
1847 ;;; Indenting-Sout writes a string to an indenting stream.
1848
1849 (defun indenting-sout (stream string start end)
1850 (declare (simple-string string) (fixnum start end))
1851 (do ((i start)
1852 (sub-stream (indenting-stream-stream stream)))
1853 ((= i end))
1854 (let ((newline (position #\newline string :start i :end end)))
1855 (cond (newline
1856 (write-string* string sub-stream i (1+ newline))
1857 (indenting-indent stream sub-stream)
1858 (setq i (+ newline 1)))
1859 (t
1860 (write-string* string sub-stream i end)
1861 (setq i end))))))
1862
1863 ;;; Indenting-Misc just treats just the :Line-Length message differently.
1864 ;;; Indenting-Charpos says the charpos is the charpos of the base stream minus
1865 ;;; the stream's indentation.
1866
1867 (defun indenting-misc (stream operation &optional arg1 arg2)
1868 (let ((sub-stream (indenting-stream-stream stream)))
1869 (if (lisp-stream-p sub-stream)
1870 (let ((method (lisp-stream-misc sub-stream)))
1871 (case operation
1872 (:line-length
1873 (let ((line-length (funcall method sub-stream operation)))
1874 (if line-length
1875 (- line-length (indenting-stream-indentation stream)))))
1876 (:charpos
1877 (let ((charpos (funcall method sub-stream operation)))
1878 (if charpos
1879 (- charpos (indenting-stream-indentation stream)))))
1880 (t
1881 (funcall method sub-stream operation arg1 arg2))))
1882 ;; Fundamental-stream.
1883 (case operation
1884 (:line-length
1885 (let ((line-length (stream-line-length sub-stream)))
1886 (if line-length
1887 (- line-length (indenting-stream-indentation stream)))))
1888 (:charpos
1889 (let ((charpos (stream-line-column sub-stream)))
1890 (if charpos
1891 (- charpos (indenting-stream-indentation stream)))))
1892 (t
1893 (stream-misc-dispatch sub-stream operation arg1 arg2))))))
1894
1895
1896 (declaim (maybe-inline read-char unread-char read-byte listen))
1897
1898
1899
1900 ;;;; Case frobbing streams, used by format ~(...~).
1901
1902 (defstruct (case-frob-stream
1903 (:include lisp-stream
1904 (:misc #'case-frob-misc))
1905 (:constructor %make-case-frob-stream (target out sout)))
1906 (target (required-argument) :type stream))
1907
1908 (defun make-case-frob-stream (target kind)
1909 "Returns a stream that sends all output to the stream TARGET, but modifies
1910 the case of letters, depending on KIND, which should be one of:
1911 :upcase - convert to upper case.
1912 :downcase - convert to lower case.
1913 :capitalize - convert the first letter of words to upper case and the
1914 rest of the word to lower case.
1915 :capitalize-first - convert the first letter of the first word to upper
1916 case and everything else to lower case."
1917 (declare (type stream target)
1918 (type (member :upcase :downcase :capitalize :capitalize-first)
1919 kind)
1920 (values stream))
1921 (if (case-frob-stream-p target)
1922 ;; If we are going to be writing to a stream that already does case
1923 ;; frobbing, why bother frobbing the case just so it can frob it
1924 ;; again?
1925 target
1926 (multiple-value-bind
1927 (out sout)
1928 (ecase kind
1929 (:upcase
1930 (values #'case-frob-upcase-out
1931 #'case-frob-upcase-sout))
1932 (:downcase
1933 (values #'case-frob-downcase-out
1934 #'case-frob-downcase-sout))
1935 (:capitalize
1936 (values #'case-frob-capitalize-out
1937 #'case-frob-capitalize-sout))
1938 (:capitalize-first
1939 (values #'case-frob-capitalize-first-out
1940 #'case-frob-capitalize-first-sout)))
1941 (%make-case-frob-stream target out sout))))
1942
1943 (defun case-frob-misc (stream op &optional arg1 arg2)
1944 (declare (type case-frob-stream stream))
1945 (case op
1946 (:close)
1947 (t
1948 (let ((target (case-frob-stream-target stream)))
1949 (if (lisp-stream-p target)
1950 (funcall (lisp-stream-misc target) target op arg1 arg2)
1951 (stream-misc-dispatch target op arg1 arg2))))))
1952
1953 (defun case-frob-upcase-out (stream char)
1954 (declare (type case-frob-stream stream)
1955 (type base-char char))
1956 (let ((target (case-frob-stream-target stream))
1957 (char (char-upcase char)))
1958 (if (lisp-stream-p target)
1959 (funcall (lisp-stream-out target) target char)
1960 (stream-write-char target char))))
1961
1962 (defun case-frob-upcase-sout (stream str start end)
1963 (declare (type case-frob-stream stream)
1964 (type simple-base-string str)
1965 (type index start)
1966 (type (or index null) end))
1967 (let* ((target (case-frob-stream-target stream))
1968 (len (length str))
1969 (end (or end len))
1970 (string (if (and (zerop start) (= len end))
1971 (string-upcase str)
1972 (nstring-upcase (subseq str start end))))
1973 (string-len (- end start)))
1974 (if (lisp-stream-p target)
1975 (funcall (lisp-stream-sout target) target string 0 string-len)
1976 (stream-write-string target string 0 string-len))))
1977
1978 (defun case-frob-downcase-out (stream char)
1979 (declare (type case-frob-stream stream)
1980 (type base-char char))
1981 (let ((target (case-frob-stream-target stream))
1982 (char (char-downcase char)))
1983 (if (lisp-stream-p target)
1984 (funcall (lisp-stream-out target) target char)
1985 (stream-write-char target char))))
1986
1987 (defun case-frob-downcase-sout (stream str start end)
1988 (declare (type case-frob-stream stream)
1989 (type simple-base-string str)
1990 (type index start)
1991 (type (or index null) end))
1992 (let* ((target (case-frob-stream-target stream))
1993 (len (length str))
1994 (end (or end len))
1995 (string (if (and (zerop start) (= len end))
1996 (string-downcase str)
1997 (nstring-downcase (subseq str start end))))
1998 (string-len (- end start)))
1999 (if (lisp-stream-p target)
2000 (funcall (lisp-stream-sout target) target string 0 string-len)
2001 (stream-write-string target string 0 string-len))))
2002
2003 (defun case-frob-capitalize-out (stream char)
2004 (declare (type case-frob-stream stream)
2005 (type base-char char))
2006 (let ((target (case-frob-stream-target stream)))
2007 (cond ((alphanumericp char)
2008 (let ((char (char-upcase char)))
2009 (if (lisp-stream-p target)
2010 (funcall (lisp-stream-out target) target char)
2011 (stream-write-char target char)))
2012 (setf (case-frob-stream-out stream) #'case-frob-capitalize-aux-out)
2013 (setf (case-frob-stream-sout stream)
2014 #'case-frob-capitalize-aux-sout))
2015 (t
2016 (if (lisp-stream-p target)
2017 (funcall (lisp-stream-out target) target char)
2018 (stream-write-char target char))))))
2019
2020 (defun case-frob-capitalize-sout (stream str start end)
2021 (declare (type case-frob-stream stream)
2022 (type simple-base-string str)
2023 (type index start)
2024 (type (or index null) end))
2025 (let* ((target (case-frob-stream-target stream))
2026 (str (subseq str start end))
2027 (len (length str))
2028 (inside-word nil))
2029 (dotimes (i len)
2030 (let ((char (schar str i)))
2031 (cond ((not (alphanumericp char))
2032 (setf inside-word nil))
2033 (inside-word
2034 (setf (schar str i) (char-downcase char)))
2035 (t
2036 (setf inside-word t)
2037 (setf (schar str i) (char-upcase char))))))
2038 (when inside-word
2039 (setf (case-frob-stream-out stream)
2040 #'case-frob-capitalize-aux-out)
2041 (setf (case-frob-stream-sout stream)
2042 #'case-frob-capitalize-aux-sout))
2043 (if (lisp-stream-p target)
2044 (funcall (lisp-stream-sout target) target str 0 len)
2045 (stream-write-string target str 0 len))))
2046
2047 (defun case-frob-capitalize-aux-out (stream char)
2048 (declare (type case-frob-stream stream)
2049 (type base-char char))
2050 (let ((target (case-frob-stream-target stream)))
2051 (cond ((alphanumericp char)
2052 (let ((char (char-downcase char)))
2053 (if (lisp-stream-p target)
2054 (funcall (lisp-stream-out target) target char)
2055 (stream-write-char target char))))
2056 (t
2057 (if (lisp-stream-p target)
2058 (funcall (lisp-stream-out target) target char)
2059 (stream-write-char target char))
2060 (setf (case-frob-stream-out stream)
2061 #'case-frob-capitalize-out)
2062 (setf (case-frob-stream-sout stream)
2063 #'case-frob-capitalize-sout)))))
2064
2065 (defun case-frob-capitalize-aux-sout (stream str start end)
2066 (declare (type case-frob-stream stream)
2067 (type simple-base-string str)
2068 (type index start)
2069 (type (or index null) end))
2070 (let* ((target (case-frob-stream-target stream))
2071 (str (subseq str start end))
2072 (len (length str))
2073 (inside-word t))
2074 (dotimes (i len)
2075 (let ((char (schar str i)))
2076 (cond ((not (alphanumericp char))
2077 (setf inside-word nil))
2078 (inside-word
2079 (setf (schar str i) (char-downcase char)))
2080 (t
2081 (setf inside-word t)
2082 (setf (schar str i) (char-upcase char))))))
2083 (unless inside-word
2084 (setf (case-frob-stream-out stream)
2085 #'case-frob-capitalize-out)
2086 (setf (case-frob-stream-sout stream)
2087 #'case-frob-capitalize-sout))
2088 (if (lisp-stream-p target)
2089 (funcall (lisp-stream-sout target) target str 0 len)
2090 (stream-write-string target str 0 len))))
2091
2092 (defun case-frob-capitalize-first-out (stream char)
2093 (declare (type case-frob-stream stream)
2094 (type base-char char))
2095 (let ((target (case-frob-stream-target stream)))
2096 (cond ((alphanumericp char)
2097 (let ((char (char-upcase char)))
2098 (if (lisp-stream-p target)
2099 (funcall (lisp-stream-out target) target char)
2100 (stream-write-char target char)))
2101 (setf (case-frob-stream-out stream)
2102 #'case-frob-downcase-out)
2103 (setf (case-frob-stream-sout stream)
2104 #'case-frob-downcase-sout))
2105 (t
2106 (if (lisp-stream-p target)
2107 (funcall (lisp-stream-out target) target char)
2108 (stream-write-char target char))))))
2109
2110 (defun case-frob-capitalize-first-sout (stream str start end)
2111 (declare (type case-frob-stream stream)
2112 (type simple-base-string str)
2113 (type index start)
2114 (type (or index null) end))
2115 (let* ((target (case-frob-stream-target stream))
2116 (str (subseq str start end))
2117 (len (length str)))
2118 (dotimes (i len)
2119 (let ((char (schar str i)))
2120 (when (alphanumericp char)
2121 (setf (schar str i) (char-upcase char))
2122 (do ((i (1+ i) (1+ i)))
2123 ((= i len))
2124 (setf (schar str i) (char-downcase (schar str i))))
2125 (setf (case-frob-stream-out stream)
2126 #'case-frob-downcase-out)
2127 (setf (case-frob-stream-sout stream)
2128 #'case-frob-downcase-sout)
2129 (return))))
2130 (if (lisp-stream-p target)
2131 (funcall (lisp-stream-sout target) target str 0 len)
2132 (stream-write-string target str 0 len))))
2133
2134
2135 ;;;; Public interface from "EXTENSIONS" package.
2136
2137 (defstruct (stream-command (:print-function print-stream-command)
2138 (:constructor make-stream-command
2139 (name &optional args)))
2140 (name nil :type symbol)
2141 (args nil :type list))
2142
2143 (defun print-stream-command (obj str n)
2144 (declare (ignore n))
2145 (format str "#<Stream-Cmd ~S>" (stream-command-name obj)))
2146
2147
2148 ;;; GET-STREAM-COMMAND -- Public.
2149 ;;;
2150 ;;; We can't simply call the stream's misc method because nil is an
2151 ;;; ambiguous return value: does it mean text arrived, or does it mean the
2152 ;;; stream's misc method had no :get-command implementation. We can't return
2153 ;;; nil until there is text input. We don't need to loop because any stream
2154 ;;; implementing :get-command would wait until it had some input. If the
2155 ;;; LISTEN fails, then we have some random stream we must wait on.
2156 ;;;
2157 (defun get-stream-command (stream)
2158 "This takes a stream and waits for text or a command to appear on it. If
2159 text appears before a command, this returns nil, and otherwise it returns
2160 a command."
2161 (let ((cmdp (funcall (lisp-stream-misc stream) stream :get-command)))
2162 (cond (cmdp)
2163 ((listen stream)
2164 nil)
2165 (t
2166 ;; This waits for input and returns nil when it arrives.
2167 (unread-char (read-char stream) stream)))))
2168
2169
2170 ;;; READ-SEQUENCE --
2171
2172 (defun read-sequence (seq stream &key (start 0) (end nil) partial-fill)
2173 "Destructively modify SEQ by reading elements from STREAM.
2174
2175 Seq is bounded by Start and End. Seq is destructively modified by
2176 copying successive elements into it from Stream. If the end of file
2177 for Stream is reached before copying all elements of the subsequence,
2178 then the extra elements near the end of sequence are not updated.
2179
2180 Argument(s):
2181 SEQ: a proper SEQUENCE
2182 STREAM: an input STREAM
2183 START: a bounding index designator of type '(INTEGER 0 *)' (default 0)
2184 END: a bounding index designator which be NIL or an INTEGER of
2185 type '(INTEGER 0 *)' (default NIL)
2186
2187 Value(s):
2188 POSITION: an INTEGER greater than or equal to zero, and less than or
2189 equal to the length of the SEQ. POSITION is the index of
2190 the first element of SEQ that was not updated, which might be
2191 less than END because the end of file was reached."
2192
2193 (declare (type (or list vector) seq)) ; could be (type sequence seq)
2194 (declare (type stream stream))
2195 (declare (type (integer 0 *) start)) ; a list does not have a limit
2196 (declare (type (or null (integer 0 *)) end))
2197 (declare (values (integer 0 *)))
2198
2199 (stream-dispatch stream
2200 ;; simple-stream
2201 (stream::%read-sequence stream seq start end partial-fill)
2202 ;; lisp-stream
2203 (let ((end (or end (length seq))))
2204 (declare (type (integer 0 *) start end))
2205
2206 ;; Just catch some errors earlier than it would be necessary.
2207 (cond ((not (open-stream-p stream))
2208 (error 'simple-stream-error
2209 :stream stream
2210 :format-control "The stream is not open."))
2211 ((not (input-stream-p stream))
2212 (error 'simple-stream-error
2213 :stream stream
2214 :format-control "The stream is not open for input."))
2215 ((and seq (>= start end) 0))
2216 (t
2217 ;; So much for object-oriented programming!
2218 (etypecase seq
2219 (list
2220 (read-into-list seq stream start end))
2221 (string
2222 (with-array-data ((seq seq) (start start) (end end))
2223 (read-into-string seq stream start end partial-fill)))
2224 (simple-array ; We also know that it is a 'vector'.
2225 (read-into-simple-array seq stream start end))
2226 (vector
2227 (read-into-vector seq stream start end))))))
2228 ;; fundamental-stream
2229 (stream-read-sequence stream seq start end)))
2230
2231
2232 ;;; READ-INTO-LIST, READ-INTO-LIST-1
2233 ;;; Auxiliary functions for READ-SEQUENCE. Their semantics is pretty
2234 ;;; obvious. Since lists do not have an attached element type, and
2235 ;;; since we cannot do a low-level multi-byte read operation on them,
2236 ;;; I simply dispatch on the element type of the stream and then rely
2237 ;;; on READ-BYTE and READ-CHAR to to the input.
2238 ;;;
2239 ;;; NOTE: the use of 'endp' will generate a (desired)
2240 ;;; 'type-error' if the sequence is not a "proper list".
2241
2242 (defun read-into-list (l stream start end)
2243 (let ((read-function (if (subtypep (stream-element-type stream) 'character)
2244 #'read-char
2245 #'read-byte)))
2246 (read-into-list-1 (nthcdr start l) start end stream read-function)))
2247
2248 #+recursive
2249 (defun read-into-list-1 (l start end stream read-function)
2250 (declare (type list l))
2251 (declare (type stream stream))
2252 (declare (type (integer 0 *) start end))
2253 (if (or (endp l) (= start end))
2254 start
2255 (let* ((el (funcall read-function stream nil stream)))
2256 (cond ((eq el stream) start)
2257 (t (setf (first l) el)
2258 (read-into-list-1 (rest l)
2259 (1+ start)
2260 end
2261 stream
2262 read-function))))
2263 ))
2264
2265
2266 #-recursive
2267 (defun read-into-list-1 (l start end stream read-function)
2268 (declare (type list l))
2269 (declare (type stream stream))
2270 (declare (type (integer 0 *) start end))
2271
2272 ;; The declaration for I may be too restrictive in the case of
2273 ;; lists. But then again, it is still a huge number.
2274 (do ((lis l (rest lis))
2275 (i start (1+ i)))
2276 ((or (endp lis)
2277 (>= i end))
2278 i)
2279 (declare (type list lis))
2280 (declare (type index i))
2281 (let* ((el (funcall read-function stream nil stream)))
2282 (when (eq el stream)
2283 (return i))
2284 (setf (first lis) el))))
2285
2286
2287 ;;; READ-INTO-SIMPLE-STRING --
2288
2289 #+nil
2290 (defun read-into-simple-string (s stream start end)
2291 (declare (type simple-string s))
2292 (declare (type stream stream))
2293 (declare (type index start end))
2294 (unless (subtypep (stream-element-type stream) 'character)
2295 (error 'type-error
2296 :datum (read-char stream nil #\Null)
2297 :expected-type (stream-element-type stream)
2298 :format-control "Trying to read characters from a binary stream."))
2299 ;; Let's go as low level as it seems reasonable.
2300 (let* ((numbytes (- end start))
2301 (total-bytes 0))
2302 ;; read-n-bytes may return fewer bytes than requested, so we need
2303 ;; to keep trying.
2304 (loop while (plusp numbytes) do
2305 (let ((bytes-read (system:read-n-bytes stream s start numbytes nil)))
2306 (when (zerop bytes-read)
2307 (return-from read-into-simple-string start))
2308 (incf total-bytes bytes-read)
2309 (incf start bytes-read)
2310 (decf numbytes bytes-read)))
2311 start))
2312
2313
2314 ;;; read-into-simple-string hacked to allow (unsigned-byte 8) stream-element-type
2315 ;;; For some reason applying this change to read-into-simple-string causes CMUCL to die.
2316 #-unicode
2317 (defun read-into-string (s stream start end partial-fill)
2318 (declare (type simple-string s))
2319 (declare (type stream stream))
2320 (declare (type index start end))
2321 (unless (or (subtypep (stream-element-type stream) 'character)
2322 (equal (stream-element-type stream) '(unsigned-byte 8)))
2323 (error 'type-error
2324 :datum (read-char stream nil #\Null)
2325 :expected-type (stream-element-type stream)
2326 :format-control "Trying to read characters from a binary stream."))
2327 ;; Let's go as low level as it seems reasonable.
2328 (let* ((numbytes (- end start))
2329 (total-bytes 0))
2330 ;; read-n-bytes may return fewer bytes than requested, so we need
2331 ;; to keep trying.
2332 (loop while (plusp numbytes) do
2333 (let ((bytes-read (system:read-n-bytes stream s start numbytes nil)))
2334 (incf total-bytes bytes-read)
2335 (incf start bytes-read)
2336 (decf numbytes bytes-read)
2337 (when (or partial-fill (zerop bytes-read))
2338 (return-from read-into-string start))))
2339 start))
2340
2341 #+unicode
2342 (defun read-into-string (s stream start end partial-fill)
2343 (declare (type string s))
2344 (declare (type stream stream))
2345 (declare (type index start end))
2346 (unless (subtypep (stream-element-type stream) 'character)
2347 (error 'type-error
2348 :datum (read-char stream nil #\Null)
2349 :expected-type (stream-element-type stream)
2350 :format-control "Trying to read characters from a binary stream."))
2351 (do ((i start (1+ i))
2352 (s-len (length s)))
2353 ((or (>= i s-len)
2354 (>= i end))
2355 i)
2356 (declare (type index i s-len))
2357 (let* ((el (read-char stream nil stream)))
2358 (declare (type (or character stream) el))
2359 (when (eq el stream)
2360 (return i))
2361 (setf (char s i) (the character el)))))
2362
2363 ;;; READ-INTO-SIMPLE-ARRAY --
2364 ;;; We definitively know that we are really reading into a vector.
2365
2366 ;;; *read-into-simple-array-recognized-types* --
2367 ;;;
2368 ;;; Note the new feature :extended-binary-streams.
2369 ;;; Up to 18a, CMUCL has a wired in limitation to treat only 8-bits
2370 ;;; word binary streams. 'fd-read-n-bytes' is associated to a binary
2371 ;;; stream only if the fd-stream has binary type size of 1 (i.e. 1
2372 ;;; 8-bits byte). This is reflected also in the size of the input
2373 ;;; buffers.
2374
2375 (defparameter *read-into-simple-array-recognized-types*
2376 '(base-char ; Character types are needed
2377 ; to support simple-stream
2378 ; semantics for read-vector
2379 character
2380 (unsigned-byte 8)
2381 (unsigned-byte 16)
2382 (unsigned-byte 32)
2383 (signed-byte 8)
2384 (signed-byte 16)
2385 (signed-byte 32)
2386 single-float ; not previously supported by read-sequence
2387 double-float ; not previously supported by read-sequence
2388 ))
2389
2390 (defun read-into-simple-array (s stream start end)
2391 ;; The complex declaration is needed to make Python behave.
2392 ;; The first declaration does not work because of type promotion
2393 ;; which effectively excises the etypecase below.
2394 ;; The second declaration does not quite work because it does not
2395 ;; quite constrain the array element type.
2396 ;; (declare (type (simple-array (or unsigned-byte signed-byte) (*)) s))
2397 ;; (declare (type (simple-array * (*)) s))
2398 (declare (type (or (simple-array (unsigned-byte 8) (*))
2399 (simple-array (signed-byte 8) (*))
2400 (simple-array (unsigned-byte 16) (*))
2401 (simple-array (signed-byte 16) (*))
2402 (simple-array (unsigned-byte 32) (*))
2403 (simple-array (signed-byte 32) (*))
2404 (simple-array (unsigned-byte *) (*))
2405 (simple-array (signed-byte *) (*))
2406 (simple-array single-float (*)) ; not previously supported by read-sequence
2407 (simple-array double-float (*)) ; not previously supported by read-sequence
2408 simple-bit-vector)
2409 s))
2410
2411 (declare (type stream stream))
2412 (declare (type index start end))
2413 (let ((stream-et (stream-element-type stream)))
2414 ;; What is the purpose of this explicit test for characters? It
2415 ;; prevents reading a string-stream into a vector, like the
2416 ;; example in the CLHS.
2417 (cond #+(or)
2418 ((subtypep (stream-element-type stream) 'character)
2419 (error 'type-error
2420 :datum (read-byte stream nil 0)
2421 :expected-type (stream-element-type stream) ; Bogus?!?
2422 :format-control
2423 "Trying to read binary data from a text stream."))
2424
2425 ;; Let's go as low level as it seems reasonable.
2426 ((not (member stream-et
2427 *read-into-simple-array-recognized-types*
2428 :test #'equal))
2429 #+nil
2430 (format t ">>> Reading vector from binary stream of type ~S~%"
2431 stream-et)
2432
2433 ;; We resort to the READ-BYTE based operation.
2434 (read-into-vector s stream start end))
2435
2436 ((/= vm:byte-bits 8)
2437 ;; We must resort to the READ-BYTE based operation
2438 ;; also in this case. XXX Unreachable code note.
2439 (read-into-vector s stream start end))
2440
2441 ;; Otherwise we can do something more interesting.
2442 (t
2443 (labels
2444 ((get-n-bytes (stream data offset numbytes)
2445 ;; Handle case of read-n-bytes reading short.
2446 (let ((need numbytes))
2447 (loop
2448 (let ((n (read-n-bytes stream data offset need nil)))
2449 (decf need n)
2450 (cond ((or (zerop need) ; Complete
2451 (zerop n)) ; EOF
2452 (return (- numbytes need)))
2453 (t (incf offset n)))))))
2454 (read-n-x8-bytes (stream data offset-start offset-end byte-size)
2455 (let* ((x8-mult (truncate byte-size 8))
2456 (numbytes (* (- offset-end offset-start) x8-mult))
2457 (bytes-read (get-n-bytes
2458 stream
2459 data
2460 offset-start
2461 numbytes))
2462 )
2463 ;; A check should probably be made here in order to
2464 ;; be sure that we actually read the right amount
2465 ;; of bytes. (I.e. (truncate bytes-read x8-mult)
2466 ;; should return a 0 second value.
2467 (if (< bytes-read numbytes)
2468 (+ offset-start (truncate bytes-read x8-mult))
2469 offset-end)))
2470 )
2471
2472 ;; According to the definition of OPEN and READ-N-BYTES,
2473 ;; these are the only cases when we can use the multi-byte read
2474 ;; operation on a binary stream.
2475 (with-array-data ((data s) (offset-start start) (offset-end end))
2476 (etypecase data
2477 ((simple-array (unsigned-byte 8) (*))
2478 (read-n-x8-bytes stream data offset-start offset-end 8))
2479
2480 ((simple-array (unsigned-byte 16) (*))
2481 (read-n-x8-bytes stream data offset-start offset-end 16))
2482
2483 ((simple-array (unsigned-byte 32) (*))
2484 (read-n-x8-bytes stream data offset-start offset-end 32))
2485
2486 ((simple-array (signed-byte 8) (*))
2487 (read-n-x8-bytes stream data offset-start offset-end 8))
2488
2489 ((simple-array (signed-byte 16) (*))
2490 (read-n-x8-bytes stream data offset-start offset-end 16))
2491
2492 ((simple-array (signed-byte 32) (*))
2493 (read-n-x8-bytes stream data offset-start offset-end 32))
2494
2495 ;; not previously supported by read-sequence
2496 ((simple-array single-float (*))
2497 (read-n-x8-bytes stream data offset-start offset-end 32))
2498
2499 ;; not previously supported by read-sequence
2500 ((simple-array double-float (*))
2501 (read-n-x8-bytes stream data offset-start offset-end 64))
2502
2503 ;; Otherwise we resort to the READ-BYTE based operation.
2504 (simple-bit-vector
2505 (read-into-vector s stream start end))
2506 ((simple-array (unsigned-byte *) (*))
2507 (read-into-vector