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

Diff of /src/code/stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.25 by wlott, Mon Dec 5 00:02:45 1994 UTC revision 1.25.2.5 by dtc, Sun Jul 23 14:59:20 2000 UTC
# Line 11  Line 11 
11  ;;;  ;;;
12  ;;; Stream functions for Spice Lisp.  ;;; Stream functions for Spice Lisp.
13  ;;; Written by Skef Wholey and Rob MacLachlan.  ;;; Written by Skef Wholey and Rob MacLachlan.
14    ;;; Gray streams support by Douglas Crosher, 1998.
15  ;;;  ;;;
16  ;;; This file contains the OS-independent stream functions.  ;;; This file contains the OS-independent stream functions.
17  ;;;  ;;;
# Line 65  Line 66 
66    
67  (defun ill-in (stream &rest ignore)  (defun ill-in (stream &rest ignore)
68    (declare (ignore ignore))    (declare (ignore ignore))
69    (error "~S is not a character input stream." stream))    (error 'simple-type-error
70             :datum stream
71             :expected-type '(satisfies input-stream-p)
72             :format-control "~S is not a character input stream."
73             :format-arguments (list stream)))
74  (defun ill-out (stream &rest ignore)  (defun ill-out (stream &rest ignore)
75    (declare (ignore ignore))    (declare (ignore ignore))
76    (error "~S is not a character output stream." stream))    (error 'simple-type-error
77             :datum stream
78             :expected-type '(satisfies output-stream-p)
79             :format-control "~S is not a character output stream."
80             :format-arguments (list stream)))
81  (defun ill-bin (stream &rest ignore)  (defun ill-bin (stream &rest ignore)
82    (declare (ignore ignore))    (declare (ignore ignore))
83    (error "~S is not a binary input stream." stream))    (error 'simple-type-error
84             :datum stream
85             :expected-type '(satisfies input-stream-p)
86             :format-control "~S is not a binary input stream."
87             :format-arguments (list stream)))
88  (defun ill-bout (stream &rest ignore)  (defun ill-bout (stream &rest ignore)
89    (declare (ignore ignore))    (declare (ignore ignore))
90    (error "~S is not a binary output stream." stream))    (error 'simple-type-error
91             :datum stream
92             :expected-type '(satisfies output-stream-p)
93             :format-control "~S is not a binary output stream."
94             :format-arguments (list stream)))
95  (defun closed-flame (stream &rest ignore)  (defun closed-flame (stream &rest ignore)
96    (declare (ignore ignore))    (declare (ignore ignore))
97    (error "~S is closed." stream))    (error "~S is closed." stream))
# Line 163  Line 180 
180    
181  (defun input-stream-p (stream)  (defun input-stream-p (stream)
182    "Returns non-nil if the given Stream can perform input operations."    "Returns non-nil if the given Stream can perform input operations."
183    (and (streamp stream)    (and (lisp-stream-p stream)
184         (not (eq (stream-in stream) #'closed-flame))         (not (eq (lisp-stream-in stream) #'closed-flame))
185         (or (not (eq (stream-in stream) #'ill-in))         (or (not (eq (lisp-stream-in stream) #'ill-in))
186             (not (eq (stream-bin stream) #'ill-bin)))))             (not (eq (lisp-stream-bin stream) #'ill-bin)))))
187    
188  (defun output-stream-p (stream)  (defun output-stream-p (stream)
189    "Returns non-nil if the given Stream can perform output operations."    "Returns non-nil if the given Stream can perform output operations."
190    (and (streamp stream)    (and (lisp-stream-p stream)
191         (not (eq (stream-in stream) #'closed-flame))         (not (eq (lisp-stream-in stream) #'closed-flame))
192         (or (not (eq (stream-out stream) #'ill-out))         (or (not (eq (lisp-stream-out stream) #'ill-out))
193             (not (eq (stream-bout stream) #'ill-bout)))))             (not (eq (lisp-stream-bout stream) #'ill-bout)))))
194    
195  (defun open-stream-p (stream)  (defun open-stream-p (stream)
196    "Return true if Stream is not closed."    "Return true if Stream is not closed."
197    (declare (type stream stream))    (declare (type stream stream))
198    (not (eq (stream-in stream) #'closed-flame)))    (not (eq (lisp-stream-in stream) #'closed-flame)))
199    
200  (defun stream-element-type (stream)  (defun stream-element-type (stream)
201    "Returns a type specifier for the kind of object returned by the Stream."    "Returns a type specifier for the kind of object returned by the Stream."
202    (declare (type stream stream))    (declare (type stream stream))
203    (funcall (stream-misc stream) stream :element-type))    (funcall (lisp-stream-misc stream) stream :element-type))
204    
205  (defun interactive-stream-p (stream)  (defun interactive-stream-p (stream)
206    "Return true if Stream does I/O on a terminal or other interactive device."    "Return true if Stream does I/O on a terminal or other interactive device."
207    (declare (type stream stream))    (declare (type stream stream))
208    (funcall (stream-misc stream) stream :interactive-p))    (funcall (lisp-stream-misc stream) stream :interactive-p))
209    
210  (defun open-stream-p (stream)  (defun open-stream-p (stream)
211    "Return true if and only if STREAM has not been closed."    "Return true if and only if STREAM has not been closed."
212    (declare (type stream stream))    (declare (type stream stream))
213    (not (eq (stream-in stream) #'closed-flame)))    (not (eq (lisp-stream-in stream) #'closed-flame)))
214    
215  (defun close (stream &key abort)  (defun close (stream &key abort)
216    "Closes the given Stream.  No more I/O may be performed, but inquiries    "Closes the given Stream.  No more I/O may be performed, but inquiries
# Line 201  Line 218 
218    up the side effects of having created the stream."    up the side effects of having created the stream."
219    (declare (type stream stream))    (declare (type stream stream))
220    (when (open-stream-p stream)    (when (open-stream-p stream)
221      (funcall (stream-misc stream) stream :close abort))      (funcall (lisp-stream-misc stream) stream :close abort))
222    t)    t)
223    
224  (defun set-closed-flame (stream)  (defun set-closed-flame (stream)
225    (setf (stream-in stream) #'closed-flame)    (setf (lisp-stream-in stream) #'closed-flame)
226    (setf (stream-bin stream) #'closed-flame)    (setf (lisp-stream-bin stream) #'closed-flame)
227    (setf (stream-n-bin stream) #'closed-flame)    (setf (lisp-stream-n-bin stream) #'closed-flame)
228    (setf (stream-in stream) #'closed-flame)    (setf (lisp-stream-in stream) #'closed-flame)
229    (setf (stream-out stream) #'closed-flame)    (setf (lisp-stream-out stream) #'closed-flame)
230    (setf (stream-bout stream) #'closed-flame)    (setf (lisp-stream-bout stream) #'closed-flame)
231    (setf (stream-sout stream) #'closed-flame)    (setf (lisp-stream-sout stream) #'closed-flame)
232    (setf (stream-misc stream) #'closed-flame))    (setf (lisp-stream-misc stream) #'closed-flame))
233    
234    
235  ;;;; File position and file length.  ;;;; File position and file length.
# Line 230  Line 247 
247             (type (or index (member nil :start :end)) position))             (type (or index (member nil :start :end)) position))
248    (cond    (cond
249     (position     (position
250      (setf (stream-in-index stream) in-buffer-length)      (setf (lisp-stream-in-index stream) in-buffer-length)
251      (funcall (stream-misc stream) stream :file-position position))      (funcall (lisp-stream-misc stream) stream :file-position position))
252     (t     (t
253      (let ((res (funcall (stream-misc stream) stream :file-position nil)))      (let ((res (funcall (lisp-stream-misc stream) stream :file-position nil)))
254        (when res (- res (- in-buffer-length (stream-in-index stream))))))))        (when res (- res (- in-buffer-length (lisp-stream-in-index stream))))))))
255    
256    
257  ;;; File-Length  --  Public  ;;; File-Length  --  Public
# Line 244  Line 261 
261  (defun file-length (stream)  (defun file-length (stream)
262    "This function returns the length of the file that File-Stream is open to."    "This function returns the length of the file that File-Stream is open to."
263    (declare (stream stream))    (declare (stream stream))
264    (funcall (stream-misc stream) stream :file-length))    (funcall (lisp-stream-misc stream) stream :file-length))
265    
266    
267  ;;; Input functions:  ;;; Input functions:
# Line 254  Line 271 
271    "Returns a line of text read from the Stream as a string, discarding the    "Returns a line of text read from the Stream as a string, discarding the
272    newline character."    newline character."
273    (declare (ignore recursive-p))    (declare (ignore recursive-p))
274    (prepare-for-fast-read-char stream    (let ((stream (in-synonym-of stream)))
275      (let ((res (make-string 80))      (if (lisp-stream-p stream)
276            (len 80)          (prepare-for-fast-read-char stream
277            (index 0))            (let ((res (make-string 80))
278        (loop                  (len 80)
279          (let ((ch (fast-read-char nil nil)))                  (index 0))
280            (cond (ch              (loop
281                   (when (char= ch #\newline)               (let ((ch (fast-read-char nil nil)))
282                     (done-with-fast-read-char)                 (cond (ch
283                     (return (values (shrink-vector res index) nil)))                        (when (char= ch #\newline)
284                   (when (= index len)                          (done-with-fast-read-char)
285                     (setq len (* len 2))                          (return (values (shrink-vector res index) nil)))
286                     (let ((new (make-string len)))                        (when (= index len)
287                       (replace new res)                          (setq len (* len 2))
288                       (setq res new)))                          (let ((new (make-string len)))
289                   (setf (schar res index) ch)                            (replace new res)
290                   (incf index))                            (setq res new)))
291                  ((zerop index)                        (setf (schar res index) ch)
292                   (done-with-fast-read-char)                        (incf index))
293                   (return (values (eof-or-lose (in-synonym-of stream)                       ((zerop index)
294                                                eof-errorp eof-value)                        (done-with-fast-read-char)
295                                   t)))                        (return (values (eof-or-lose stream eof-errorp eof-value)
296                  ;; since fast-read-char hit already the eof char, we                                        t)))
297                  ;; shouldn't do another read-char                       ;; since fast-read-char hit already the eof char, we
298                  (t                       ;; shouldn't do another read-char
299                   (done-with-fast-read-char)                       (t
300                   (return (values (shrink-vector res index) t)))))))))                        (done-with-fast-read-char)
301                          (return (values (shrink-vector res index) t))))))))
302            ;; Fundamental-stream.
303            (multiple-value-bind (string eof)
304                (stream-read-line stream)
305              (if (and eof (zerop (length string)))
306                  (values (eof-or-lose stream eof-errorp eof-value) t)
307                  (values string eof))))))
308    
309  ;;; We proclaim them inline here, then proclaim them notinline at EOF,  ;;; We proclaim them inline here, then proclaim them notinline at EOF,
310  ;;; so, except in this file, they are not inline by default, but they can be.  ;;; so, except in this file, they are not inline by default, but they can be.
# Line 291  Line 314 
314                              recursive-p)                              recursive-p)
315    "Inputs a character from Stream and returns it."    "Inputs a character from Stream and returns it."
316    (declare (ignore recursive-p))    (declare (ignore recursive-p))
317    (prepare-for-fast-read-char stream    (let ((stream (in-synonym-of stream)))
318      (prog1      (if (lisp-stream-p stream)
319          (fast-read-char eof-errorp eof-value)          (prepare-for-fast-read-char stream
320        (done-with-fast-read-char))))            (prog1
321                  (fast-read-char eof-errorp eof-value)
322                (done-with-fast-read-char)))
323            ;; Fundamental-stream.
324            (let ((char (stream-read-char stream)))
325              (if (eq char :eof)
326                  (eof-or-lose stream eof-errorp eof-value)
327                  char)))))
328    
329  (defun unread-char (character &optional (stream *standard-input*))  (defun unread-char (character &optional (stream *standard-input*))
330    "Puts the Character back on the front of the input Stream."    "Puts the Character back on the front of the input Stream."
331    (let* ((stream (in-synonym-of stream))    (let ((stream (in-synonym-of stream)))
332           (index (1- (stream-in-index stream)))      (if (lisp-stream-p stream)
333           (buffer (stream-in-buffer stream)))          (let ((index (1- (lisp-stream-in-index stream)))
334      (declare (fixnum index))                (buffer (lisp-stream-in-buffer stream)))
335      (when (minusp index) (error "Nothing to unread."))            (declare (fixnum index))
336      (cond (buffer            (when (minusp index) (error "Nothing to unread."))
337             (setf (aref buffer index) (char-code character))            (cond (buffer
338             (setf (stream-in-index stream) index))                   (setf (aref buffer index) (char-code character))
339            (t                   (setf (lisp-stream-in-index stream) index))
340             (funcall (stream-misc stream) stream :unread character))))                  (t
341                     (funcall (lisp-stream-misc stream) stream
342                              :unread character))))
343            ;; Fundamental-stream
344            (stream-unread-char stream character)))
345    nil)    nil)
346    
347  (defun peek-char (&optional (peek-type nil) (stream *standard-input*)  (defun peek-char (&optional (peek-type nil) (stream *standard-input*)
348                              (eof-errorp t) eof-value recursive-p)                              (eof-errorp t) eof-value recursive-p)
349    "Peeks at the next character in the input Stream.  See manual for details."    "Peeks at the next character in the input Stream.  See manual for details."
350    (declare (ignore recursive-p))    (declare (ignore recursive-p))
351    (let* ((stream (in-synonym-of stream))    (let ((stream (in-synonym-of stream)))
352           (char (read-char stream eof-errorp eof-value)))      (if (lisp-stream-p stream)
353      (cond ((eq char eof-value) char)          (let ((char (read-char stream eof-errorp eof-value)))
354            ((characterp peek-type)            (cond ((eq char eof-value) char)
355             (do ((char char (read-char stream eof-errorp eof-value)))                  ((characterp peek-type)
356                 ((or (eq char eof-value) (char= char peek-type))                   (do ((char char (read-char stream eof-errorp eof-value)))
357                  (unless (eq char eof-value)                       ((or (eq char eof-value) (char= char peek-type))
358                    (unread-char char stream))                        (unless (eq char eof-value)
359                  char)))                          (unread-char char stream))
360            ((eq peek-type t)                        char)))
361             (do ((char char (read-char stream eof-errorp eof-value)))                  ((eq peek-type t)
362                 ((or (eq char eof-value) (not (whitespace-char-p char)))                   (do ((char char (read-char stream eof-errorp eof-value)))
363                  (unless (eq char eof-value)                       ((or (eq char eof-value) (not (whitespace-char-p char)))
364                    (unread-char char stream))                        (unless (eq char eof-value)
365                  char)))                          (unread-char char stream))
366            (t                        char)))
367             (unread-char char stream)                  (t
368             char))))                   (unread-char char stream)
369                     char)))
370            ;; Fundamental-stream.
371            (cond ((characterp peek-type)
372                   (do ((char (stream-read-char stream) (stream-read-char stream)))
373                       ((or (eq char :eof) (char= char peek-type))
374                        (cond ((eq char :eof)
375                               (eof-or-lose stream eof-errorp eof-value))
376                              (t
377                               (stream-unread-char stream char)
378                               char)))))
379                  ((eq peek-type t)
380                   (do ((char (stream-read-char stream) (stream-read-char stream)))
381                       ((or (eq char :eof) (not (whitespace-char-p char)))
382                        (cond ((eq char :eof)
383                               (eof-or-lose stream eof-errorp eof-value))
384                              (t
385                               (stream-unread-char stream char)
386                               char)))))
387                  (t
388                   (let ((char (stream-peek-char stream)))
389                     (if (eq char :eof)
390                         (eof-or-lose stream eof-errorp eof-value)
391                         char)))))))
392    
393  (defun listen (&optional (stream *standard-input*))  (defun listen (&optional (stream *standard-input*))
394    "Returns T if a character is availible on the given Stream."    "Returns T if a character is availible on the given Stream."
395    (let ((stream (in-synonym-of stream)))    (let ((stream (in-synonym-of stream)))
396      (or (/= (the fixnum (stream-in-index stream)) in-buffer-length)      (if (lisp-stream-p stream)
397          ;; Test for t explicitly since misc methods return :eof sometimes.          (or (/= (the fixnum (lisp-stream-in-index stream)) in-buffer-length)
398          (eq (funcall (stream-misc stream) stream :listen) t))))              ;; Test for t explicitly since misc methods return :eof sometimes.
399                (eq (funcall (lisp-stream-misc stream) stream :listen) t))
400            ;; Fundamental-stream.
401            (stream-listen stream))))
402    
403  (defun read-char-no-hang (&optional (stream *standard-input*)  (defun read-char-no-hang (&optional (stream *standard-input*)
404                                      (eof-errorp t) eof-value recursive-p)                                      (eof-errorp t) eof-value recursive-p)
405    "Returns the next character from the Stream if one is availible, or nil."    "Returns the next character from the Stream if one is availible, or nil."
406    (declare (ignore recursive-p))    (declare (ignore recursive-p))
407    (let ((stream (in-synonym-of stream)))    (let ((stream (in-synonym-of stream)))
408      (if (funcall (stream-misc stream) stream :listen)      (if (lisp-stream-p stream)
409          ;; On t or :eof get READ-CHAR to do the work.          (if (funcall (lisp-stream-misc stream) stream :listen)
410          (read-char stream eof-errorp eof-value)              ;; On t or :eof get READ-CHAR to do the work.
411          nil)))              (read-char stream eof-errorp eof-value)
412                nil)
413            ;; Fundamental-stream.
414            (let ((char (stream-read-char-no-hang stream)))
415              (if (eq char :eof)
416                  (eof-or-lose stream eof-errorp eof-value)
417                  char)))))
418    
419    
420  (defun clear-input (&optional (stream *standard-input*))  (defun clear-input (&optional (stream *standard-input*))
421    "Clears any buffered input associated with the Stream."    "Clears any buffered input associated with the Stream."
422    (let ((stream (in-synonym-of stream)))    (let ((stream (in-synonym-of stream)))
423      (setf (stream-in-index stream) in-buffer-length)      (cond ((lisp-stream-p stream)
424      (funcall (stream-misc stream) stream :clear-input)             (setf (lisp-stream-in-index stream) in-buffer-length)
425      nil))             (funcall (lisp-stream-misc stream) stream :clear-input))
426              (t
427               (stream-clear-input stream))))
428      nil)
429    
430  (defun read-byte (stream &optional (eof-errorp t) eof-value)  (defun read-byte (stream &optional (eof-errorp t) eof-value)
431    "Returns the next byte of the Stream."    "Returns the next byte of the Stream."
432    (prepare-for-fast-read-byte stream    (let ((stream (in-synonym-of stream)))
433      (prog1      (if (lisp-stream-p stream)
434          (fast-read-byte eof-errorp eof-value t)          (prepare-for-fast-read-byte stream
435        (done-with-fast-read-byte))))            (prog1
436                  (fast-read-byte eof-errorp eof-value t)
437                (done-with-fast-read-byte)))
438            ;; Fundamental-stream.
439            (let ((char (stream-read-byte stream)))
440              (if (eq char :eof)
441                  (eof-or-lose stream eof-errorp eof-value)
442                  char)))))
443    
444  (defun read-n-bytes (stream buffer start numbytes &optional (eof-errorp t))  (defun read-n-bytes (stream buffer start numbytes &optional (eof-errorp t))
445    "Reads Numbytes bytes into the Buffer starting at Start, returning the number    "Reads Numbytes bytes into the Buffer starting at Start, returning the number
# Line 373  Line 450 
450        available (up to count bytes.)  On pipes or similar devices, this        available (up to count bytes.)  On pipes or similar devices, this
451        function returns as soon as any adata is available, even if the amount        function returns as soon as any adata is available, even if the amount
452        read is less than Count and eof has not been hit."        read is less than Count and eof has not been hit."
453    (declare (type index numbytes start)    (declare (type lisp-stream stream)
454               (type index numbytes start)
455             (type (or (simple-array * (*)) system-area-pointer) buffer))             (type (or (simple-array * (*)) system-area-pointer) buffer))
456    (let* ((stream (in-synonym-of stream))    (let* ((stream (in-synonym-of stream lisp-stream))
457           (in-buffer (stream-in-buffer stream))           (in-buffer (lisp-stream-in-buffer stream))
458           (index (stream-in-index stream))           (index (lisp-stream-in-index stream))
459           (num-buffered (- in-buffer-length index)))           (num-buffered (- in-buffer-length index)))
460      (declare (fixnum index num-buffered))      (declare (fixnum index num-buffered))
461      (cond      (cond
462       ((not in-buffer)       ((not in-buffer)
463        (funcall (stream-n-bin stream) stream buffer start numbytes eof-errorp))        (funcall (lisp-stream-n-bin stream) stream buffer start numbytes eof-errorp))
464       ((<= numbytes num-buffered)       ((<= numbytes num-buffered)
465        (%primitive byte-blt in-buffer index buffer start (+ start numbytes))        (%primitive byte-blt in-buffer index buffer start (+ start numbytes))
466        (setf (stream-in-index stream) (+ index numbytes))        (setf (lisp-stream-in-index stream) (+ index numbytes))
467        numbytes)        numbytes)
468       (t       (t
469        (let ((end (+ start num-buffered)))        (let ((end (+ start num-buffered)))
470          (%primitive byte-blt in-buffer index buffer start end)          (%primitive byte-blt in-buffer index buffer start end)
471          (setf (stream-in-index stream) in-buffer-length)          (setf (lisp-stream-in-index stream) in-buffer-length)
472          (+ (funcall (stream-n-bin stream) stream buffer end          (+ (funcall (lisp-stream-n-bin stream) stream buffer end
473                      (- numbytes num-buffered)                      (- numbytes num-buffered)
474                      eof-errorp)                      eof-errorp)
475             num-buffered))))))             num-buffered))))))
# Line 409  Line 487 
487  ;;; myst be an n-bin method.  ;;; myst be an n-bin method.
488  ;;;  ;;;
489  (defun fast-read-char-refill (stream eof-errorp eof-value)  (defun fast-read-char-refill (stream eof-errorp eof-value)
490    (let* ((ibuf (stream-in-buffer stream))    (let* ((ibuf (lisp-stream-in-buffer stream))
491           (count (funcall (stream-n-bin stream) stream           (count (funcall (lisp-stream-n-bin stream) stream
492                           ibuf in-buffer-extra                           ibuf in-buffer-extra
493                           (- in-buffer-length in-buffer-extra)                           (- in-buffer-length in-buffer-extra)
494                           nil))                           nil))
495           (start (- in-buffer-length count)))           (start (- in-buffer-length count)))
496      (declare (type index start count))      (declare (type index start count))
497      (cond ((zerop count)      (cond ((zerop count)
498             (setf (stream-in-index stream) in-buffer-length)             (setf (lisp-stream-in-index stream) in-buffer-length)
499             (funcall (stream-in stream) stream eof-errorp eof-value))             (funcall (lisp-stream-in stream) stream eof-errorp eof-value))
500            (t            (t
501             (when (/= start in-buffer-extra)             (when (/= start in-buffer-extra)
502               (bit-bash-copy ibuf (+ (* in-buffer-extra vm:byte-bits)               (bit-bash-copy ibuf (+ (* in-buffer-extra vm:byte-bits)
# Line 426  Line 504 
504                              ibuf (+ (the index (* start vm:byte-bits))                              ibuf (+ (the index (* start vm:byte-bits))
505                                      (* vm:vector-data-offset vm:word-bits))                                      (* vm:vector-data-offset vm:word-bits))
506                              (* count vm:byte-bits)))                              (* count vm:byte-bits)))
507             (setf (stream-in-index stream) (1+ start))             (setf (lisp-stream-in-index stream) (1+ start))
508             (code-char (aref ibuf start))))))             (code-char (aref ibuf start))))))
509    
510    
# Line 436  Line 514 
514  ;;; unreading.  ;;; unreading.
515  ;;;  ;;;
516  (defun fast-read-byte-refill (stream eof-errorp eof-value)  (defun fast-read-byte-refill (stream eof-errorp eof-value)
517    (let* ((ibuf (stream-in-buffer stream))    (let* ((ibuf (lisp-stream-in-buffer stream))
518           (count (funcall (stream-n-bin stream) stream           (count (funcall (lisp-stream-n-bin stream) stream
519                           ibuf 0 in-buffer-length                           ibuf 0 in-buffer-length
520                           nil))                           nil))
521           (start (- in-buffer-length count)))           (start (- in-buffer-length count)))
522      (declare (type index start count))      (declare (type index start count))
523      (cond ((zerop count)      (cond ((zerop count)
524             (setf (stream-in-index stream) in-buffer-length)             (setf (lisp-stream-in-index stream) in-buffer-length)
525             (funcall (stream-bin stream) stream eof-errorp eof-value))             (funcall (lisp-stream-bin stream) stream eof-errorp eof-value))
526            (t            (t
527             (unless (zerop start)             (unless (zerop start)
528               (bit-bash-copy ibuf (* vm:vector-data-offset vm:word-bits)               (bit-bash-copy ibuf (* vm:vector-data-offset vm:word-bits)
529                              ibuf (+ (the index (* start vm:byte-bits))                              ibuf (+ (the index (* start vm:byte-bits))
530                                      (* vm:vector-data-offset vm:word-bits))                                      (* vm:vector-data-offset vm:word-bits))
531                              (* count vm:byte-bits)))                              (* count vm:byte-bits)))
532             (setf (stream-in-index stream) (1+ start))             (setf (lisp-stream-in-index stream) (1+ start))
533             (aref ibuf start)))))             (aref ibuf start)))))
534    
535    
# Line 459  Line 537 
537    
538  (defun write-char (character &optional (stream *standard-output*))  (defun write-char (character &optional (stream *standard-output*))
539    "Outputs the Character to the Stream."    "Outputs the Character to the Stream."
540    (with-out-stream stream stream-out character)    (with-out-stream stream (lisp-stream-out character)
541                       (stream-write-char character))
542    character)    character)
543    
544  (defun terpri (&optional (stream *standard-output*))  (defun terpri (&optional (stream *standard-output*))
545    "Outputs a new line to the Stream."    "Outputs a new line to the Stream."
546    (with-out-stream stream stream-out #\newline)    (with-out-stream stream (lisp-stream-out #\newline) (stream-terpri))
547    nil)    nil)
548    
549  (defun fresh-line (&optional (stream *standard-output*))  (defun fresh-line (&optional (stream *standard-output*))
550    "Outputs a new line to the Stream if it is not positioned at the begining of    "Outputs a new line to the Stream if it is not positioned at the begining of
551     a line.  Returns T if it output a new line, nil otherwise."     a line.  Returns T if it output a new line, nil otherwise."
552    (let ((stream (out-synonym-of stream)))    (let ((stream (out-synonym-of stream)))
553      (when (/= (or (charpos stream) 1) 0)      (if (lisp-stream-p stream)
554        (funcall (stream-out stream) stream #\newline)          (when (/= (or (charpos stream) 1) 0)
555        t)))            (funcall (lisp-stream-out stream) stream #\newline)
556              t)
557            ;; Fundamental-stream.
558            (stream-fresh-line stream))))
559    
560  (defun write-string (string &optional (stream *standard-output*)  (defun write-string (string &optional (stream *standard-output*)
561                              &key (start 0) (end (length (the vector string))))                              &key (start 0) (end (length (the vector string))))
# Line 483  Line 565 
565  (defun write-string* (string &optional (stream *standard-output*)  (defun write-string* (string &optional (stream *standard-output*)
566                               (start 0) (end (length (the vector string))))                               (start 0) (end (length (the vector string))))
567    (declare (fixnum start end))    (declare (fixnum start end))
568    (if (array-header-p string)    (let ((stream (out-synonym-of stream)))
569        (with-array-data ((data string) (offset-start start) (offset-end end))      (cond ((lisp-stream-p stream)
570          (with-out-stream stream stream-sout data offset-start offset-end))             (if (array-header-p string)
571        (with-out-stream stream stream-sout string start end))                 (with-array-data ((data string) (offset-start start)
572    string)                                   (offset-end end))
573                     (funcall (lisp-stream-sout stream)
574                              stream data offset-start offset-end))
575                   (funcall (lisp-stream-sout stream) stream string start end))
576               string)
577              (t    ; Fundamental-stream.
578               (stream-write-string stream string start end)))))
579    
580  (defun write-line (string &optional (stream *standard-output*)  (defun write-line (string &optional (stream *standard-output*)
581                            &key (start 0) (end (length string)))                            &key (start 0) (end (length string)))
# Line 498  Line 586 
586                             (start 0) (end (length string)))                             (start 0) (end (length string)))
587    (declare (fixnum start end))    (declare (fixnum start end))
588    (let ((stream (out-synonym-of stream)))    (let ((stream (out-synonym-of stream)))
589      (if (array-header-p string)      (cond ((lisp-stream-p stream)
590          (with-array-data ((data string) (offset-start start) (offset-end end))             (if (array-header-p string)
591            (with-out-stream stream stream-sout data offset-start offset-end))                 (with-array-data ((data string) (offset-start start)
592          (with-out-stream stream stream-sout string start end))                                   (offset-end end))
593      (funcall (stream-out stream) stream #\newline))                   (with-out-stream stream (lisp-stream-sout data offset-start
594    string)                                                             offset-end)))
595                   (with-out-stream stream (lisp-stream-sout string start end)))
596               (funcall (lisp-stream-out stream) stream #\newline))
597              (t    ; Fundamental-stream.
598               (stream-write-string stream string start end)
599               (stream-write-char stream #\Newline)))
600        string))
601    
602  (defun charpos (&optional (stream *standard-output*))  (defun charpos (&optional (stream *standard-output*))
603    "Returns the number of characters on the current line of output of the given    "Returns the number of characters on the current line of output of the given
604    Stream, or Nil if that information is not availible."    Stream, or Nil if that information is not availible."
605    (with-out-stream stream stream-misc :charpos))    (with-out-stream stream (lisp-stream-misc :charpos) (stream-line-column)))
606    
607  (defun line-length (&optional (stream *standard-output*))  (defun line-length (&optional (stream *standard-output*))
608    "Returns the number of characters that will fit on a line of output on the    "Returns the number of characters that will fit on a line of output on the
609    given Stream, or Nil if that information is not available."    given Stream, or Nil if that information is not available."
610    (with-out-stream stream stream-misc :line-length))    (with-out-stream stream (lisp-stream-misc :line-length)
611                       (stream-line-length)))
612    
613  (defun finish-output (&optional (stream *standard-output*))  (defun finish-output (&optional (stream *standard-output*))
614    "Attempts to ensure that all output sent to the the Stream has reached its    "Attempts to ensure that all output sent to the Stream has reached its
615     destination, and only then returns."     destination, and only then returns."
616    (with-out-stream stream stream-misc :finish-output)    (with-out-stream stream (lisp-stream-misc :finish-output)
617                       (stream-finish-output))
618    nil)    nil)
619    
620  (defun force-output (&optional (stream *standard-output*))  (defun force-output (&optional (stream *standard-output*))
621    "Attempts to force any buffered output to be sent."    "Attempts to force any buffered output to be sent."
622    (with-out-stream stream stream-misc :force-output)    (with-out-stream stream (lisp-stream-misc :force-output)
623                       (stream-force-output))
624    nil)    nil)
625    
626  (defun clear-output (&optional (stream *standard-output*))  (defun clear-output (&optional (stream *standard-output*))
627    "Clears the given output Stream."    "Clears the given output Stream."
628    (with-out-stream stream stream-misc :clear-output)    (with-out-stream stream (lisp-stream-misc :clear-output)
629                       (stream-force-output))
630    nil)    nil)
631    
632  (defun write-byte (integer stream)  (defun write-byte (integer stream)
633    "Outputs the Integer to the binary Stream."    "Outputs the Integer to the binary Stream."
634    (with-out-stream stream stream-bout integer)    (with-out-stream stream (lisp-stream-bout integer)
635                       (stream-write-byte integer))
636    integer)    integer)
637    
638    
639    ;;; Stream-misc-dispatch
640    ;;;
641    ;;; Called from lisp-steam routines that encapsulate CLOS streams to
642    ;;; handle the misc routines and dispatch to the appropriate Gray
643    ;;; stream functions.
644    ;;;
645    (defun stream-misc-dispatch (stream operation &optional arg1 arg2)
646      (declare (type fundamental-stream stream)
647               (ignore arg2))
648      (case operation
649        (:listen
650         ;; Return true is input available, :eof for eof-of-file, otherwise Nil.
651         (let ((char (stream-read-char-no-hang stream)))
652           (when (characterp char)
653             (stream-unread-char stream char))
654           char))
655        (:unread
656         (stream-unread-char stream arg1))
657        (:close
658         (close stream))
659        (:clear-input
660         (stream-clear-input stream))
661        (:force-output
662         (stream-force-output stream))
663        (:finish-output
664         (stream-finish-output stream))
665        (:element-type
666         (stream-element-type stream))
667        (:interactive-p
668         (interactive-stream-p stream))
669        (:line-length
670         (stream-line-length stream))
671        (:charpos
672         (stream-line-column stream))
673        (:file-length
674         (file-length stream))
675        (:file-position
676         (file-position stream arg1))))
677    
678    
679  ;;;; Broadcast streams:  ;;;; Broadcast streams:
680    
681  (defstruct (broadcast-stream (:include stream  (defstruct (broadcast-stream (:include lisp-stream
682                                         (out #'broadcast-out)                                         (out #'broadcast-out)
683                                         (bout #'broadcast-bout)                                         (bout #'broadcast-bout)
684                                         (sout #'broadcast-sout)                                         (sout #'broadcast-sout)
# Line 555  Line 695 
695    (declare (ignore s d))    (declare (ignore s d))
696    (write-string "#<Broadcast Stream>" stream))    (write-string "#<Broadcast Stream>" stream))
697    
698  (macrolet ((out-fun (fun method &rest args)  (macrolet ((out-fun (fun method stream-method &rest args)
699               `(defun ,fun (stream ,@args)               `(defun ,fun (stream ,@args)
700                  (dolist (stream (broadcast-stream-streams stream))                  (dolist (stream (broadcast-stream-streams stream))
701                    (funcall (,method stream) stream ,@args)))))                    (if (lisp-stream-p stream)
702    (out-fun broadcast-out stream-out char)                        (funcall (,method stream) stream ,@args)
703    (out-fun broadcast-bout stream-bout byte)                        (,stream-method stream ,@args))))))
704    (out-fun broadcast-sout stream-sout string start end))    (out-fun broadcast-out lisp-stream-out stream-write-char char)
705      (out-fun broadcast-bout lisp-stream-bout stream-write-byte byte)
706      (out-fun broadcast-sout lisp-stream-sout stream-write-string
707               string start end))
708    
709  (defun broadcast-misc (stream operation &optional arg1 arg2)  (defun broadcast-misc (stream operation &optional arg1 arg2)
710    (let ((streams (broadcast-stream-streams stream)))    (let ((streams (broadcast-stream-streams stream)))
711      (case operation      (case operation
712        (:charpos        (:charpos
713         (dolist (stream streams)         (dolist (stream streams)
714           (let ((charpos (funcall (stream-misc stream) stream :charpos)))           (let ((charpos (charpos stream)))
715             (if charpos (return charpos)))))             (if charpos (return charpos)))))
716        (:line-length        (:line-length
717         (let ((min nil))         (let ((min nil))
718           (dolist (stream streams min)           (dolist (stream streams min)
719             (let ((res (funcall (stream-misc stream) stream :line-length)))             (let ((res (line-length stream)))
720               (when res (setq min (if min (min res min) res)))))))               (when res (setq min (if min (min res min) res)))))))
721        (:element-type        (:element-type
722         (let (res)         (let (res)
723           (dolist (stream streams (if (> (length res) 1) `(and ,@res) res))           (dolist (stream streams (if (> (length res) 1) `(and ,@res) res))
724             (pushnew (funcall (stream-misc stream) stream :element-type) res             (pushnew (stream-element-type stream) res :test #'equal))))
                     :test #'equal))))  
725        (:close)        (:close)
726        (t        (t
727         (let ((res nil))         (let ((res nil))
728           (dolist (stream streams res)           (dolist (stream streams res)
729             (setq res (funcall (stream-misc stream) stream operation             (setq res
730                                arg1 arg2))))))))                   (if (lisp-stream-p stream)
731                         (funcall (lisp-stream-misc stream) stream operation
732                                  arg1 arg2)
733                         (stream-misc-dispatch stream operation arg1 arg2)))))))))
734    
735    
736  ;;;; Synonym Streams:  ;;;; Synonym Streams:
737    
738  (defstruct (synonym-stream (:include stream  (defstruct (synonym-stream (:include lisp-stream
739                                       (in #'synonym-in)                                       (in #'synonym-in)
740                                       (bin #'synonym-bin)                                       (bin #'synonym-bin)
741                                       (n-bin #'synonym-n-bin)                                       (n-bin #'synonym-n-bin)
# Line 613  Line 759 
759  ;;; The output simple output methods just call the corresponding method  ;;; The output simple output methods just call the corresponding method
760  ;;; in the synonymed stream.  ;;; in the synonymed stream.
761  ;;;  ;;;
762  (macrolet ((out-fun (name slot &rest args)  (macrolet ((out-fun (name slot stream-method &rest args)
763               `(defun ,name (stream ,@args)               `(defun ,name (stream ,@args)
764                  (declare (optimize (safety 1)))                  (declare (optimize (safety 1)))
765                  (let ((syn (symbol-value (synonym-stream-symbol stream))))                  (let ((syn (symbol-value (synonym-stream-symbol stream))))
766                    (funcall (,slot syn) syn ,@args)))))                    (if (lisp-stream-p syn)
767    (out-fun synonym-out stream-out ch)                        (funcall (,slot syn) syn ,@args)
768    (out-fun synonym-bout stream-bout n)                        (,stream-method syn ,@args))))))
769    (out-fun synonym-sout stream-sout string start end))    (out-fun synonym-out lisp-stream-out stream-write-char ch)
770      (out-fun synonym-bout lisp-stream-bout stream-write-byte n)
771      (out-fun synonym-sout lisp-stream-sout stream-write-string string start end))
772    
773    
774  ;;; Bind synonym stream to this so that SPIO can turn on the right frob in  ;;; Bind synonym stream to this so that SPIO can turn on the right frob in
# Line 651  Line 799 
799    (declare (optimize (safety 1)))    (declare (optimize (safety 1)))
800    (let ((syn (symbol-value (synonym-stream-symbol stream)))    (let ((syn (symbol-value (synonym-stream-symbol stream)))
801          (*previous-stream* stream))          (*previous-stream* stream))
802      (case operation      (if (lisp-stream-p syn)
803        (:listen (or (/= (the fixnum (stream-in-index syn)) in-buffer-length)          (case operation
804                     (funcall (stream-misc syn) syn :listen)))            (:listen (or (/= (the fixnum (lisp-stream-in-index syn))
805        (t                             in-buffer-length)
806         (funcall (stream-misc syn) syn operation arg1 arg2)))))                         (funcall (lisp-stream-misc syn) syn :listen)))
807              (:clear-input (clear-input syn))
808              (:unread (unread-char arg1 syn))
809              (t
810               (funcall (lisp-stream-misc syn) syn operation arg1 arg2)))
811            (stream-misc-dispatch syn operation arg1 arg2))))
812    
813  ;;;; Two-Way streams:  ;;;; Two-Way streams:
814    
815  (defstruct (two-way-stream  (defstruct (two-way-stream
816              (:include stream              (:include lisp-stream
817                        (in #'two-way-in)                        (in #'two-way-in)
818                        (bin #'two-way-bin)                        (bin #'two-way-bin)
819                        (n-bin #'two-way-n-bin)                        (n-bin #'two-way-n-bin)
# Line 685  Line 838 
838    "Returns a bidirectional stream which gets its input from Input-Stream and    "Returns a bidirectional stream which gets its input from Input-Stream and
839     sends its output to Output-Stream.")     sends its output to Output-Stream.")
840    
841  (macrolet ((out-fun (name slot &rest args)  (macrolet ((out-fun (name slot stream-method &rest args)
842               `(defun ,name (stream ,@args)               `(defun ,name (stream ,@args)
843                  (let ((syn (two-way-stream-output-stream stream)))                  (let ((syn (two-way-stream-output-stream stream)))
844                    (funcall (,slot syn) syn ,@args)))))                    (if (lisp-stream-p syn)
845    (out-fun two-way-out stream-out ch)                        (funcall (,slot syn) syn ,@args)
846    (out-fun two-way-bout stream-bout n)                        (,stream-method syn ,@args))))))
847    (out-fun two-way-sout stream-sout string start end))    (out-fun two-way-out lisp-stream-out stream-write-char ch)
848      (out-fun two-way-bout lisp-stream-bout stream-write-byte n)
849      (out-fun two-way-sout lisp-stream-sout stream-write-string string start end))
850    
851  (macrolet ((in-fun (name fun &rest args)  (macrolet ((in-fun (name fun &rest args)
852               `(defun ,name (stream ,@args)               `(defun ,name (stream ,@args)
# Line 703  Line 858 
858    
859  (defun two-way-misc (stream operation &optional arg1 arg2)  (defun two-way-misc (stream operation &optional arg1 arg2)
860    (let* ((in (two-way-stream-input-stream stream))    (let* ((in (two-way-stream-input-stream stream))
          (in-method (stream-misc in))  
861           (out (two-way-stream-output-stream stream))           (out (two-way-stream-output-stream stream))
862           (out-method (stream-misc out)))           (in-lisp-stream-p (lisp-stream-p in))
863             (out-lisp-stream-p (lisp-stream-p out)))
864      (case operation      (case operation
865        (:listen (or (/= (the fixnum (stream-in-index in)) in-buffer-length)        (:listen
866                     (funcall in-method in :listen)))         (if in-lisp-stream-p
867               (or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length)
868                   (funcall (lisp-stream-misc in) in :listen))
869               (stream-listen in)))
870        ((:finish-output :force-output :clear-output)        ((:finish-output :force-output :clear-output)
871         (funcall out-method out operation arg1 arg2))         (if out-lisp-stream-p
872        ((:clear-input :unread)             (funcall (lisp-stream-misc out) out operation arg1 arg2)
873         (funcall in-method in operation arg1 arg2))             (stream-misc-dispatch out operation arg1 arg2)))
874          (:clear-input (clear-input in))
875          (:unread (unread-char arg1 in))
876        (:element-type        (:element-type
877         (let ((in-type (funcall in-method in :element-type))         (let ((in-type (stream-element-type in))
878               (out-type (funcall out-method out :element-type)))               (out-type (stream-element-type out)))
879           (if (equal in-type out-type)           (if (equal in-type out-type)
880               in-type `(and ,in-type ,out-type))))               in-type `(and ,in-type ,out-type))))
881        (:close        (:close
882         (set-closed-flame stream))         (set-closed-flame stream))
883        (t        (t
884         (or (funcall in-method in operation arg1 arg2)         (or (if in-lisp-stream-p
885             (funcall out-method out operation arg1 arg2))))))                 (funcall (lisp-stream-misc in) in operation arg1 arg2)
886                   (stream-misc-dispatch in operation arg1 arg2))
887               (if out-lisp-stream-p
888                   (funcall (lisp-stream-misc out) out operation arg1 arg2)
889                   (stream-misc-dispatch out operation arg1 arg2)))))))
890    
891    
892  ;;;; Concatenated Streams:  ;;;; Concatenated Streams:
893    
894  (defstruct (concatenated-stream  (defstruct (concatenated-stream
895              (:include stream              (:include lisp-stream
896                        (in #'concatenated-in)                        (in #'concatenated-in)
897                        (bin #'concatenated-bin)                        (bin #'concatenated-bin)
898                        (misc #'concatenated-misc))                        (misc #'concatenated-misc))
899              (:print-function %print-concatenated-stream)              (:print-function %print-concatenated-stream)
900              (:constructor              (:constructor make-concatenated-stream (&rest streams)))
901               make-concatenated-stream (&rest streams &aux (current streams))))    ;; This is a list of all the streams. The car of this is the stream
902    ;; The car of this is the stream we are reading from now.    ;; we are reading from now.
903    current    (streams nil :type list))
   ;; This is a list of all the streams.  We need to remember them so that  
   ;; we can close them.  
   (streams nil :type list :read-only t))  
904    
905  (defun %print-concatenated-stream (s stream d)  (defun %print-concatenated-stream (s stream d)
906    (declare (ignore d))    (declare (ignore d))
# Line 751  Line 913 
913    
914  (macrolet ((in-fun (name fun)  (macrolet ((in-fun (name fun)
915               `(defun ,name (stream eof-errorp eof-value)               `(defun ,name (stream eof-errorp eof-value)
916                  (do ((current (concatenated-stream-current stream) (cdr current)))                  (do ((current (concatenated-stream-streams stream)
917                                  (cdr current)))
918                      ((null current)                      ((null current)
919                       (eof-or-lose stream eof-errorp eof-value))                       (eof-or-lose stream eof-errorp eof-value))
920                    (let* ((stream (car current))                    (let* ((stream (car current))
921                           (result (,fun stream nil nil)))                           (result (,fun stream nil nil)))
922                      (when result (return result)))                      (when result (return result)))
923                    (setf (concatenated-stream-current stream) current)))))                    (setf (concatenated-stream-streams stream) (cdr current))))))
924    (in-fun concatenated-in read-char)    (in-fun concatenated-in read-char)
925    (in-fun concatenated-bin read-byte))    (in-fun concatenated-bin read-byte))
926    
927  (defun concatenated-misc (stream operation &optional arg1 arg2)  (defun concatenated-misc (stream operation &optional arg1 arg2)
928    (let ((left (concatenated-stream-current stream)))    (let ((left (concatenated-stream-streams stream)))
929      (when left      (when left
930        (let* ((current (car left))        (let* ((current (car left)))
              (misc (stream-misc current)))  
931          (case operation          (case operation
932            (:listen            (:listen
933             (loop             (loop
934               (let ((stuff (funcall misc current :listen)))               (let ((stuff (if (lisp-stream-p current)
935                                  (funcall (lisp-stream-misc current) current
936                                           :listen)
937                                  (stream-misc-dispatch current :listen))))
938                 (cond ((eq stuff :eof)                 (cond ((eq stuff :eof)
939                        ;; Advance current, and try again.                        ;; Advance current, and try again.
940                        (pop (concatenated-stream-current stream))                        (pop (concatenated-stream-streams stream))
941                        (setf current                        (setf current
942                              (car (concatenated-stream-current stream)))                              (car (concatenated-stream-streams stream)))
943                        (unless current                        (unless current
944                          ;; No further streams.  EOF.                          ;; No further streams.  EOF.
945                          (return :eof))                          (return :eof)))
                       (setf misc (stream-misc current)))  
946                       (stuff                       (stuff
947                        ;; Stuff's available.                        ;; Stuff's available.
948                        (return t))                        (return t))
# Line 787  Line 951 
951                        (return nil))))))                        (return nil))))))
952            (:close            (:close
953             (set-closed-flame stream))             (set-closed-flame stream))
954              (:clear-input (clear-input current))
955              (:unread (unread-char arg1 current))
956            (t            (t
957             (funcall misc current operation arg1 arg2)))))))             (if (lisp-stream-p current)
958                   (funcall (lisp-stream-misc current) current operation arg1 arg2)
959                   (stream-misc-dispatch current operation arg1 arg2))))))))
960    
961    
962  ;;;; Echo Streams:  ;;;; Echo Streams:
963    
# Line 803  Line 972 
972    unread-stuff)    unread-stuff)
973    
974    
975  (macrolet ((in-fun (name fun out-slot &rest args)  (macrolet ((in-fun (name fun out-slot stream-method)
976               `(defun ,name (stream ,@args)               `(defun ,name (stream eof-errorp eof-value)
977                  (or (pop (echo-stream-unread-stuff stream))                  (or (pop (echo-stream-unread-stuff stream))
978                      (let* ((in (echo-stream-input-stream stream))                      (let* ((in (echo-stream-input-stream stream))
979                             (out (echo-stream-output-stream stream))                             (out (echo-stream-output-stream stream))
980                             (result (,fun in ,@args)))                             (result (,fun in nil :eof)))
981                        (funcall (,out-slot out) out result)                        (cond ((eq result :eof)
982                        result)))))                               (eof-or-lose stream eof-errorp eof-value))
983    (in-fun echo-in read-char stream-out eof-errorp eof-value)                              (t
984    (in-fun echo-bin read-byte stream-bout eof-errorp eof-value))                               (if (lisp-stream-p out)
985                                     (funcall (,out-slot out) out result)
986                                     (,stream-method out result))
987                                 result)))))))
988      (in-fun echo-in read-char lisp-stream-out stream-write-char)
989      (in-fun echo-bin read-byte lisp-stream-bout stream-write-byte))
990    
991  (defun echo-misc (stream operation &optional arg1 arg2)  (defun echo-misc (stream operation &optional arg1 arg2)
992    (let* ((in (two-way-stream-input-stream stream))    (let* ((in (two-way-stream-input-stream stream))
993           (in-method (stream-misc in))           (out (two-way-stream-output-stream stream)))
          (out (two-way-stream-output-stream stream))  
          (out-method (stream-misc out)))  
994      (case operation      (case operation
995        (:listen (or (not (null (echo-stream-unread-stuff stream)))        (:listen
996                     (/= (the fixnum (stream-in-index in)) in-buffer-length)         (or (not (null (echo-stream-unread-stuff stream)))
997                     (funcall in-method in :listen)))             (if (lisp-stream-p in)
998                   (or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length)
999                       (funcall (lisp-stream-misc in) in :listen))
1000                   (stream-misc-dispatch in :listen))))
1001        (:unread (push arg1 (echo-stream-unread-stuff stream)))        (:unread (push arg1 (echo-stream-unread-stuff stream)))
1002        (:element-type        (:element-type
1003         (let ((in-type (funcall in-method in :element-type))         (let ((in-type (stream-element-type in))
1004               (out-type (funcall out-method out :element-type)))               (out-type (stream-element-type out)))
1005           (if (equal in-type out-type)           (if (equal in-type out-type)
1006               in-type `(and ,in-type ,out-type))))               in-type `(and ,in-type ,out-type))))
1007        (:close        (:close
1008         (set-closed-flame stream))         (set-closed-flame stream))
1009        (t        (t
1010         (or (funcall in-method in operation arg1 arg2)         (or (if (lisp-stream-p in)
1011             (funcall out-method out operation arg1 arg2))))))                 (funcall (lisp-stream-misc in) in operation arg1 arg2)
1012                   (stream-misc-dispatch in operation arg1 arg2))
1013               (if (lisp-stream-p out)
1014                   (funcall (lisp-stream-misc out) out operation arg1 arg2)
1015                   (stream-misc-dispatch out operation arg1 arg2)))))))
1016    
1017  (defun %print-echo-stream (s stream d)  (defun %print-echo-stream (s stream d)
1018    (declare (ignore d))    (declare (ignore d))
# Line 849  Line 1028 
1028  ;;;; String Input Streams:  ;;;; String Input Streams:
1029    
1030  (defstruct (string-input-stream  (defstruct (string-input-stream
1031               (:include stream               (:include lisp-stream
1032                         (in #'string-inch)                         (in #'string-inch)
1033                         (bin #'string-binch)                         (bin #'string-binch)
1034                         (n-bin #'string-stream-read-n-bytes)                         (n-bin #'string-stream-read-n-bytes)
# Line 859  Line 1038 
1038               (:constructor internal-make-string-input-stream               (:constructor internal-make-string-input-stream
1039                             (string current end)))                             (string current end)))
1040    (string nil :type simple-string)    (string nil :type simple-string)
1041    (current nil :type fixnum)    (current nil :type index)
1042    (end nil :type fixnum))    (end nil :type index))
1043    
1044  (defun %print-string-input-stream (s stream d)  (defun %print-string-input-stream (s stream d)
1045    (declare (ignore s d))    (declare (ignore s d))
# Line 870  Line 1049 
1049    (let ((string (string-input-stream-string stream))    (let ((string (string-input-stream-string stream))
1050          (index (string-input-stream-current stream)))          (index (string-input-stream-current stream)))
1051      (declare (simple-string string) (fixnum index))      (declare (simple-string string) (fixnum index))
1052      (cond ((= index (the fixnum (string-input-stream-end stream)))      (cond ((= index (the index (string-input-stream-end stream)))
1053             (eof-or-lose stream eof-errorp eof-value))             (eof-or-lose stream eof-errorp eof-value))
1054            (t            (t
1055             (setf (string-input-stream-current stream) (1+ index))             (setf (string-input-stream-current stream) (1+ index))
# Line 879  Line 1058 
1058  (defun string-binch (stream eof-errorp eof-value)  (defun string-binch (stream eof-errorp eof-value)
1059    (let ((string (string-input-stream-string stream))    (let ((string (string-input-stream-string stream))
1060          (index (string-input-stream-current stream)))          (index (string-input-stream-current stream)))
1061      (declare (simple-string string) (fixnum index))      (declare (simple-string string)
1062      (cond ((= index (the fixnum (string-input-stream-end stream)))               (type index index))
1063        (cond ((= index (the index (string-input-stream-end stream)))
1064             (eof-or-lose stream eof-errorp eof-value))             (eof-or-lose stream eof-errorp eof-value))
1065            (t            (t
1066             (setf (string-input-stream-current stream) (1+ index))             (setf (string-input-stream-current stream) (1+ index))
# Line 889  Line 1069 
1069  (defun string-stream-read-n-bytes (stream buffer start requested eof-errorp)  (defun string-stream-read-n-bytes (stream buffer start requested eof-errorp)
1070    (declare (type string-input-stream stream)    (declare (type string-input-stream stream)
1071             (type index start requested))             (type index start requested))
1072    (let ((string (string-input-stream-string stream))    (let* ((string (string-input-stream-string stream))
1073          (index (string-input-stream-current stream))           (index (string-input-stream-current stream))
1074          (end (string-input-stream-end stream)))           (available (- (string-input-stream-end stream) index))
1075      (declare (simple-string string) (fixnum index end))           (copy (min available requested)))
1076      (cond ((>= (+ index requested) end)      (declare (simple-string string)
1077             (eof-or-lose stream eof-errorp nil))               (type index index available copy))
1078            (t      (when (plusp copy)
1079             (setf (string-input-stream-current stream) (+ index requested))        (setf (string-input-stream-current stream)
1080             (system:without-gcing              (truly-the index (+ index copy)))
1081              (system-area-copy (vector-sap string)        (system:without-gcing
1082                                (* index vm:byte-bits)         (system-area-copy (vector-sap string)
1083                                (if (typep buffer 'system-area-pointer)                           (* index vm:byte-bits)
1084                                    buffer                           (if (typep buffer 'system-area-pointer)
1085                                    (vector-sap buffer))                               buffer
1086                                (* start vm:byte-bits)                               (vector-sap buffer))
1087                                (* requested vm:byte-bits)))                           (* start vm:byte-bits)
1088             requested))))                           (* copy vm:byte-bits))))
1089        (if (and (> requested copy) eof-errorp)
1090            (error 'end-of-file :stream stream)
1091            copy)))
1092    
1093  (defun string-in-misc (stream operation &optional arg1 arg2)  (defun string-in-misc (stream operation &optional arg1 arg2)
1094    (declare (ignore arg2))    (declare (ignore arg2))
# Line 919  Line 1102 
1102      (:listen (or (/= (the fixnum (string-input-stream-current stream))      (:listen (or (/= (the fixnum (string-input-stream-current stream))
1103                       (the fixnum (string-input-stream-end stream)))                       (the fixnum (string-input-stream-end stream)))
1104                   :eof))                   :eof))
1105      (:element-type 'string-char)))      (:element-type 'base-char)))
1106    
1107  (defun make-string-input-stream (string &optional  (defun make-string-input-stream (string &optional
1108                                          (start 0) (end (length string)))                                          (start 0) (end (length string)))
# Line 934  Line 1117 
1117  ;;;; String Output Streams:  ;;;; String Output Streams:
1118    
1119  (defstruct (string-output-stream  (defstruct (string-output-stream
1120              (:include stream              (:include lisp-stream
1121                        (out #'string-ouch)                        (out #'string-ouch)
1122                        (sout #'string-sout)                        (sout #'string-sout)
1123                        (misc #'string-out-misc))                        (misc #'string-out-misc))
# Line 1001  Line 1184 
1184                  (fixnum index count))                  (fixnum index count))
1185         (if (char= (schar string index) #\newline)         (if (char= (schar string index) #\newline)
1186             (return count))))             (return count))))
1187      (:element-type 'string-char)))      (:element-type 'base-char)))
1188    
1189  (defun get-output-stream-string (stream)  (defun get-output-stream-string (stream)
1190    "Returns a string of all the characters sent to a stream made by    "Returns a string of all the characters sent to a stream made by
# Line 1016  Line 1199 
1199  (defun dump-output-stream-string (in-stream out-stream)  (defun dump-output-stream-string (in-stream out-stream)
1200    "Dumps the characters buffer up in the In-Stream to the Out-Stream as    "Dumps the characters buffer up in the In-Stream to the Out-Stream as
1201    Get-Output-Stream-String would return them."    Get-Output-Stream-String would return them."
1202    (write-string (string-output-stream-string in-stream) out-stream    (write-string* (string-output-stream-string in-stream) out-stream
1203                  :start 0 :end (string-output-stream-index in-stream))                   0 (string-output-stream-index in-stream))
1204    (setf (string-output-stream-index in-stream) 0))    (setf (string-output-stream-index in-stream) 0))
1205    
1206  ;;;; Fill-pointer streams:  ;;;; Fill-pointer streams:
# Line 1026  Line 1209 
1209  ;;; the CLM, but they are required for the implementation of With-Output-To-String.  ;;; the CLM, but they are required for the implementation of With-Output-To-String.
1210    
1211  (defstruct (fill-pointer-output-stream  (defstruct (fill-pointer-output-stream
1212              (:include stream              (:include lisp-stream
1213                        (out #'fill-pointer-ouch)                        (out #'fill-pointer-ouch)
1214                        (sout #'fill-pointer-sout)                        (sout #'fill-pointer-sout)
1215                        (misc #'fill-pointer-misc))                        (misc #'fill-pointer-misc))
# Line 1103  Line 1286 
1286             (if found             (if found
1287                 (- end (the fixnum found))                 (- end (the fixnum found))
1288                 current)))))                 current)))))
1289       (:element-type 'string-char)))       (:element-type 'base-char)))
1290    
1291  ;;;; Indenting streams:  ;;;; Indenting streams:
1292    
1293  (defstruct (indenting-stream (:include stream  (defstruct (indenting-stream (:include lisp-stream
1294                                         (out #'indenting-out)                                         (out #'indenting-out)
1295                                         (sout #'indenting-sout)                                         (sout #'indenting-sout)
1296                                         (misc #'indenting-misc))                                         (misc #'indenting-misc))
# Line 1132  Line 1315 
1315    `(do ((i 0 (+ i 60))    `(do ((i 0 (+ i 60))
1316          (indentation (indenting-stream-indentation ,stream)))          (indentation (indenting-stream-indentation ,stream)))
1317         ((>= i indentation))         ((>= i indentation))
1318       (funcall (stream-sout ,sub-stream) ,sub-stream       (write-string*
1319                "                                                            "        "                                                            "
1320                0 (min 60 (- indentation i)))))        ,sub-stream 0 (min 60 (- indentation i)))))
1321    
1322  ;;; Indenting-Out writes a character to an indenting stream.  ;;; Indenting-Out writes a character to an indenting stream.
1323    
1324  (defun indenting-out (stream char)  (defun indenting-out (stream char)
1325    (let ((sub-stream (indenting-stream-stream stream)))    (let ((sub-stream (indenting-stream-stream stream)))
1326      (funcall (stream-out sub-stream) sub-stream char)      (write-char char sub-stream)
1327      (if (char= char #\newline)      (if (char= char #\newline)
1328          (indenting-indent stream sub-stream))))          (indenting-indent stream sub-stream))))
1329    
# Line 1153  Line 1336 
1336        ((= i end))        ((= i end))
1337      (let ((newline (position #\newline string :start i :end end)))      (let ((newline (position #\newline string :start i :end end)))
1338        (cond (newline        (cond (newline
1339               (funcall (stream-sout sub-stream) sub-stream string i (1+ newline))               (write-string* string sub-stream i (1+ newline))
1340               (indenting-indent stream sub-stream)               (indenting-indent stream sub-stream)
1341               (setq i (+ newline 1)))               (setq i (+ newline 1)))
1342              (t              (t
1343               (funcall (stream-sout sub-stream) sub-stream string i end)               (write-string* string sub-stream i end)
1344               (setq i end))))))               (setq i end))))))
1345    
1346  ;;; Indenting-Misc just treats just the :Line-Length message differently.  ;;; Indenting-Misc just treats just the :Line-Length message differently.
# Line 1165  Line 1348 
1348  ;;; the stream's indentation.  ;;; the stream's indentation.
1349    
1350  (defun indenting-misc (stream operation &optional arg1 arg2)  (defun indenting-misc (stream operation &optional arg1 arg2)
1351    (let* ((sub-stream (indenting-stream-stream stream))    (let ((sub-stream (indenting-stream-stream stream)))
1352           (method (stream-misc sub-stream)))      (if (lisp-stream-p sub-stream)
1353      (case operation          (let ((method (lisp-stream-misc sub-stream)))
1354        (:line-length            (case operation
1355         (let ((line-length (funcall method sub-stream operation)))              (:line-length
1356           (if line-length               (let ((line-length (funcall method sub-stream operation)))
1357               (- line-length (indenting-stream-indentation stream)))))                 (if line-length
1358        (:charpos                     (- line-length (indenting-stream-indentation stream)))))
1359         (let* ((sub-stream (indenting-stream-stream stream))              (:charpos
1360                (charpos (funcall method sub-stream operation)))               (let ((charpos (funcall method sub-stream operation)))
1361           (if charpos                 (if charpos
1362               (- charpos (indenting-stream-indentation stream)))))                     (- charpos (indenting-stream-indentation stream)))))
1363        (t              (t
1364         (funcall method sub-stream operation arg1 arg2)))))               (funcall method sub-stream operation arg1 arg2))))
1365            ;; Fundamental-stream.
1366            (case operation
1367              (:line-length
1368               (let ((line-length (stream-line-length sub-stream)))
1369                 (if line-length
1370                     (- line-length (indenting-stream-indentation stream)))))
1371              (:charpos
1372               (let ((charpos (stream-line-column sub-stream)))
1373                 (if charpos
1374                     (- charpos (indenting-stream-indentation stream)))))
1375              (t
1376               (stream-misc-dispatch sub-stream operation arg1 arg2))))))
1377    
1378    
1379  (proclaim '(maybe-inline read-char unread-char read-byte listen))  (proclaim '(maybe-inline read-char unread-char read-byte listen))
1380    
# Line 1187  Line 1383 
1383  ;;;; Case frobbing streams, used by format ~(...~).  ;;;; Case frobbing streams, used by format ~(...~).
1384    
1385  (defstruct (case-frob-stream  (defstruct (case-frob-stream
1386              (:include stream              (:include lisp-stream
1387                        (:misc #'case-frob-misc))                        (:misc #'case-frob-misc))
1388              (:constructor %make-case-frob-stream (target out sout)))              (:constructor %make-case-frob-stream (target out sout)))
1389    (target (required-argument) :type stream))    (target (required-argument) :type stream))
# Line 1233  Line 1429 
1429      (:close)      (:close)
1430      (t      (t
1431       (let ((target (case-frob-stream-target stream)))       (let ((target (case-frob-stream-target stream)))
1432         (funcall (stream-misc target) target op arg1 arg2)))))         (if (lisp-stream-p target)
1433               (funcall (lisp-stream-misc target) target op arg1 arg2)
1434               (stream-misc-dispatch target op arg1 arg2))))))
1435    
1436  (defun case-frob-upcase-out (stream char)  (defun case-frob-upcase-out (stream char)
1437    (declare (type case-frob-stream stream)    (declare (type case-frob-stream stream)
1438             (type base-char char))             (type base-char char))
1439    (let ((target (case-frob-stream-target stream)))    (let ((target (case-frob-stream-target stream))
1440      (funcall (stream-out target) target (char-upcase char))))          (char (char-upcase char)))
1441        (if (lisp-stream-p target)
1442            (funcall (lisp-stream-out target) target char)
1443            (stream-write-char target char))))
1444    
1445  (defun case-frob-upcase-sout (stream str start end)  (defun case-frob-upcase-sout (stream str start end)
1446    (declare (type case-frob-stream stream)    (declare (type case-frob-stream stream)
# Line 1249  Line 1449 
1449             (type (or index null) end))             (type (or index null) end))
1450    (let* ((target (case-frob-stream-target stream))    (let* ((target (case-frob-stream-target stream))
1451           (len (length str))           (len (length str))
1452           (end (or end len)))           (end (or end len))
1453      (funcall (stream-sout target) target           (string (if (and (zerop start) (= len end))
1454               (if (and (zerop start) (= len end))                       (string-upcase str)
1455                   (string-upcase str)                       (nstring-upcase (subseq str start end))))
1456                   (nstring-upcase (subseq str start end)))           (string-len (- end start)))
1457               0      (if (lisp-stream-p target)
1458               (- end start))))          (funcall (lisp-stream-sout target) target string 0 string-len)
1459            (stream-write-string target string 0 string-len))))
1460    
1461  (defun case-frob-downcase-out (stream char)  (defun case-frob-downcase-out (stream char)
1462    (declare (type case-frob-stream stream)    (declare (type case-frob-stream stream)
1463             (type base-char char))             (type base-char char))
1464    (let ((target (case-frob-stream-target stream)))    (let ((target (case-frob-stream-target stream))
1465      (funcall (stream-out target) target (char-downcase char))))          (char (char-downcase char)))
1466        (if (lisp-stream-p target)
1467            (funcall (lisp-stream-out target) target char)
1468            (stream-write-char target char))))
1469    
1470  (defun case-frob-downcase-sout (stream str start end)  (defun case-frob-downcase-sout (stream str start end)
1471    (declare (type case-frob-stream stream)    (declare (type case-frob-stream stream)
# Line 1270  Line 1474 
1474             (type (or index null) end))             (type (or index null) end))
1475    (let* ((target (case-frob-stream-target stream))    (let* ((target (case-frob-stream-target stream))
1476           (len (length str))           (len (length str))
1477           (end (or end len)))           (end (or end len))
1478      (funcall (stream-sout target) target           (string (if (and (zerop start) (= len end))
1479               (if (and (zerop start) (= len end))                       (string-downcase str)
1480                   (string-downcase str)                       (nstring-downcase (subseq str start end))))
1481                   (nstring-downcase (subseq str start end)))           (string-len (- end start)))
1482               0      (if (lisp-stream-p target)
1483               (- end start))))          (funcall (lisp-stream-sout target) target string 0 string-len)
1484            (stream-write-string target string 0 string-len))))
1485    
1486  (defun case-frob-capitalize-out (stream char)  (defun case-frob-capitalize-out (stream char)
1487    (declare (type case-frob-stream stream)    (declare (type case-frob-stream stream)
1488             (type base-char char))             (type base-char char))
1489    (let ((target (case-frob-stream-target stream)))    (let ((target (case-frob-stream-target stream)))
1490      (cond ((alphanumericp char)      (cond ((alphanumericp char)
1491             (funcall (stream-out target) target (char-upcase char))             (let ((char (char-upcase char)))
1492             (setf (case-frob-stream-out stream)               (if (lisp-stream-p target)
1493                   #'case-frob-capitalize-aux-out)                   (funcall (lisp-stream-out target) target char)
1494                     (stream-write-char target char)))
1495               (setf (case-frob-stream-out stream) #'case-frob-capitalize-aux-out)
1496             (setf (case-frob-stream-sout stream)             (setf (case-frob-stream-sout stream)
1497                   #'case-frob-capitalize-aux-sout))                   #'case-frob-capitalize-aux-sout))
1498            (t            (t
1499             (funcall (stream-out target) target char)))))             (if (lisp-stream-p target)
1500                   (funcall (lisp-stream-out target) target char)
1501                   (stream-write-char target char))))))
1502    
1503  (defun case-frob-capitalize-sout (stream str start end)  (defun case-frob-capitalize-sout (stream str start end)
1504    (declare (type case-frob-stream stream)    (declare (type case-frob-stream stream)
# Line 1314  Line 1523 
1523              #'case-frob-capitalize-aux-out)              #'case-frob-capitalize-aux-out)
1524        (setf (case-frob-stream-sout stream)        (setf (case-frob-stream-sout stream)
1525              #'case-frob-capitalize-aux-sout))              #'case-frob-capitalize-aux-sout))
1526      (funcall (stream-sout target) target str 0 len)))      (if (lisp-stream-p target)
1527            (funcall (lisp-stream-sout target) target str 0 len)
1528            (stream-write-string target str 0 len))))
1529    
1530  (defun case-frob-capitalize-aux-out (stream char)  (defun case-frob-capitalize-aux-out (stream char)
1531    (declare (type case-frob-stream stream)    (declare (type case-frob-stream stream)
1532             (type base-char char))             (type base-char char))
1533    (let ((target (case-frob-stream-target stream)))    (let ((target (case-frob-stream-target stream)))
1534      (cond ((alphanumericp char)      (cond ((alphanumericp char)
1535             (funcall (stream-out target) target (char-downcase char)))             (let ((char (char-downcase char)))
1536                 (if (lisp-stream-p target)
1537                     (funcall (lisp-stream-out target) target char)
1538                     (stream-write-char target char))))
1539            (t            (t
1540             (funcall (stream-out target) target char)             (if (lisp-stream-p target)
1541                   (funcall (lisp-stream-out target) target char)
1542                   (stream-write-char target char))
1543             (setf (case-frob-stream-out stream)             (setf (case-frob-stream-out stream)
1544                   #'case-frob-capitalize-out)                   #'case-frob-capitalize-out)
1545             (setf (case-frob-stream-sout stream)             (setf (case-frob-stream-sout stream)
# Line 1352  Line 1568 
1568              #'case-frob-capitalize-out)              #'case-frob-capitalize-out)
1569        (setf (case-frob-stream-sout stream)        (setf (case-frob-stream-sout stream)
1570              #'case-frob-capitalize-sout))              #'case-frob-capitalize-sout))
1571      (funcall (stream-sout target) target str 0 len)))      (if (lisp-stream-p target)
1572            (funcall (lisp-stream-sout target) target str 0 len)
1573            (stream-write-string target str 0 len))))
1574    
1575  (defun case-frob-capitalize-first-out (stream char)  (defun case-frob-capitalize-first-out (stream char)
1576    (declare (type case-frob-stream stream)    (declare (type case-frob-stream stream)
1577             (type base-char char))             (type base-char char))
1578    (let ((target (case-frob-stream-target stream)))    (let ((target (case-frob-stream-target stream)))
1579      (cond ((alphanumericp char)      (cond ((alphanumericp char)
1580             (funcall (stream-out target) target (char-upcase char))             (let ((char (char-upcase char)))
1581                 (if (lisp-stream-p target)
1582                     (funcall (lisp-stream-out target) target char)
1583                     (stream-write-char target char)))
1584             (setf (case-frob-stream-out stream)             (setf (case-frob-stream-out stream)
1585                   #'case-frob-downcase-out)                   #'case-frob-downcase-out)
1586             (setf (case-frob-stream-sout stream)             (setf (case-frob-stream-sout stream)
1587                   #'case-frob-downcase-sout))                   #'case-frob-downcase-sout))
1588            (t            (t
1589             (funcall (stream-out target) target char)))))             (if (lisp-stream-p target)
1590                   (funcall (lisp-stream-out target) target char)
1591                   (stream-write-char target char))))))
1592    
1593  (defun case-frob-capitalize-first-sout (stream str start end)  (defun case-frob-capitalize-first-sout (stream str start end)
1594    (declare (type case-frob-stream stream)    (declare (type case-frob-stream stream)
# Line 1387  Line 1610 
1610            (setf (case-frob-stream-sout stream)            (setf (case-frob-stream-sout stream)
1611                  #'case-frob-downcase-sout)                  #'case-frob-downcase-sout)
1612            (return))))            (return))))
1613      (funcall (stream-sout target) target str 0 len)))      (if (lisp-stream-p target)
1614            (funcall (lisp-stream-sout target) target str 0 len)
1615            (stream-write-string target str 0 len))))
1616    
1617    
1618  ;;;; Public interface from "EXTENSIONS" package.  ;;;; Public interface from "EXTENSIONS" package.
# Line 1405  Line 1630 
1630    
1631  ;;; GET-STREAM-COMMAND -- Public.  ;;; GET-STREAM-COMMAND -- Public.
1632  ;;;  ;;;
1633  ;;; We can't simply call the stream's misc method because because nil is an  ;;; We can't simply call the stream's misc method because nil is an
1634  ;;; ambiguous return value: does it mean text arrived, or does it mean the  ;;; ambiguous return value: does it mean text arrived, or does it mean the
1635  ;;; stream's misc method had no :get-command implementation.  We can't return  ;;; stream's misc method had no :get-command implementation.  We can't return
1636  ;;; nil until there is text input.  We don't need to loop because any stream  ;;; nil until there is text input.  We don't need to loop because any stream
# Line 1416  Line 1641 
1641    "This takes a stream and waits for text or a command to appear on it.  If    "This takes a stream and waits for text or a command to appear on it.  If
1642     text appears before a command, this returns nil, and otherwise it returns     text appears before a command, this returns nil, and otherwise it returns
1643     a command."     a command."
1644    (let ((cmdp (funcall (lisp::stream-misc stream) stream :get-command)))    (let ((cmdp (funcall (lisp-stream-misc stream) stream :get-command)))
1645      (cond (cmdp)      (cond (cmdp)
1646            ((listen stream)            ((listen stream)
1647             nil)             nil)
1648            (t            (t
1649             ;; This waits for input and returns nil when it arrives.             ;; This waits for input and returns nil when it arrives.
1650             (unread-char (read-char stream) stream)))))             (unread-char (read-char stream) stream)))))
1651    
1652    
1653    ;;; READ-SEQUENCE -- Public
1654    ;;;
1655    (defun read-sequence (seq stream &key (start 0) (end nil))
1656      "Destructively modify SEQ by reading elements from STREAM.
1657      SEQ is bounded by START and END. SEQ is destructively modified by
1658      copying successive elements into it from STREAM. If the end of file
1659      for STREAM is reached before copying all elements of the subsequence,
1660      then the extra elements near the end of sequence are not updated, and
1661      the index of the next element is returned."
1662      (declare (type sequence seq)
1663               (type stream stream)
1664               (type index start)
1665               (type sequence-end end)
1666               (values index))
1667      (let ((end (or end (length seq))))
1668        (declare (type index end))
1669        (etypecase seq
1670          (list
1671           (let ((read-function
1672                  (if (subtypep (stream-element-type stream) 'character)
1673                      #'read-char
1674                      #'read-byte)))
1675             (do ((rem (nthcdr start seq) (rest rem))
1676                  (i start (1+ i)))
1677                 ((or (endp rem) (>= i end)) i)
1678               (declare (type list rem)
1679                        (type index i))
1680               (let ((el (funcall read-function stream nil :eof)))
1681                 (when (eq el :eof)
1682                   (return i))
1683                 (setf (first rem) el)))))
1684          (vector
1685           (with-array-data ((data seq) (offset-start start) (offset-end end))
1686             (typecase data
1687               ((or (simple-array (unsigned-byte 8) (*))
1688                    (simple-array (signed-byte 8) (*))
1689                    simple-string)
1690                (let* ((numbytes (- end start))
1691                       (bytes-read (system:read-n-bytes
1692                                    stream data offset-start numbytes nil)))
1693                  (if (< bytes-read numbytes)
1694                      (+ start bytes-read)
1695                      end)))
1696               (t
1697                (let ((read-function
1698                       (if (subtypep (stream-element-type stream) 'character)
1699                           #'read-char
1700                           #'read-byte)))
1701                  (do ((i offset-start (1+ i)))
1702                      ((>= i offset-end) end)
1703                    (declare (type index i))
1704                    (let ((el (funcall read-function stream nil :eof)))
1705                      (when (eq el :eof)
1706                        (return (+ start (- i offset-start))))
1707                      (setf (aref data i) el)))))))))))
1708    
1709    ;;; WRITE-SEQUENCE -- Public
1710    ;;;
1711    (defun write-sequence (seq stream &key (start 0) (end nil))
1712      "Write the elements of SEQ bounded by START and END to STREAM."
1713      (declare (type sequence seq)
1714               (type stream stream)
1715               (type index start)
1716               (type sequence-end end)
1717               (values sequence))
1718      (let ((end (or end (length seq))))
1719        (declare (type index start end))
1720        (etypecase seq
1721          (list
1722           (let ((write-function
1723                  (if (subtypep (stream-element-type stream) 'character)
1724                      #'write-char
1725                      #'write-byte)))
1726             (do ((rem (nthcdr start seq) (rest rem))
1727                  (i start (1+ i)))
1728                 ((or (endp rem) (>= i end)) seq)
1729               (declare (type list rem)
1730                        (type index i))
1731               (funcall write-function (first rem) stream))))
1732          (string
1733           (write-string* seq stream start end))
1734          (vector
1735           (let ((write-function
1736                  (if (subtypep (stream-element-type stream) 'character)
1737                      #'write-char
1738                      #'write-byte)))
1739             (do ((i start (1+ i)))
1740                 ((>= i end) seq)
1741               (declare (type index i))
1742               (funcall write-function (aref seq i) stream)))))))

Legend:
Removed from v.1.25  
changed lines
  Added in v.1.25.2.5

  ViewVC Help
Powered by ViewVC 1.1.5