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

Contents of /src/code/stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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