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

Contents of /src/code/stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.87.6.6 - (show annotations)
Fri Sep 25 22:56:11 2009 UTC (4 years, 6 months ago) by rtoy
Branch: unicode-string-buffer-impl-branch
Changes since 1.87.6.5: +44 -13 lines
Make (setf stream-external-format) work with the string buffer.  This
has no impact on fast-read-char, but does make changing the external
format a little bit slower than might be expected.

fd-stream.lisp:
o Don't call (setf stream-external-format) in make-fd-stream because
  we're not ready for that yet.  Call %set-fd-stream-external-format
  instead.

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