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

Contents of /src/code/stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.87.6.1 - (show annotations)
Sat Sep 19 15:16:05 2009 UTC (4 years, 6 months ago) by rtoy
Branch: unicode-string-buffer-impl-branch
Changes since 1.87: +59 -1 lines
Implement fast external formats.  This is done for buffered streams
where an in-buffer would be allocated.  For character streams, a
string-buffer is also allocated.  Whenever the string-buffer is empty,
the in-buffer is filled with new octets, and the octets are
immediately converted to a string.  FAST-READ-CHAR pulls the
characters from string-buffer as needed.  This speeds up utf8
processing by 30-40% (for read-line).

fd-stream-extfmt.lisp:
o Precompile the +ef-os+ slot for iso8859-1. (Not necessary?)
o Set *enable-stream-buffer-p* to T to enable the buffer.

fd-stream.lisp:
o In SET-ROUTINES, allocate the string-buffer when appropriate.
o Update FD-STREAM-MISC-ROUTINE to handle :unread with the string
  buffer.

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