/[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.4 - (show annotations)
Fri Sep 25 18:13:11 2009 UTC (4 years, 6 months ago) by rtoy
Branch: unicode-string-buffer-impl-branch
Changes since 1.87.6.3: +16 -8 lines
Support fast iso8859-1 reader, again.

fd-stream.lisp:
o If the external format is :iso8859-1, don't create the string
  buffer, but do create the in-buffer from which we can grab the
  octets/characters.

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