/[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.12 - (show annotations)
Thu Oct 8 02:06:25 2009 UTC (4 years, 6 months ago) by rtoy
Branch: unicode-string-buffer-impl-branch
Changes since 1.87.6.11: +6 -4 lines
fd-stream.lisp:
o EF-COPY-STATE is only for unicode builds.

stream.lisp:
o %SET-FD-STREAM-EXTERNAL-FORMAT and FAST-READ-CHAR-STRING-REFILL are
  %only for unicode builds.

sysmacs.lisp:
o Combine the unicode and non-unicode versions of FAST-REACH-CHAR into
  one macro with one conditionalization internally for unicode.

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