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

Contents of /src/code/stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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