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

Contents of /src/code/stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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