/[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.58.2.1 by gerd, Fri Mar 21 00:03:14 2003 UTC revision 1.102 by rtoy, Wed Jun 29 00:55:04 2011 UTC
# Line 12  Line 12 
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.  ;;; 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.  ;;; This file contains the OS-independent stream functions.
18  ;;;  ;;;
19  (in-package "LISP")  (in-package "LISP")
20    
21    (intl:textdomain "cmucl")
22    
23  (export '(broadcast-stream make-broadcast-stream broadcast-stream-streams  (export '(broadcast-stream make-broadcast-stream broadcast-stream-streams
24            synonym-stream make-synonym-stream synonym-stream-symbol            synonym-stream make-synonym-stream synonym-stream-symbol
25            concatenated-stream make-concatenated-stream            concatenated-stream make-concatenated-stream
# Line 65  Line 68 
68    (error 'simple-type-error    (error 'simple-type-error
69           :datum stream           :datum stream
70           :expected-type '(satisfies input-stream-p)           :expected-type '(satisfies input-stream-p)
71           :format-control "~S is not an input stream."           :format-control (intl:gettext "~S is not an input stream.")
72           :format-arguments (list stream)))           :format-arguments (list stream)))
73  (defun ill-out-any (stream &rest ignore)  (defun ill-out-any (stream &rest ignore)
74    (declare (ignore ignore))    (declare (ignore ignore))
75    (error 'simple-type-error    (error 'simple-type-error
76           :datum stream           :datum stream
77           :expected-type '(satisfies output-stream-p)           :expected-type '(satisfies output-stream-p)
78           :format-control "~S is not an output stream."           :format-control (intl:gettext "~S is not an output stream.")
79           :format-arguments (list stream)))           :format-arguments (list stream)))
80  (defun ill-in (stream &rest ignore)  (defun ill-in (stream &rest ignore)
81    (declare (ignore ignore))    (declare (ignore ignore))
82    (error 'simple-type-error    (error 'simple-type-error
83           :datum stream           :datum stream
84           :expected-type '(satisfies input-stream-p)           :expected-type '(satisfies input-stream-p)
85           :format-control "~S is not a character input stream."           :format-control (intl:gettext "~S is not a character input stream.")
86           :format-arguments (list stream)))           :format-arguments (list stream)))
87  (defun ill-out (stream &rest ignore)  (defun ill-out (stream &rest ignore)
88    (declare (ignore ignore))    (declare (ignore ignore))
89    (error 'simple-type-error    (error 'simple-type-error
90           :datum stream           :datum stream
91           :expected-type '(satisfies output-stream-p)           :expected-type '(satisfies output-stream-p)
92           :format-control "~S is not a character output stream."           :format-control (intl:gettext "~S is not a character output stream.")
93           :format-arguments (list stream)))           :format-arguments (list stream)))
94  (defun ill-bin (stream &rest ignore)  (defun ill-bin (stream &rest ignore)
95    (declare (ignore ignore))    (declare (ignore ignore))
96    (error 'simple-type-error    (error 'simple-type-error
97           :datum stream           :datum stream
98           :expected-type '(satisfies input-stream-p)           :expected-type '(satisfies input-stream-p)
99           :format-control "~S is not a binary input stream."           :format-control (intl:gettext "~S is not a binary input stream.")
100           :format-arguments (list stream)))           :format-arguments (list stream)))
101  (defun ill-n-bin (stream &rest ignore)  (defun ill-n-bin (stream &rest ignore)
102    (declare (ignore ignore))    (declare (ignore ignore))
103    (error 'simple-type-error    (error 'simple-type-error
104           :datum stream           :datum stream
105           :expected-type '(satisfies input-stream-p)           :expected-type '(satisfies input-stream-p)
106           :format-control "~S is not a binary input stream or does not support multi-byte read operations."           :format-control (intl:gettext "~S is not a binary input stream ~
107                              or does not support multi-byte read operations.")
108           :format-arguments (list stream)))           :format-arguments (list stream)))
109  (defun ill-bout (stream &rest ignore)  (defun ill-bout (stream &rest ignore)
110    (declare (ignore ignore))    (declare (ignore ignore))
111    (error 'simple-type-error    (error 'simple-type-error
112           :datum stream           :datum stream
113           :expected-type '(satisfies output-stream-p)           :expected-type '(satisfies output-stream-p)
114           :format-control "~S is not a binary output stream."           :format-control (intl:gettext "~S is not a binary output stream.")
115           :format-arguments (list stream)))           :format-arguments (list stream)))
116  (defun closed-flame (stream &rest ignore)  (defun closed-flame (stream &rest ignore)
117    (declare (ignore ignore))    (declare (ignore ignore))
118    (error "~S is closed." stream))    (error (intl:gettext "~S is closed.") stream))
119  (defun do-nothing (&rest ignore)  (defun do-nothing (&rest ignore)
120    (declare (ignore ignore)))    (declare (ignore ignore)))
121    (defun no-gray-streams (stream)
122      (error 'simple-type-error
123             :datum stream
124             :expected-type 'stream
125             :format-control (intl:gettext "~S is an unsupported Gray stream.")
126             :format-arguments (list stream)))
127    
128  (defun %print-stream (structure stream d)  (defun %print-stream (structure stream d)
129    (declare (ignore d structure))    (declare (ignore d structure))
# Line 140  Line 150 
150  ;;; are handled by just one function, the Misc method.  This function  ;;; are handled by just one function, the Misc method.  This function
151  ;;; is passed a keyword which indicates the operation to perform.  ;;; is passed a keyword which indicates the operation to perform.
152  ;;; The following keywords are used:  ;;; The following keywords are used:
153    ;;;
154  ;;;  :listen            - Return the following values:  ;;;  :listen            - Return the following values:
155  ;;;                          t if any input waiting.  ;;;                          t if any input waiting.
156  ;;;                          :eof if at eof.  ;;;                          :eof if at eof.
# Line 153  Line 164 
164  ;;;  :finish-output,  ;;;  :finish-output,
165  ;;;  :force-output      - Cause output to happen  ;;;  :force-output      - Cause output to happen
166  ;;;  :clear-output      - Clear any undone output  ;;;  :clear-output      - Clear any undone output
167  ;;;  :element-type      - Return the type of element the stream deals wit<h.  ;;;  :element-type      - Return the type of element the stream deals with.
168  ;;;  :line-length       - Return the length of a line of output.  ;;;  :line-length       - Return the length of a line of output.
169  ;;;  :charpos           - Return current output position on the line.  ;;;  :charpos           - Return current output position on the line.
170  ;;;  :file-length       - Return the file length of a file stream.  ;;;  :file-length       - Return the file length of a file stream.
# Line 197  Line 208 
208    
209  (defun input-stream-p (stream)  (defun input-stream-p (stream)
210    "Returns non-nil if the given Stream can perform input operations."    "Returns non-nil if the given Stream can perform input operations."
211    (and (lisp-stream-p stream)    (declare (type stream stream))
212         (not (eq (lisp-stream-in stream) #'closed-flame))    ;; Note: Gray streams redefines this function; any changes made here need
213         (or (not (eq (lisp-stream-in stream) #'ill-in))    ;; to be duplicated in .../pcl/gray-streams.lisp
214             (not (eq (lisp-stream-bin stream) #'ill-bin))    (stream-dispatch stream
215             (not (eq (lisp-stream-n-bin stream) #'ill-n-bin)))))      ;; simple-stream
216        (stream::%input-stream-p stream)
217        ;; lisp-stream
218        (let ((stream (if (synonym-stream-p stream)
219                          (symbol-value (synonym-stream-symbol stream))
220                          stream)))
221          (and (not (eq (lisp-stream-in stream) #'closed-flame))
222               (or (not (eq (lisp-stream-in stream) #'ill-in))
223                   (not (eq (lisp-stream-bin stream) #'ill-bin))
224                   (not (eq (lisp-stream-n-bin stream) #'ill-n-bin)))))))
225    
226  (defun output-stream-p (stream)  (defun output-stream-p (stream)
227    "Returns non-nil if the given Stream can perform output operations."    "Returns non-nil if the given Stream can perform output operations."
228    (and (lisp-stream-p stream)    (declare (type stream stream))
229         (not (eq (lisp-stream-in stream) #'closed-flame))    ;; Note: Gray streams redefines this function; any changes made here need
230         (or (not (eq (lisp-stream-out stream) #'ill-out))    ;; to be duplicated in .../pcl/gray-streams.lisp
231             (not (eq (lisp-stream-bout stream) #'ill-bout)))))    (stream-dispatch stream
232        ;; simple-stream
233        (stream::%output-stream-p stream)
234        ;; lisp-stream
235        (let ((stream (if (synonym-stream-p stream)
236                          (symbol-value (synonym-stream-symbol stream))
237                          stream)))
238          (and (not (eq (lisp-stream-in stream) #'closed-flame))
239               (or (not (eq (lisp-stream-out stream) #'ill-out))
240                   (not (eq (lisp-stream-bout stream) #'ill-bout)))))))
241    
242  (defun open-stream-p (stream)  (defun open-stream-p (stream)
243    "Return true if Stream is not closed."    "Return true if Stream is not closed."
244    (declare (type stream stream))    (declare (type stream stream))
245    (not (eq (lisp-stream-in stream) #'closed-flame)))    ;; Note: Gray streams redefines this function; any changes made here need
246      ;; to be duplicated in .../pcl/gray-streams.lisp
247      (stream-dispatch stream
248        ;; simple-stream
249        (stream::%open-stream-p stream)
250        ;; lisp-stream
251        (not (eq (lisp-stream-in stream) #'closed-flame))))
252    
253  (defun stream-element-type (stream)  (defun stream-element-type (stream)
254    "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."
255    (declare (type stream stream))    (declare (type stream stream))
256    (funcall (lisp-stream-misc stream) stream :element-type))    ;; Note: Gray streams redefines this function; any changes made here need
257      ;; to be duplicated in .../pcl/gray-streams.lisp
258      (stream-dispatch stream
259        ;; simple-stream
260        '(unsigned-byte 8)
261        ;; lisp-stream
262        (funcall (lisp-stream-misc stream) stream :element-type)))
263    
264  (defun interactive-stream-p (stream)  (defun interactive-stream-p (stream)
265    "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."
266    (declare (type stream stream))    (declare (type stream stream))
267    (funcall (lisp-stream-misc stream) stream :interactive-p))    (stream-dispatch stream
268        ;; simple-stream
269        (stream::%interactive-stream-p stream)
270        ;; lisp-stream
271        (funcall (lisp-stream-misc stream) stream :interactive-p)))
272    
273  (defun open-stream-p (stream)  (defun (setf interactive-stream-p) (flag stream)
   "Return true if and only if STREAM has not been closed."  
274    (declare (type stream stream))    (declare (type stream stream))
275    (not (eq (lisp-stream-in stream) #'closed-flame)))    (stream-dispatch stream
276        ;; simple-stream
277        (if flag
278            (stream::%interactive-stream-y stream)
279            (stream::%interactive-stream-n stream))
280        ;; lisp-stream
281        (error 'simple-type-error
282               :datum stream
283               :expected-type 'stream:simple-stream
284               :format-control (intl:gettext "Can't set interactive flag on ~S.")
285               :format-arguments (list stream))))
286    
287    (defun stream-external-format (stream)
288      "Returns the external format used by the given Stream."
289      (declare (type stream stream))
290      (stream-dispatch stream
291        ;; simple-stream
292        (stream::%stream-external-format stream)
293        ;; lisp-stream
294        (typecase stream
295          #+unicode
296          (fd-stream (fd-stream-external-format stream))
297          (synonym-stream (stream-external-format
298                           (symbol-value (synonym-stream-symbol stream))))
299          (t :default))
300        ;; fundamental-stream
301        :default))
302    
303    ;; This is only used while building; it's reimplemented in
304    ;; fd-stream-extfmt.lisp
305    #+unicode
306    (defun %set-fd-stream-external-format (stream extfmt &optional (updatep t))
307      extfmt)
308    
309    
310    ;; This is only used while building; it's reimplemented in
311    ;; fd-stream-extfmt.lisp
312    (defun (setf stream-external-format) (extfmt stream)
313      (declare (ignore stream))
314      extfmt)
315    
316  (defun close (stream &key abort)  (defun close (stream &key abort)
317    "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
318    may still be made.  If :Abort is non-nil, an attempt is made to clean    may still be made.  If :Abort is non-nil, an attempt is made to clean
319    up the side effects of having created the stream."    up the side effects of having created the stream."
320    (declare (type stream stream))    (declare (type stream stream))
321    (when (open-stream-p stream)    ;; Note: Gray streams redefines this function; any changes made here need
322      (funcall (lisp-stream-misc stream) stream :close abort))    ;; to be duplicated in .../pcl/gray-streams.lisp
323      (stream-dispatch stream
324        ;; simple-stream
325        (stream:device-close stream abort)
326        ;; lisp-stream
327        (when (open-stream-p stream)
328          (funcall (lisp-stream-misc stream) stream :close abort)))
329    t)    t)
330    
331  (defun set-closed-flame (stream)  (defun set-closed-flame (stream)
332      (declare (type lisp-stream stream))
333    (setf (lisp-stream-in stream) #'closed-flame)    (setf (lisp-stream-in stream) #'closed-flame)
334    (setf (lisp-stream-bin stream) #'closed-flame)    (setf (lisp-stream-bin stream) #'closed-flame)
335    (setf (lisp-stream-n-bin stream) #'closed-flame)    (setf (lisp-stream-n-bin stream) #'closed-flame)
# Line 262  Line 352 
352     this becomes the new file position.  The second argument may also     this becomes the new file position.  The second argument may also
353     be :start or :end for the start and end of the file, respectively."     be :start or :end for the start and end of the file, respectively."
354    (declare (type stream stream)    (declare (type stream stream)
355             (type (or (integer 0) (member nil :start :end)) position))             (type (or (integer 0 *) (member nil :start :end)) position))
356    (cond    (stream-dispatch stream
357     (position      ;; simple-stream
358      (setf (lisp-stream-in-index stream) in-buffer-length)      (stream::%file-position stream position)
359      (funcall (lisp-stream-misc stream) stream :file-position position))      ;; lisp-stream
360     (t      (cond
361      (let ((res (funcall (lisp-stream-misc stream) stream :file-position nil)))        (position
362        (when res (- res (- in-buffer-length (lisp-stream-in-index stream))))))))         (setf (lisp-stream-in-index stream) in-buffer-length)
363           (funcall (lisp-stream-misc stream) stream :file-position position))
364          (t
365           (let ((res (funcall (lisp-stream-misc stream) stream
366                               :file-position nil)))
367             ;; For Unicode, the LISP-STREAM-MISC function handles
368             ;; everything, so we can just return the result.
369             #-unicode
370             (when res
371               (- res (- in-buffer-length (lisp-stream-in-index stream))))
372             #+unicode
373             res)))))
374    
375    
376  ;;; File-Length  --  Public  ;;; File-Length  --  Public
# Line 278  Line 379 
379  ;;;  ;;;
380  (defun file-length (stream)  (defun file-length (stream)
381    "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."
382    (declare (stream stream))    (stream-dispatch stream
383    (funcall (lisp-stream-misc stream) stream :file-length))      ;; simple-stream
384        (stream::%file-length stream)
385        ;; lisp-stream
386        (funcall (lisp-stream-misc stream) stream :file-length)))
387    
388    
389  ;;; Input functions:  ;;; Input functions:
# Line 288  Line 392 
392                              recursive-p)                              recursive-p)
393    "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
394    newline character."    newline character."
   (declare (ignore recursive-p))  
395    (let ((stream (in-synonym-of stream)))    (let ((stream (in-synonym-of stream)))
396      (if (lisp-stream-p stream)      (stream-dispatch stream
397          (prepare-for-fast-read-char stream        ;; simple-stream
398            (let ((res (make-string 80))        (stream::%read-line stream eof-errorp eof-value recursive-p)
399                  (len 80)        ;; lisp-stream
400                  (index 0))        (prepare-for-fast-read-char stream
401              (loop          (let ((res (make-string 80))
402               (let ((ch (fast-read-char nil nil)))                (len 80)
403                 (cond (ch                (index 0))
404                        (when (char= ch #\newline)            (loop
405                          (done-with-fast-read-char)              (let ((ch (fast-read-char nil nil)))
406                          (return (values (shrink-vector res index) nil)))                (cond (ch
407                        (when (= index len)                       (when (char= ch #\newline)
408                          (setq len (* len 2))                         (done-with-fast-read-char)
409                          (let ((new (make-string len)))                         (return (values (shrink-vector res index) nil)))
410                            (replace new res)                       (when (= index len)
411                            (setq res new)))                         (setq len (* len 2))
412                        (setf (schar res index) ch)                         (let ((new (make-string len)))
413                        (incf index))                           (replace new res)
414                       ((zerop index)                           (setq res new)))
415                        (done-with-fast-read-char)                       (setf (schar res index) ch)
416                        (return (values (eof-or-lose stream eof-errorp eof-value)                       (incf index))
417                                        t)))                      ((zerop index)
418                       ;; since fast-read-char hit already the eof char, we                       (done-with-fast-read-char)
419                       ;; shouldn't do another read-char                       (return (values (eof-or-lose stream eof-errorp eof-value)
420                       (t                                       t)))
421                        (done-with-fast-read-char)                      ;; since fast-read-char hit already the eof char, we
422                        (return (values (shrink-vector res index) t))))))))                      ;; shouldn't do another read-char
423          ;; Fundamental-stream.                      (t
424          (multiple-value-bind (string eof)                       (done-with-fast-read-char)
425              (stream-read-line stream)                       (return (values (shrink-vector res index) t))))))))
426            (if (and eof (zerop (length string)))        ;; fundamental-stream
427                (values (eof-or-lose stream eof-errorp eof-value) t)        (multiple-value-bind (string eof)
428                (values string eof))))))            (stream-read-line stream)
429            (if (and eof (zerop (length string)))
430                (values (eof-or-lose stream eof-errorp eof-value) t)
431                (values string eof))))))
432    
433  ;;; We proclaim them inline here, then proclaim them notinline at EOF,  ;;; We proclaim them inline here, then proclaim them notinline at EOF,
434  ;;; so, except in this file, they are not inline by default, but they can be.  ;;; so, except in this file, they are not inline by default, but they can be.
# Line 331  Line 437 
437  (defun read-char (&optional (stream *standard-input*) (eof-errorp t) eof-value  (defun read-char (&optional (stream *standard-input*) (eof-errorp t) eof-value
438                              recursive-p)                              recursive-p)
439    "Inputs a character from Stream and returns it."    "Inputs a character from Stream and returns it."
   (declare (ignore recursive-p))  
440    (let ((stream (in-synonym-of stream)))    (let ((stream (in-synonym-of stream)))
441      (if (lisp-stream-p stream)      (stream-dispatch stream
442          (prepare-for-fast-read-char stream        ;; simple-stream
443            (prog1        (stream::%read-char stream eof-errorp eof-value recursive-p t)
444                (fast-read-char eof-errorp eof-value)        ;; lisp-stream
445              (done-with-fast-read-char)))        (prepare-for-fast-read-char stream
446          ;; Fundamental-stream.          (prog1
447          (let ((char (stream-read-char stream)))              (fast-read-char eof-errorp eof-value)
448            (if (eq char :eof)            (done-with-fast-read-char)))
449                (eof-or-lose stream eof-errorp eof-value)        ;; fundamental-stream
450                char)))))        (let ((char (stream-read-char stream)))
451            (if (eq char :eof)
452                (eof-or-lose stream eof-errorp eof-value)
453                char)))))
454    
455  (defun unread-char (character &optional (stream *standard-input*))  (defun unread-char (character &optional (stream *standard-input*))
456    "Puts the Character back on the front of the input Stream."    "Puts the Character back on the front of the input Stream."
457    (let ((stream (in-synonym-of stream)))    (let ((stream (in-synonym-of stream)))
458      (if (lisp-stream-p stream)      (stream-dispatch stream
459          (let ((index (1- (lisp-stream-in-index stream)))        ;; simple-stream
460                (buffer (lisp-stream-in-buffer stream)))        (stream::%unread-char stream character)
461            (declare (fixnum index))        ;; lisp-stream
462            (when (minusp index) (error "Nothing to unread."))        #-unicode
463            (cond (buffer        (let ((index (1- (lisp-stream-in-index stream)))
464                   (setf (aref buffer index) (char-code character))              (buffer (lisp-stream-in-buffer stream)))
465                   (setf (lisp-stream-in-index stream) index))          (declare (fixnum index))
466                  (t          (when (minusp index) (error (intl:gettext "Nothing to unread.")))
467                   (funcall (lisp-stream-misc stream) stream          (cond (buffer
468                            :unread character))))                 (setf (aref buffer index) (char-code character))
469          ;; Fundamental-stream                 (setf (lisp-stream-in-index stream) index))
470          (stream-unread-char stream character)))                (t
471                   (funcall (lisp-stream-misc stream) stream
472                            :unread character))))
473          #+unicode
474          (let ((sbuf (lisp-stream-string-buffer stream))
475                (ibuf (lisp-stream-in-buffer stream)))
476            (cond (sbuf
477                   (let ((index (1- (lisp-stream-string-index stream))))
478                     (when (minusp index)
479                       (error (intl:gettext "Nothing to unread.")))
480                     (setf (aref sbuf index) character)
481                     (setf (lisp-stream-string-index stream) index)))
482                  (ibuf
483                   (let ((index (1- (lisp-stream-in-index stream))))
484                     (when (minusp index)
485                       (error (intl:gettext "Nothing to unread.")))
486                     ;; This only works for iso8859-1!
487                     (setf (aref ibuf index) (char-code character))
488                     (setf (lisp-stream-in-index stream) index)))
489                  (t
490                   (funcall (lisp-stream-misc stream) stream
491                            :unread character))))
492          ;; fundamental-stream
493          (stream-unread-char stream character)))
494    nil)    nil)
495    
496  ;;; In the interest of ``once and only once'' this macro contains the  ;;; In the interest of ``once and only once'' this macro contains the
# Line 372  Line 503 
503  ;;; EOF-VALUE - the eof-value argument to peek-char  ;;; EOF-VALUE - the eof-value argument to peek-char
504  ;;; CHAR-VAR - the variable which will be used to store the current character  ;;; CHAR-VAR - the variable which will be used to store the current character
505  ;;; READ-FORM - the form which will be used to read a character  ;;; READ-FORM - the form which will be used to read a character
506    ;;; READ-EOF - the result returned from READ-FORM when eof is reached.
507  ;;; UNREAD-FORM - ditto for unread-char  ;;; UNREAD-FORM - ditto for unread-char
508  ;;; SKIPPED-CHAR-FORM - the form to execute when skipping a character  ;;; SKIPPED-CHAR-FORM - the form to execute when skipping a character
509  ;;; EOF-DETECTED-FORM - the form to execute when EOF has been detected  ;;; EOF-DETECTED-FORM - the form to execute when EOF has been detected
510  ;;;                     (this will default to CHAR-VAR)  ;;;                     (this will default to CHAR-VAR)
511  (defmacro generalized-peeking-mechanism (peek-type eof-value char-var read-form unread-form  (defmacro generalized-peeking-mechanism (peek-type eof-value char-var
512                                                     &optional (skipped-char-form nil)                                           read-form read-eof unread-form
513                                                     (eof-detected-form nil))                                           &key (skipped-char-form nil)
514                                                  (eof-detected-form nil))
515    `(let ((,char-var ,read-form))    `(let ((,char-var ,read-form))
516      (cond ((eql ,char-var ,eof-value)      (cond ((eql ,char-var ,read-eof)
517             ,(if eof-detected-form             ,(if eof-detected-form
518                  eof-detected-form                  eof-detected-form
519                  char-var))                  eof-value))
520            ((characterp ,peek-type)            ((characterp ,peek-type)
521             (do ((,char-var ,char-var ,read-form))             (do ((,char-var ,char-var ,read-form))
522                 ((or (eql ,char-var ,eof-value)                 ((or (eql ,char-var ,read-eof)
523                      (char= ,char-var ,peek-type))                      (char= ,char-var ,peek-type))
524                  (cond ((eql ,char-var ,eof-value)                  (cond ((eql ,char-var ,read-eof)
525                         ,(if eof-detected-form                         ,(if eof-detected-form
526                              eof-detected-form                              eof-detected-form
527                              char-var))                              eof-value))
528                        (t ,unread-form                        (t ,unread-form
529                           ,char-var)))                           ,char-var)))
530               ,skipped-char-form))               ,skipped-char-form))
531            ((eql ,peek-type t)            ((eql ,peek-type t)
532             (do ((,char-var ,char-var ,read-form))             (do ((,char-var ,char-var ,read-form))
533                 ((or (eql ,char-var ,eof-value)                 ((or (eql ,char-var ,read-eof)
534                      (not (whitespace-char-p ,char-var)))                      (not (eql (get-cat-entry ,char-var *readtable*) whitespace)))
535                  (cond ((eql ,char-var ,eof-value)                  (cond ((eql ,char-var ,read-eof)
536                         ,(if eof-detected-form                         ,(if eof-detected-form
537                              eof-detected-form                              eof-detected-form
538                              char-var))                              eof-value))
539                        (t ,unread-form                        (t ,unread-form
540                           ,char-var)))                           ,char-var)))
541               ,skipped-char-form))               ,skipped-char-form))
542            ((null ,peek-type)            ((null ,peek-type)
543             ,unread-form             ,unread-form
544               ,(if eof-detected-form
545                    (when (eql char-var read-eof)
546                      eof-detected-form))
547             ,char-var)             ,char-var)
548            (t            (t
549             (error "Impossible case reached in PEEK-CHAR")))))             (error (intl:gettext "Impossible case reached in PEEK-CHAR"))))))
550    
551  (defun peek-char (&optional (peek-type nil) (stream *standard-input*)  (defun peek-char (&optional (peek-type nil) (stream *standard-input*)
552                              (eof-errorp t) eof-value recursive-p)                              (eof-errorp t) eof-value recursive-p)
553    "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."
   (declare (ignore recursive-p))  
554    ;; FIXME: The type of PEEK-TYPE is also declared in a DEFKNOWN, but    ;; FIXME: The type of PEEK-TYPE is also declared in a DEFKNOWN, but
555    ;; the compiler doesn't seem to be smart enough to go from there to    ;; the compiler doesn't seem to be smart enough to go from there to
556    ;; imposing a type check. Figure out why (because PEEK-TYPE is an    ;; imposing a type check. Figure out why (because PEEK-TYPE is an
# Line 425  Line 560 
560      (error 'simple-type-error      (error 'simple-type-error
561             :datum peek-type             :datum peek-type
562             :expected-type '(or character boolean)             :expected-type '(or character boolean)
563             :format-control "~@<bad PEEK-TYPE=~S, ~_expected ~S~:>"             :format-control (intl:gettext "~@<bad PEEK-TYPE=~S, ~_expected ~S~:>")
564             :format-arguments (list peek-type '(or character boolean))))             :format-arguments (list peek-type '(or character boolean))))
565    (let ((stream (in-synonym-of stream)))    (let ((stream (in-synonym-of stream)))
566      (cond ((typep stream 'echo-stream)      (if (typep stream 'echo-stream)
567             (echo-misc stream          (echo-misc stream :peek-char peek-type (list eof-errorp eof-value))
568                        :peek-char          (stream-dispatch stream
569                        peek-type            ;; simple-stream
570                        (list eof-errorp eof-value)))            (stream::%peek-char stream peek-type eof-errorp eof-value
571            ((lisp-stream-p stream)                                recursive-p)
572             (generalized-peeking-mechanism            ;; lisp-stream
573              peek-type eof-value char            (generalized-peeking-mechanism
574              (read-char stream eof-errorp eof-value)             peek-type eof-value char
575              (unread-char char stream)))             (read-char stream eof-errorp :eof)
576            (t             :eof
577             ;; by elimination, must be Gray streams FUNDAMENTAL-STREAM             (unread-char char stream)
578             (generalized-peeking-mechanism             :skipped-char-form nil
579              peek-type :eof char             :eof-detected-form (eof-or-lose stream (or eof-errorp recursive-p) eof-value))
580              (if (null peek-type)            ;; fundamental-stream
581                  (stream-peek-char stream)            (generalized-peeking-mechanism
582                  (stream-read-char stream))             peek-type :eof char
583              (if (null peek-type)             (if (null peek-type)
584                  ()                 (stream-peek-char stream)
585                  (stream-unread-char stream char))                 (stream-read-char stream))
586              ()             :eof
587              (eof-or-lose stream eof-errorp eof-value))))))             (if (null peek-type)
588                   ()
589                   (stream-unread-char stream char))
590               :skipped-char-form ()
591               :eof-detected-form (eof-or-lose stream eof-errorp eof-value))))))
592    
593  (defun listen (&optional (stream *standard-input*))  (defun listen (&optional (stream *standard-input*) (width 1))
594    "Returns T if a character is availible on the given Stream."    "Returns T if a character is available on the given Stream."
595      (declare (type streamlike stream))
596    (let ((stream (in-synonym-of stream)))    (let ((stream (in-synonym-of stream)))
597      (if (lisp-stream-p stream)      (stream-dispatch stream
598          (or (/= (the fixnum (lisp-stream-in-index stream)) in-buffer-length)        ;; simple-stream
599              ;; Test for t explicitly since misc methods return :eof sometimes.        (stream::%listen stream width)
600              (eq (funcall (lisp-stream-misc stream) stream :listen) t))        ;; lisp-stream
601          ;; Fundamental-stream.        (or (/= (the fixnum (lisp-stream-in-index stream)) in-buffer-length)
602          (stream-listen stream))))            ;; Test for t explicitly since misc methods return :eof sometimes.
603              (eq (funcall (lisp-stream-misc stream) stream :listen) t))
604          ;; fundamental-stream
605          (stream-listen stream))))
606    
607  (defun read-char-no-hang (&optional (stream *standard-input*)  (defun read-char-no-hang (&optional (stream *standard-input*)
608                                      (eof-errorp t) eof-value recursive-p)                                      (eof-errorp t) eof-value recursive-p)
609    "Returns the next character from the Stream if one is availible, or nil."    "Returns the next character from the Stream if one is available, or nil."
   (declare (ignore recursive-p))  
610    (let ((stream (in-synonym-of stream)))    (let ((stream (in-synonym-of stream)))
611      (if (lisp-stream-p stream)      (stream-dispatch stream
612          (if (funcall (lisp-stream-misc stream) stream :listen)        ;; simple-stream
613              ;; On t or :eof get READ-CHAR to do the work.        (stream::%read-char stream eof-errorp eof-value recursive-p nil)
614              (read-char stream eof-errorp eof-value)        ;; lisp-stream
615              nil)        (if (funcall (lisp-stream-misc stream) stream :listen)
616          ;; Fundamental-stream.            ;; On t or :eof get READ-CHAR to do the work.
617          (let ((char (stream-read-char-no-hang stream)))            (read-char stream eof-errorp eof-value)
618            (if (eq char :eof)            nil)
619                (eof-or-lose stream eof-errorp eof-value)        ;; fundamental-stream
620                char)))))        (let ((char (stream-read-char-no-hang stream)))
621            (if (eq char :eof)
622                (eof-or-lose stream eof-errorp eof-value)
623                char)))))
624    
625    
626  (defun clear-input (&optional (stream *standard-input*))  (defun clear-input (&optional (stream *standard-input*) buffer-only)
627    "Clears any buffered input associated with the Stream."    "Clears any buffered input associated with the Stream."
628    (declare (type streamlike stream))    (declare (type streamlike stream))
629    (let ((stream (in-synonym-of stream)))    (let ((stream (in-synonym-of stream)))
630      (cond ((lisp-stream-p stream)      (stream-dispatch stream
631             (setf (lisp-stream-in-index stream) in-buffer-length)        ;; simple-stream
632             (funcall (lisp-stream-misc stream) stream :clear-input))        (stream::%clear-input stream buffer-only)
633            (t        ;; lisp-stream
634             (stream-clear-input stream))))        (progn
635            (setf (lisp-stream-in-index stream) in-buffer-length)
636            (funcall (lisp-stream-misc stream) stream :clear-input))
637          ;; fundamental-stream
638          (stream-clear-input stream)))
639    nil)    nil)
640    
641  (defun read-byte (stream &optional (eof-errorp t) eof-value)  (defun read-byte (stream &optional (eof-errorp t) eof-value)
642    "Returns the next byte of the Stream."    "Returns the next byte of the Stream."
643    (declare (type stream stream))    (declare (type stream stream))
644    (let ((stream (in-synonym-of stream)))    (let ((stream (in-synonym-of stream)))
645      (if (lisp-stream-p stream)      (stream-dispatch stream
646          (prepare-for-fast-read-byte stream        ;; simple-stream
647            (prog1        (stream::%read-byte stream eof-errorp eof-value)
648                (fast-read-byte eof-errorp eof-value t)        ;; lisp-stream
649              (done-with-fast-read-byte)))        (prepare-for-fast-read-byte stream
650          ;; Fundamental-stream.          (prog1
651          (let ((char (stream-read-byte stream)))              (fast-read-byte eof-errorp eof-value t)
652            (if (eq char :eof)            (done-with-fast-read-byte)))
653                (eof-or-lose stream eof-errorp eof-value)        ;; fundamental-stream
654                char)))))        (let ((char (stream-read-byte stream)))
655            (if (eq char :eof)
656                (eof-or-lose stream eof-errorp eof-value)
657                char)))))
658    
659  (defun read-n-bytes (stream buffer start numbytes &optional (eof-errorp t))  (defun read-n-bytes (stream buffer start numbytes &optional (eof-errorp t))
660    "Reads Numbytes bytes into the Buffer starting at Start, returning the number    "Reads Numbytes bytes into the Buffer starting at Start, returning the number
661     of bytes read.     of bytes read.
662     -- If EOF-ERROR-P is true, an END-OF-FILE condition is signalled if     -- If EOF-ERROR-P is true, an END-OF-FILE condition is signalled if
663        end-of-file is encountered before Count bytes have been read.        end-of-file is encountered before Count bytes have been read.
664     -- If EOF-ERROR-P is false, READ-N-BYTES reads as much data is currently     -- If EOF-ERROR-P is false, READ-N-BYTES reads as much data as is currently
665        available (up to count bytes.)  On pipes or similar devices, this        available (up to count bytes).  On pipes or similar devices, this
666        function returns as soon as any adata is available, even if the amount        function returns as soon as any data is available, even if the amount
667        read is less than Count and eof has not been hit."        read is less than Count and eof has not been hit."
668    (declare (type lisp-stream stream)    (declare (type lisp-stream stream)
669             (type index numbytes start)             (type index numbytes start)
# Line 523  Line 675 
675      (declare (fixnum index num-buffered))      (declare (fixnum index num-buffered))
676      (cond      (cond
677       ((not in-buffer)       ((not in-buffer)
678        (funcall (lisp-stream-n-bin stream) stream buffer start numbytes eof-errorp))        (funcall (lisp-stream-n-bin stream) stream
679                   buffer start numbytes eof-errorp))
680       ((<= numbytes num-buffered)       ((<= numbytes num-buffered)
681        (%primitive byte-blt in-buffer index buffer start (+ start numbytes))        (%primitive byte-blt in-buffer index buffer start (+ start numbytes))
682        (setf (lisp-stream-in-index stream) (+ index numbytes))        (setf (lisp-stream-in-index stream) (+ index numbytes))
# Line 547  Line 700 
700  ;;;  ;;;
701  ;;;    This function is called by the fast-read-char expansion to refill the  ;;;    This function is called by the fast-read-char expansion to refill the
702  ;;; in-buffer for text streams.  There is definitely an in-buffer, and hence  ;;; in-buffer for text streams.  There is definitely an in-buffer, and hence
703  ;;; myst be an n-bin method.  ;;; must be an n-bin method.
704  ;;;  ;;;
705  (defun fast-read-char-refill (stream eof-errorp eof-value)  (defun fast-read-char-refill (stream eof-errorp eof-value)
706    (let* ((ibuf (lisp-stream-in-buffer stream))    (let* ((ibuf (lisp-stream-in-buffer stream))
# Line 570  Line 723 
723             (setf (lisp-stream-in-index stream) (1+ start))             (setf (lisp-stream-in-index stream) (1+ start))
724             (code-char (aref ibuf start))))))             (code-char (aref ibuf start))))))
725    
726    ;;; FAST-READ-CHAR-STRING-REFILL  --  Interface
727    ;;;
728    ;;;    This function is called by the fast-read-char expansion to refill the
729    ;;; string-buffer for text streams.  There is definitely a
730    ;;; string-buffer and an in-buffer, which implies there must be an
731    ;;; n-bin method.
732    ;;;
733    #+unicode
734    (defun fast-read-char-string-refill (stream eof-errorp eof-value)
735      ;; Like fast-read-char-refill, but we don't need or want the
736      ;; in-buffer-extra.
737      (let* ((ibuf (lisp-stream-in-buffer stream))
738             (index (lisp-stream-in-index stream))
739             (in-length (fd-stream-in-length stream)))
740        (declare (type (integer 0 #.in-buffer-length) index in-length))
741    
742        #+(or debug-frc-sr)
743        (progn
744          (format t "index = ~A~%" index)
745          (format t "in-length = ~A~%" in-length)
746          (format t "ibuf before = ~A~%" ibuf)
747          (format t "sbuf before = ~S~%" (subseq (lisp-stream-string-buffer stream) 0
748                                                 (lisp-stream-string-buffer-len stream))))
749    
750        ;; For debugging, clear out the stuff we've already read so we can
751        ;; see what's happening.
752        #+(or debug-frc-sr)
753        (fill ibuf 0 :start 0 :end index)
754    
755        ;; Copy the stuff we haven't read from in-buffer to the beginning
756        ;; of the buffer.
757        (if (< index in-length)
758            (replace ibuf ibuf
759                     :start1 0
760                     :start2 index :end2 in-length)
761            (setf index in-length))
762    
763        ;; For debugging, clear out the stuff we've already read so we can
764        ;; see what's happening.
765        #+(or debug-frc-sr)
766        (when (< index (1- in-buffer-length))
767          (fill ibuf 0 :start (1+ index) :end in-buffer-length))
768    
769        (setf index (- in-length index))
770    
771        #+(or debug-frc-sr)
772        (format t "ibuf after  = ~A~%" ibuf)
773    
774        (flet
775            ((get-octets (start)
776               (funcall (lisp-stream-n-bin stream) stream
777                        ibuf start
778                        (- in-buffer-length start)
779                        nil))
780             (handle-eof ()
781               ;; Nothing left in the stream, so update our pointers to
782               ;; indicate we've read everything and call the stream-in
783               ;; function so that we do the right thing for eof.
784               (setf (lisp-stream-in-index stream) in-buffer-length)
785               (setf (lisp-stream-string-index stream)
786                     (lisp-stream-string-buffer-len stream))
787               (funcall (lisp-stream-in stream) stream eof-errorp eof-value)))
788          (let ((count (get-octets index)))
789            (declare (type (integer 0 #.in-buffer-length) count))
790    
791            #+(or debug-frc-sr)
792            (progn
793              (format t "count = ~D~%" count)
794              (format t "new ibuf = ~A~%" ibuf))
795    
796            (cond ((zerop count)
797                   (handle-eof))
798                  (t
799                   (let ((sbuf (lisp-stream-string-buffer stream))
800                         (slen (lisp-stream-string-buffer-len stream)))
801                     (declare (simple-string sbuf)
802                              (type (integer 0 #.(1+ in-buffer-length)) slen)
803                              (optimize (speed 3)))
804    
805                     ;; Update in-length.  This is needed if we change the
806                     ;; external-format of the stream because we need to
807                     ;; know how many octets are valid (in case
808                     ;; end-of-file was reached)
809                     (setf (fd-stream-in-length stream) (+ count index))
810                     #+(or debug-frc-sr)
811                     (format t "in-length = ~D~%" (fd-stream-in-length stream))
812    
813                     #+(or debug-frc-sr)
814                     (format t "slen = ~A~%" slen)
815    
816                     ;; Copy the last read character to the beginning of the
817                     ;; buffer to support unreading.
818                     (when (plusp slen)
819                       (setf (schar sbuf 0) (schar sbuf (1- slen))))
820    
821                     #+(or debug-frc-sr)
822                     (progn
823                       (format t "sbuf[0] = ~S~%" (schar sbuf 0))
824                       (format t "index = ~S~%" index))
825    
826    
827                     ;; Convert all the octets, including the ones that we
828                     ;; haven't processed yet and the ones we just read in.
829                     (flet
830                         ((convert-buffer ()
831                            (multiple-value-bind (s char-count octet-count new-state)
832                                (stream::octets-to-string-counted
833                                 ibuf
834                                 (fd-stream-octet-count stream)
835                                 :start 0
836                                 :end (fd-stream-in-length stream)
837                                 :state (fd-stream-oc-state stream)
838                                 :string sbuf
839                                 :s-start 1
840                                 :external-format (fd-stream-external-format stream)
841                                 :error (fd-stream-octets-to-char-error stream))
842                              (declare (ignore s)
843                                       (type (integer 0 #.in-buffer-length) char-count octet-count))
844                              #+(or debug-frc-sr)
845                              (progn
846                                (format t "char-count = ~A~%" char-count)
847                                (format t "octet-count = ~A~%" octet-count)
848                                (format t "in-index = ~A~%" (lisp-stream-in-index stream)))
849                              (when (> char-count 0)
850                                (setf (fd-stream-oc-state stream) new-state)
851                                (setf (lisp-stream-string-buffer-len stream) (1+ char-count))
852                                (setf (lisp-stream-string-index stream) 2)
853                                (setf (lisp-stream-in-index stream) octet-count)
854                                #+(or debug-frc-sr)
855                                (progn
856                                  (format t "new in-index = ~A~%" (lisp-stream-in-index stream))
857                                  (format t "new sbuf = ~S~%"
858                                          (subseq sbuf 0 (1+ char-count))))
859                                (schar sbuf 1)))))
860                       (let ((out (convert-buffer)))
861                         (or out
862                             ;; There weren't enough octets to convert at
863                             ;; least one character.  Try to read some more
864                             ;; octets and try again.  (If we still fail,
865                             ;; what should we do then?  Currently, just
866                             ;; just return NIL and let other parts of Lisp
867                             ;; catch that.)
868                             ;;
869                             ;; The in buffer holds unread octets up to
870                             ;; index in-length.  So start reading octets there.
871                             (let* ((index (fd-stream-in-length stream))
872                                    (count (get-octets index)))
873                               (declare (type (integer 0 #.in-buffer-length) count index))
874                               (cond ((zerop count)
875                                      (handle-eof))
876                                     (t
877                                      ;; Adjust in-length to the total
878                                      ;; number of octets that are now in
879                                      ;; the buffer.
880                                      (setf (fd-stream-in-length stream) (+ count index))
881                                      (convert-buffer))))))))))))))
882    
883  ;;; FAST-READ-BYTE-REFILL  --  Interface  ;;; FAST-READ-BYTE-REFILL  --  Interface
884  ;;;  ;;;
# Line 601  Line 910 
910  (defun write-char (character &optional (stream *standard-output*))  (defun write-char (character &optional (stream *standard-output*))
911    "Outputs the Character to the Stream."    "Outputs the Character to the Stream."
912    (declare (type streamlike stream))    (declare (type streamlike stream))
913    (with-out-stream stream (lisp-stream-out character)    (let ((stream (out-synonym-of stream)))
914                     (stream-write-char character))      (stream-dispatch stream
915          ;; simple-stream
916          (stream::%write-char stream character)
917          ;; lisp-stream
918          (funcall (lisp-stream-out stream) stream character)
919          ;; fundamental-stream
920          (stream-write-char stream character)))
921    character)    character)
922    
923  (defun terpri (&optional (stream *standard-output*))  (defun terpri (&optional (stream *standard-output*))
924    "Outputs a new line to the Stream."    "Outputs a new line to the Stream."
925    (declare (type streamlike stream))    (declare (type streamlike stream))
926    (with-out-stream stream (lisp-stream-out #\newline) (stream-terpri))    (let ((stream (out-synonym-of stream)))
927        (stream-dispatch stream
928          ;; simple-stream
929          (stream::%write-char stream #\Newline)
930          ;; lisp-stream
931          (funcall (lisp-stream-out stream) stream #\Newline)
932          ;; fundamental-stream
933          (stream-terpri stream)))
934    nil)    nil)
935    
936  (defun fresh-line (&optional (stream *standard-output*))  (defun fresh-line (&optional (stream *standard-output*))
937    "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 beginning of
938     a line.  Returns T if it output a new line, nil otherwise."     a line.  Returns T if it output a new line, nil otherwise."
939    (declare (type streamlike stream))    (declare (type streamlike stream))
940    (let ((stream (out-synonym-of stream)))    (let ((stream (out-synonym-of stream)))
941      (if (lisp-stream-p stream)      (stream-dispatch stream
942          (when (/= (or (charpos stream) 1) 0)        ;; simple-stream
943            (funcall (lisp-stream-out stream) stream #\newline)        (stream::%fresh-line stream)
944            t)        ;; lisp-stream
945          ;; Fundamental-stream.        (when (/= (or (charpos stream) 1) 0)
946          (stream-fresh-line stream))))          (funcall (lisp-stream-out stream) stream #\newline)
947            t)
948          ;; fundamental-stream
949          (stream-fresh-line stream))))
950    
951  (defun write-string (string &optional (stream *standard-output*)  (defun write-string (string &optional (stream *standard-output*)
952                              &key (start 0) end)                              &key (start 0) end)
# Line 630  Line 955 
955    
956  (defun write-string* (string &optional (stream *standard-output*)  (defun write-string* (string &optional (stream *standard-output*)
957                               (start 0) (end (length (the vector string))))                               (start 0) (end (length (the vector string))))
958    (declare (fixnum start end))    (declare (type streamlike stream) (fixnum start end))
959    (let ((stream (out-synonym-of stream)))    (let ((stream (out-synonym-of stream)))
960      (cond ((lisp-stream-p stream)      (stream-dispatch stream
961             (if (array-header-p string)        ;; simple-stream
962                 (with-array-data ((data string) (offset-start start)        (if (array-header-p string)
963                                   (offset-end end))            (with-array-data ((data string) (offset-start start)
964                   (funcall (lisp-stream-sout stream)                              (offset-end end))
965                            stream data offset-start offset-end))              (stream::%write-string stream data offset-start offset-end))
966                 (funcall (lisp-stream-sout stream) stream string start end))            (stream::%write-string stream string start end))
967             string)        ;; lisp-stream
968            (t    ; Fundamental-stream.        (if (array-header-p string)
969             (stream-write-string stream string start end)))))            (with-array-data ((data string) (offset-start start)
970                                (offset-end end))
971                (funcall (lisp-stream-sout stream)
972                         stream data offset-start offset-end))
973              (funcall (lisp-stream-sout stream) stream string start end))
974          ;; fundamental-stream
975          (stream-write-string stream string start end)))
976      string)
977    
978  (defun write-line (string &optional (stream *standard-output*)  (defun write-line (string &optional (stream *standard-output*)
979                            &key (start 0) (end (length string)))                            &key (start 0) (end (length string)))
980    "Outputs the String to the given Stream, followed by a newline character."    "Outputs the String to the given Stream, followed by a newline character."
981    (write-line* string stream start end))    (write-line* string stream start (or end (length string))))
982    
983  (defun write-line* (string &optional (stream *standard-output*)  (defun write-line* (string &optional (stream *standard-output*)
984                             (start 0) (end (length string)))                             (start 0) (end (length string)))
985    (declare (fixnum start end))    (declare (type streamlike stream) (fixnum start end))
986    (let ((stream (out-synonym-of stream)))    (let ((stream (out-synonym-of stream)))
987      (cond ((lisp-stream-p stream)      (stream-dispatch stream
988             (if (array-header-p string)        ;; simple-stream
989                 (with-array-data ((data string) (offset-start start)        (progn
990                                   (offset-end end))          (if (array-header-p string)
991                   (with-out-stream stream (lisp-stream-sout data offset-start              (with-array-data ((data string) (offset-start start)
992                                                             offset-end)))                                (offset-end end))
993                 (with-out-stream stream (lisp-stream-sout string start end)))                (stream::%write-string stream data offset-start offset-end))
994             (funcall (lisp-stream-out stream) stream #\newline))              (stream::%write-string stream string start end))
995            (t    ; Fundamental-stream.          (stream::%write-char stream #\Newline))
996             (stream-write-string stream string start end)        ;; lisp-stream
997             (stream-write-char stream #\Newline)))        (progn
998            (if (array-header-p string)
999                (with-array-data ((data string) (offset-start start)
1000                                  (offset-end end))
1001                  (funcall (lisp-stream-sout stream) stream data offset-start
1002                                                            offset-end))
1003                (funcall (lisp-stream-sout stream) stream string start end))
1004            (funcall (lisp-stream-out stream) stream #\newline))
1005          ;; fundamental-stream
1006          (progn
1007            (stream-write-string stream string start end)
1008            (stream-write-char stream #\Newline)))
1009      string))      string))
1010    
1011  (defun charpos (&optional (stream *standard-output*))  (defun charpos (&optional (stream *standard-output*))
1012    "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
1013    Stream, or Nil if that information is not availible."    Stream, or Nil if that information is not availible."
1014    (with-out-stream stream (lisp-stream-misc :charpos) (stream-line-column)))    (declare (type streamlike stream))
1015      (let ((stream (out-synonym-of stream)))
1016        (stream-dispatch stream
1017          ;; simple-stream
1018          (stream::%charpos stream)
1019          ;; lisp-stream
1020          (funcall (lisp-stream-misc stream) stream :charpos)
1021          ;; fundamental-stream
1022          (stream-line-column stream))))
1023    
1024  (defun line-length (&optional (stream *standard-output*))  (defun line-length (&optional (stream *standard-output*))
1025    "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
1026    given Stream, or Nil if that information is not available."    given Stream, or Nil if that information is not available."
1027    (with-out-stream stream (lisp-stream-misc :line-length)    (declare (type streamlike stream))
1028                     (stream-line-length)))    (let ((stream (out-synonym-of stream)))
1029        (stream-dispatch stream
1030          ;; simple-stream
1031          (stream::%line-length stream)
1032          ;; lisp-stream
1033          (funcall (lisp-stream-misc stream) stream :line-length)
1034          ;; fundamental-stream
1035          (stream-line-length stream))))
1036    
1037  (defun finish-output (&optional (stream *standard-output*))  (defun finish-output (&optional (stream *standard-output*))
1038    "Attempts to ensure that all output sent to the Stream has reached its    "Attempts to ensure that all output sent to the Stream has reached its
1039     destination, and only then returns."     destination, and only then returns."
1040    (declare (type streamlike stream))    (declare (type streamlike stream))
1041    (with-out-stream stream (lisp-stream-misc :finish-output)    (let ((stream (out-synonym-of stream)))
1042                     (stream-finish-output))      (stream-dispatch stream
1043          ;; simple-stream
1044          (stream::%finish-output stream)
1045          ;; lisp-stream
1046          (funcall (lisp-stream-misc stream) stream :finish-output)
1047          ;; fundamental-stream
1048          (stream-finish-output stream)))
1049    nil)    nil)
1050    
1051  (defun force-output (&optional (stream *standard-output*))  (defun force-output (&optional (stream *standard-output*))
1052    "Attempts to force any buffered output to be sent."    "Attempts to force any buffered output to be sent."
1053    (declare (type streamlike stream))    (declare (type streamlike stream))
1054    (with-out-stream stream (lisp-stream-misc :force-output)    (let ((stream (out-synonym-of stream)))
1055                     (stream-force-output))      (stream-dispatch stream
1056          ;; simple-stream
1057          (stream::%force-output stream)
1058          ;; lisp-stream-misc
1059          (funcall (lisp-stream-misc stream) stream :force-output)
1060          ;; fundamental-stream
1061          (stream-force-output stream)))
1062    nil)    nil)
1063    
1064  (defun clear-output (&optional (stream *standard-output*))  (defun clear-output (&optional (stream *standard-output*))
1065    "Clears the given output Stream."    "Clears the given output Stream."
1066    (declare (type streamlike stream))    (declare (type streamlike stream))
1067    (with-out-stream stream (lisp-stream-misc :clear-output)    (let ((stream (out-synonym-of stream)))
1068                     (stream-force-output))      (stream-dispatch stream
1069          ;; simple-stream
1070          (stream::%clear-output stream)
1071          ;; lisp-stream
1072          (funcall (lisp-stream-misc stream) stream :clear-output)
1073          ;; fundamental-stream
1074          (stream-force-output stream)))
1075    nil)    nil)
1076    
1077  (defun write-byte (integer stream)  (defun write-byte (integer stream)
1078    "Outputs the Integer to the binary Stream."    "Outputs the Integer to the binary Stream."
1079    (declare (type stream stream))    (declare (type stream stream))
1080    (with-out-stream stream (lisp-stream-bout integer)    (let ((stream (out-synonym-of stream)))
1081                     (stream-write-byte integer))      (stream-dispatch stream
1082          ;; simple-stream
1083          (stream::%write-byte stream integer)
1084          ;; lisp-stream
1085          (funcall (lisp-stream-bout stream) stream integer)
1086          ;; fundamental-stream
1087          (stream-write-byte stream integer)))
1088    integer)    integer)
1089    
1090    
1091  ;;; Stream-misc-dispatch  ;;; Stream-misc-dispatch
1092  ;;;  ;;;
1093  ;;; Called from lisp-steam routines that encapsulate CLOS streams to  ;;; Called from lisp-stream routines that encapsulate CLOS streams to
1094  ;;; handle the misc routines and dispatch to the appropriate Gray  ;;; handle the misc routines and dispatch to the appropriate Gray
1095  ;;; stream functions.  ;;; stream functions.
1096  ;;;  ;;;
# Line 717  Line 1099 
1099             (ignore arg2))             (ignore arg2))
1100    (case operation    (case operation
1101      (:listen      (:listen
1102       ;; Return true is input available, :eof for eof-of-file, otherwise Nil.       ;; Return true if input available, :eof for end-of-file, otherwise Nil.
1103       (let ((char (stream-read-char-no-hang stream)))       (let ((char (stream-read-char-no-hang stream)))
1104         (when (characterp char)         (when (characterp char)
1105           (stream-unread-char stream char))           (stream-unread-char stream char))
# Line 774  streams." Line 1156  streams."
1156  (macrolet ((out-fun (fun method stream-method &rest args)  (macrolet ((out-fun (fun method stream-method &rest args)
1157               `(defun ,fun (stream ,@args)               `(defun ,fun (stream ,@args)
1158                  (dolist (stream (broadcast-stream-streams stream))                  (dolist (stream (broadcast-stream-streams stream))
1159                    (if (lisp-stream-p stream)                    (stream-dispatch stream
1160                        (funcall (,method stream) stream ,@args)                      ;; simple-stream
1161                        (,stream-method stream ,@args))))))                      (,stream-method stream ,@args) ; use gray-compat for now
1162                        ;; lisp-stream
1163                        (funcall (,method stream) stream ,@args)
1164                        ;; fundamental-stream
1165                        (,stream-method stream ,@args))))))
1166    (out-fun broadcast-out lisp-stream-out stream-write-char char)    (out-fun broadcast-out lisp-stream-out stream-write-char char)
1167    (out-fun broadcast-bout lisp-stream-bout stream-write-byte byte)    (out-fun broadcast-bout lisp-stream-bout stream-write-byte byte)
1168    (out-fun broadcast-sout lisp-stream-sout stream-write-string    (out-fun broadcast-sout lisp-stream-sout stream-write-string
# Line 786  streams." Line 1172  streams."
1172    (let ((streams (broadcast-stream-streams stream)))    (let ((streams (broadcast-stream-streams stream)))
1173      (case operation      (case operation
1174        (:charpos        (:charpos
1175         (dolist (stream streams)         (dolist (stream streams 0)
1176           (let ((charpos (charpos stream)))           (let ((charpos (charpos stream)))
1177             (if charpos (return charpos)))))             (if charpos (return charpos)))))
1178        (:line-length        (:line-length
# Line 794  streams." Line 1180  streams."
1180           (dolist (stream streams min)           (dolist (stream streams min)
1181             (let ((res (line-length stream)))             (let ((res (line-length stream)))
1182               (when res (setq min (if min (min res min) res)))))))               (when res (setq min (if min (min res min) res)))))))
1183          ;; CLHS: The functions file-length, file-position, file-string-length, and
1184          ;; stream-external-format return the value from the last component
1185          ;; stream; if there are no component streams, file-length and
1186          ;; file-position return 0, file-string-length returns 1, and
1187          ;; stream-external-format returns :default.
1188          (:file-length
1189           (if (null streams) 0
1190               (file-length (first (last streams)))))
1191          (:file-position
1192           (if (null streams) 0
1193               (file-position (first (last streams)))))
1194        (:element-type        (:element-type
1195           #+nil ; old, arguably more logical, version
1196         (let (res)         (let (res)
1197           (dolist (stream streams (if (> (length res) 1) `(and ,@res) res))           (dolist (stream streams (if (> (length res) 1) `(and ,@res) t))
1198             (pushnew (stream-element-type stream) res :test #'equal))))             (pushnew (stream-element-type stream) res :test #'equal)))
1199           ;; ANSI-specified version (under System Class BROADCAST-STREAM)
1200           (let ((res t))
1201             (do ((streams streams (cdr streams)))
1202                 ((null streams) res)
1203               (when (null (cdr streams))
1204                 (setq res (stream-element-type (car streams)))))))
1205        (:close)        (:close)
1206        (t        (t
1207         (let ((res nil))         (let ((res nil))
# Line 829  streams." Line 1233  streams."
1233    (format stream "#<Synonym Stream to ~S>" (synonym-stream-symbol s)))    (format stream "#<Synonym Stream to ~S>" (synonym-stream-symbol s)))
1234    
1235  (setf (documentation 'make-synonym-stream 'function)  (setf (documentation 'make-synonym-stream 'function)
1236    "Returns a stream which performs its operations on the stream which is the    _N"Returns a stream which performs its operations on the stream which is the
1237     value of the dynamic variable named by Symbol.")     value of the dynamic variable named by Symbol.")
1238    
1239  ;;; The output simple output methods just call the corresponding method  ;;; The output simple output methods just call the corresponding method
# Line 962  streams." Line 1366  streams."
1366               in-type `(and ,in-type ,out-type))))               in-type `(and ,in-type ,out-type))))
1367        (:close        (:close
1368         (set-closed-flame stream))         (set-closed-flame stream))
1369          (:file-length
1370           (error 'type-error :datum stream :expected-type 'file-stream))
1371          (:charpos
1372           (charpos out))
1373          (:line-length
1374           (line-length out))
1375        (t        (t
1376         (or (if in-lisp-stream-p         (or (if in-lisp-stream-p
1377                 (funcall (lisp-stream-misc in) in operation arg1 arg2)                 (funcall (lisp-stream-misc in) in operation arg1 arg2)
# Line 1028  streams." Line 1438  streams."
1438      (setf (concatenated-stream-streams stream) (cdr current))))      (setf (concatenated-stream-streams stream) (cdr current))))
1439    
1440  (defun concatenated-misc (stream operation &optional arg1 arg2)  (defun concatenated-misc (stream operation &optional arg1 arg2)
1441    (let ((left (concatenated-stream-streams stream)))    (let ((current (first (concatenated-stream-streams stream))))
1442      (when left      (case operation
1443        (let* ((current (car left)))        (:listen
1444          (case operation         (if current
1445            (:listen             (loop
1446             (loop              (let ((stuff (if (lisp-stream-p current)
1447               (let ((stuff (if (lisp-stream-p current)                               (funcall (lisp-stream-misc current) current
1448                                (funcall (lisp-stream-misc current) current                                        :listen)
1449                                         :listen)                               (stream-misc-dispatch current :listen))))
1450                                (stream-misc-dispatch current :listen))))                (cond ((eq stuff :eof)
1451                 (cond ((eq stuff :eof)                       ;; Advance current, and try again.
1452                        ;; Advance current, and try again.                       (pop (concatenated-stream-streams stream))
1453                        (pop (concatenated-stream-streams stream))                       (setf current (first (concatenated-stream-streams stream)))
1454                        (setf current                       (unless current (return :eof)))
1455                              (car (concatenated-stream-streams stream)))                      (stuff
1456                        (unless current                       ;; Stuff's available.
1457                          ;; No further streams.  EOF.                       (return t))
1458                          (return :eof)))                      (t
1459                       (stuff                       ;; Nothing available yet.
1460                        ;; Stuff's available.                       (return nil)))))
1461                        (return t))             :eof))
1462                       (t        (:close
1463                        ;; Nothing available yet.         (set-closed-flame stream))
1464                        (return nil))))))        (:clear-input
1465            (:close         (when current (clear-input current)))
1466             (set-closed-flame stream))        (:unread
1467            (:clear-input (clear-input current))         (when current (unread-char arg1 current)))
1468            (:unread (unread-char arg1 current))        (:file-length
1469            (t         (error 'type-error :datum stream :expected-type 'file-stream))
1470             (if (lisp-stream-p current)        (t
1471                 (funcall (lisp-stream-misc current) current operation arg1 arg2)         (if (lisp-stream-p current)
1472                 (stream-misc-dispatch current operation arg1 arg2))))))))             (funcall (lisp-stream-misc current) current operation arg1 arg2)
1473               (stream-misc-dispatch current operation arg1 arg2))))))
1474    
1475    
1476  ;;;; Echo Streams:  ;;;; Echo Streams:
# Line 1069  streams." Line 1480  streams."
1480                        (in #'echo-in)                        (in #'echo-in)
1481                        (bin #'echo-bin)                        (bin #'echo-bin)
1482                        (misc #'echo-misc)                        (misc #'echo-misc)
1483                        (n-bin #'ill-n-bin))                        (n-bin #'echo-n-bin))
1484              (:print-function %print-echo-stream)              (:print-function %print-echo-stream)
1485              (:constructor %make-echo-stream (input-stream output-stream)))              (:constructor %make-echo-stream (input-stream output-stream)))
1486    unread-stuff)    unread-stuff)
# Line 1139  output to Output-stream" Line 1550  output to Output-stream"
1550                             (pop (echo-stream-unread-stuff stream)))                             (pop (echo-stream-unread-stuff stream)))
1551                            (t                            (t
1552                             (setf unread-char-p nil)                             (setf unread-char-p nil)
1553                             (read-char in eof-errorp eof-value)))))                             (read-char in eof-errorp :eof)))))
1554               (generalized-peeking-mechanism               (generalized-peeking-mechanism
1555                arg1 eof-value char                arg1 eof-value char
1556                (infn)                (infn)
1557                  :eof
1558                (unread-char char in)                (unread-char char in)
1559                (outfn char))))))                :skipped-char-form (outfn char))))))
1560          (:file-length
1561           (error 'type-error :datum stream :expected-type 'file-stream))
1562        (t        (t
1563         (or (if (lisp-stream-p in)         (or (if (lisp-stream-p in)
1564                 (funcall (lisp-stream-misc in) in operation arg1 arg2)                 (funcall (lisp-stream-misc in) in operation arg1 arg2)
# Line 1153  output to Output-stream" Line 1567  output to Output-stream"
1567                 (funcall (lisp-stream-misc out) out operation arg1 arg2)                 (funcall (lisp-stream-misc out) out operation arg1 arg2)
1568                 (stream-misc-dispatch out operation arg1 arg2)))))))                 (stream-misc-dispatch out operation arg1 arg2)))))))
1569    
1570    
1571    (defun echo-n-bin (stream buffer start numbytes eof-error-p)
1572      (let ((new-start start)
1573            (read 0))
1574        (loop
1575         (let ((thing (pop (echo-stream-unread-stuff stream))))
1576           (cond
1577             (thing
1578              (setf (aref buffer new-start) thing)
1579              (incf new-start)
1580              (incf read)
1581              (when (= read numbytes)
1582                (return-from echo-n-bin numbytes)))
1583             (t (return nil)))))
1584        (let ((bytes-read (read-n-bytes (echo-stream-input-stream stream) buffer
1585                                        new-start (- numbytes read) nil)))
1586          (cond
1587            ((not eof-error-p)
1588             (write-sequence buffer (echo-stream-output-stream stream)
1589                             :start new-start :end (+ new-start bytes-read))
1590             (+ bytes-read read))
1591            ((> numbytes (+ read bytes-read))
1592             (write-sequence buffer (echo-stream-output-stream stream)
1593                             :start new-start :end (+ new-start bytes-read))
1594             (error 'end-of-file :stream stream))
1595            (t
1596             (write-sequence buffer (echo-stream-output-stream stream)
1597                             :start new-start :end (+ new-start bytes-read))
1598             numbytes)))))
1599    
1600  (defun %print-echo-stream (s stream d)  (defun %print-echo-stream (s stream d)
1601    (declare (ignore d))    (declare (ignore d))
1602    (format stream "#<Echo Stream, Input = ~S, Output = ~S>"    (format stream "#<Echo Stream, Input = ~S, Output = ~S>"
# Line 1160  output to Output-stream" Line 1604  output to Output-stream"
1604            (two-way-stream-output-stream s)))            (two-way-stream-output-stream s)))
1605    
1606  (setf (documentation 'make-echo-stream 'function)  (setf (documentation 'make-echo-stream 'function)
1607    "Returns a bidirectional stream which gets its input from Input-Stream and    _N"Returns a bidirectional stream which gets its input from Input-Stream and
1608     sends its output to Output-Stream.  In addition, all input is echoed to     sends its output to Output-Stream.  In addition, all input is echoed to
1609     the output stream")     the output stream")
1610    
# Line 1241  output to Output-stream" Line 1685  output to Output-stream"
1685    (case operation    (case operation
1686      (:file-position      (:file-position
1687       (if arg1       (if arg1
1688           (setf (string-input-stream-current stream) arg1)           (setf (string-input-stream-current stream)
1689                   (case arg1
1690                     (:start 0)
1691                     (:end (length (string-input-stream-string stream)))
1692                     (t arg1)))
1693           (string-input-stream-current stream)))           (string-input-stream-current stream)))
1694      (:file-length (length (string-input-stream-string stream)))      (:file-length
1695         (error 'type-error :datum stream :expected-type 'file-stream))
1696      (:unread (decf (string-input-stream-current stream)))      (:unread (decf (string-input-stream-current stream)))
1697      (:listen (or (/= (the fixnum (string-input-stream-current stream))      (:listen (or (/= (the fixnum (string-input-stream-current stream))
1698                       (the fixnum (string-input-stream-end stream)))                       (the fixnum (string-input-stream-end stream)))
1699                   :eof))                   :eof))
1700      (:element-type 'base-char)))      (:element-type 'base-char)
1701        (:close
1702         (set-closed-flame stream))))
1703    
1704  (defun make-string-input-stream (string &optional  (defun make-string-input-stream (string &optional
1705                                          (start 0) (end (length string)))                                          (start 0) (end (length string)))
# Line 1258  output to Output-stream" Line 1709  output to Output-stream"
1709             (type index start)             (type index start)
1710             (type (or index null) end))             (type (or index null) end))
1711    (internal-make-string-input-stream (coerce string 'simple-string)    (internal-make-string-input-stream (coerce string 'simple-string)
1712                                       start end))                                       start (or end (length string))))
1713    
1714  ;;;; String Output Streams:  ;;;; String Output Streams:
1715    
# Line 1268  output to Output-stream" Line 1719  output to Output-stream"
1719                        (sout #'string-sout)                        (sout #'string-sout)
1720                        (misc #'string-out-misc))                        (misc #'string-out-misc))
1721              (:print-function %print-string-output-stream)              (:print-function %print-string-output-stream)
1722              (:constructor make-string-output-stream ()))              (:constructor %make-string-output-stream ()))
1723    ;; The string we throw stuff in.    ;; The string we throw stuff in.
1724    (string (make-string 40) :type simple-string)    (string (make-string 40) :type simple-string)
1725    ;; Index of the next location to use.    ;; Index of the next location to use.
# Line 1278  output to Output-stream" Line 1729  output to Output-stream"
1729    (declare (ignore s d))    (declare (ignore s d))
1730    (write-string "#<String-Output Stream>" stream))    (write-string "#<String-Output Stream>" stream))
1731    
1732  (setf (documentation 'make-string-output-stream 'function)  (defun make-string-output-stream (&key (element-type 'character))
1733    "Returns an Output stream which will accumulate all output given it for    "Returns an Output stream which will accumulate all output given to it for
1734     the benefit of the function Get-Output-Stream-String.")     the benefit of the function Get-Output-Stream-String."
1735      (declare (ignore element-type))
1736      (%make-string-output-stream))
1737    
1738  (defun string-ouch (stream character)  (defun string-ouch (stream character)
1739    (let ((current (string-output-stream-index stream))    (let ((current (string-output-stream-index stream))
# Line 1320  output to Output-stream" Line 1773  output to Output-stream"
1773      (:file-position      (:file-position
1774       (if (null arg1)       (if (null arg1)
1775           (string-output-stream-index stream)))           (string-output-stream-index stream)))
1776        (:file-length
1777         (error 'type-error :datum stream :expected-type 'file-stream))
1778      (:charpos      (:charpos
1779       (do ((index (1- (the fixnum (string-output-stream-index stream)))       (do ((index (1- (the fixnum (string-output-stream-index stream)))
1780                   (1- index))                   (1- index))
# Line 1330  output to Output-stream" Line 1785  output to Output-stream"
1785                  (fixnum index count))                  (fixnum index count))
1786         (if (char= (schar string index) #\newline)         (if (char= (schar string index) #\newline)
1787             (return count))))             (return count))))
1788      (:element-type 'base-char)))      (:element-type 'base-char)
1789        (:close
1790         (set-closed-flame stream))))
1791    
1792  (defun get-output-stream-string (stream)  (defun get-output-stream-string (stream)
1793    "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 1381  output to Output-stream" Line 1838  output to Output-stream"
1838              (let* ((new-length (if (zerop current) 1 (* current 2)))              (let* ((new-length (if (zerop current) 1 (* current 2)))
1839                     (new-workspace (make-string new-length)))                     (new-workspace (make-string new-length)))
1840                (declare (simple-string new-workspace))                (declare (simple-string new-workspace))
1841                (%primitive byte-blt workspace start new-workspace 0 current)                (%primitive byte-blt workspace (* vm:char-bytes start)
1842                              new-workspace 0 (* vm:char-bytes current))
1843                (setf workspace new-workspace)                (setf workspace new-workspace)
1844                (setf offset-current current)                (setf offset-current current)
1845                (set-array-header buffer workspace new-length                (set-array-header buffer workspace new-length
# Line 1407  output to Output-stream" Line 1865  output to Output-stream"
1865              (let* ((new-length (+ (the fixnum (* current 2)) string-len))              (let* ((new-length (+ (the fixnum (* current 2)) string-len))
1866                     (new-workspace (make-string new-length)))                     (new-workspace (make-string new-length)))
1867                (declare (simple-string new-workspace))                (declare (simple-string new-workspace))
1868                (%primitive byte-blt workspace dst-start new-workspace 0 current)                (%primitive byte-blt workspace (* vm:char-bytes dst-start)
1869                              new-workspace 0 (* vm:char-bytes current))
1870                (setf workspace new-workspace)                (setf workspace new-workspace)
1871                (setf offset-current current)                (setf offset-current current)
1872                (setf offset-dst-end dst-end)                (setf offset-dst-end dst-end)
1873                (set-array-header buffer workspace new-length                (set-array-header buffer workspace new-length
1874                                  dst-end 0 new-length nil))                                  dst-end 0 new-length nil))
1875              (setf (fill-pointer buffer) dst-end))              (setf (fill-pointer buffer) dst-end))
1876          (%primitive byte-blt string start          (%primitive byte-blt string (* vm:char-bytes start)
1877                      workspace offset-current offset-dst-end)))                      workspace (* vm:char-bytes offset-current)
1878                        (* vm:char-bytes offset-dst-end))))
1879      dst-end))      dst-end))
1880    
1881    
# Line 1448  output to Output-stream" Line 1908  output to Output-stream"
1908    (indentation 0))    (indentation 0))
1909    
1910  (setf (documentation 'make-indenting-stream 'function)  (setf (documentation 'make-indenting-stream 'function)
1911   "Returns an output stream which indents its output by some amount.")   _N"Returns an output stream which indents its output by some amount.")
1912    
1913  (defun %print-indenting-stream (s stream d)  (defun %print-indenting-stream (s stream d)
1914    (declare (ignore s d))    (declare (ignore s d))
1915    (write-string "#<Indenting Stream>" stream))    (write-string "#<Indenting Stream>" stream))
1916    
1917  ;;; Indenting-Indent writes the right number of spaces needed to indent output on  ;;; Indenting-Indent writes the right number of spaces needed to indent
1918  ;;; the given Stream based on the specified Sub-Stream.  ;;; output on the given Stream based on the specified Sub-Stream.
1919    
1920  (defmacro indenting-indent (stream sub-stream)  (defmacro indenting-indent (stream sub-stream)
1921    `(do ((i 0 (+ i 60))    `(do ((i 0 (+ i 60))
# Line 1797  output to Output-stream" Line 2257  output to Output-stream"
2257    
2258    
2259  ;;; READ-SEQUENCE --  ;;; READ-SEQUENCE --
 ;;; Note:  the multi-byte operation SYSTEM:READ-N-BYTES operates on  
 ;;; subtypes of SIMPLE-ARRAY.  Hence the distinction between simple  
 ;;; and non simple input functions.  
2260    
2261  (defun read-sequence (seq stream &key (start 0) (end nil))  (defun read-sequence (seq stream &key (start 0) (end nil) partial-fill)
2262    "Destructively modify SEQ by reading elements from STREAM.    "Destructively modify SEQ by reading elements from STREAM.
2263  SEQ is bounded by START and END. SEQ is destructively modified by  
2264  copying successive elements into it from STREAM. If the end of file    Seq is bounded by Start and End. Seq is destructively modified by
2265  for STREAM is reached before copying all elements of the subsequence,    copying successive elements into it from Stream. If the end of file
2266  then the extra elements near the end of sequence are not updated.    for Stream is reached before copying all elements of the subsequence,
2267      then the extra elements near the end of sequence are not updated.
2268  Argument(s):  
2269  SEQ:    a proper SEQUENCE    Argument(s):
2270  STREAM: an input STREAM    SEQ:      a proper SEQUENCE
2271  START:  a bounding index designator of type '(INTEGER 0 *)' (default 0)    STREAM:   an input STREAM
2272  END:    a bounding index designator which be NIL or an INTEGER of    START:    a bounding index designator of type '(INTEGER 0 *)' (default 0)
2273          type '(INTEGER 0 *)' (default NIL)    END:      a bounding index designator which be NIL or an INTEGER of
2274                type '(INTEGER 0 *)' (default NIL)
2275  Value(s):  
2276  POSITION: an INTEGER greater than or equal to zero, and less than or    Value(s):
2277            equal to the length of the SEQ. POSITION is the index of    POSITION: an INTEGER greater than or equal to zero, and less than or
2278            the first element of SEQ that was not updated, which might be              equal to the length of the SEQ. POSITION is the index of
2279            less than END because the end of file was reached."              the first element of SEQ that was not updated, which might be
2280                less than END because the end of file was reached."
2281    
2282    (declare (type (or list vector) seq)) ; could be (type sequence seq)    (declare (type (or list vector) seq)) ; could be (type sequence seq)
2283    (declare (type stream stream))    (declare (type stream stream))
# Line 1827  POSITION: an INTEGER greater than or equ Line 2285  POSITION: an INTEGER greater than or equ
2285    (declare (type (or null (integer 0 *)) end))    (declare (type (or null (integer 0 *)) end))
2286    (declare (values (integer 0 *)))    (declare (values (integer 0 *)))
2287    
2288    (when (not (cl::lisp-stream-p stream))    (stream-dispatch stream
2289       (return-from read-sequence (stream-read-sequence stream seq start end)))      ;; simple-stream
2290        (stream::%read-sequence stream seq start end partial-fill)
2291    (let ((end (or end (length seq))))      ;; lisp-stream
2292      (declare (type (integer 0 *) start end))      (let ((end (or end (length seq))))
2293          (declare (type (integer 0 *) start end))
2294      ;; Just catch some errors earlier than it would be necessary.  
2295      (cond ((not (open-stream-p stream))        ;; Just catch some errors earlier than it would be necessary.
2296             (error 'stream-error        (cond ((not (open-stream-p stream))
2297                    :stream stream               (error 'simple-stream-error
2298                    :format-control "The stream is not open."))                      :stream stream
2299            ((not (input-stream-p stream))                      :format-control (intl:gettext "The stream is not open.")))
2300             (error 'stream-error              ((not (input-stream-p stream))
2301                    :stream stream               (error 'simple-stream-error
2302                    :format-control "The stream is not open for input."))                      :stream stream
2303            ((and seq (>= start end) 0))                      :format-control (intl:gettext "The stream is not open for input.")))
2304            (t              ((and seq (>= start end) 0))
2305             ;; So much for object-oriented programming!              (t
2306             (etypecase seq               ;; So much for object-oriented programming!
2307               (list               (etypecase seq
2308                (read-into-list seq stream start end))                 (list
2309               (simple-string                  (read-into-list seq stream start end))
2310                (read-into-simple-string seq stream start end))                 (string
2311               (string                  (with-array-data ((seq seq) (start start) (end end))
2312                (read-into-string seq stream start end))                    (read-into-string seq stream start end partial-fill)))
2313               (simple-array              ; We also know that it is a 'vector'.                 (simple-array            ; We also know that it is a 'vector'.
2314                (read-into-simple-array seq stream start end))                  (read-into-simple-array seq stream start end))
2315               (vector                 (vector
2316                (read-into-vector seq stream start end)))                  (read-into-vector seq stream start end))))))
2317             ))))      ;; fundamental-stream
2318        (stream-read-sequence stream seq start end)))
2319    
2320    
2321  ;;; READ-INTO-LIST, READ-INTO-LIST-1  ;;; READ-INTO-LIST, READ-INTO-LIST-1
# Line 1875  POSITION: an INTEGER greater than or equ Line 2334  POSITION: an INTEGER greater than or equ
2334                             #'read-byte)))                             #'read-byte)))
2335      (read-into-list-1 (nthcdr start l) start end stream read-function)))      (read-into-list-1 (nthcdr start l) start end stream read-function)))
2336    
2337  #+:recursive  #+recursive
2338  (defun read-into-list-1 (l start end stream read-function)  (defun read-into-list-1 (l start end stream read-function)
2339    (declare (type list l))    (declare (type list l))
2340    (declare (type stream stream))    (declare (type stream stream))
2341    (declare (type (integer 0 *) start end))    (declare (type (integer 0 *) start end))
2342    (if (or (endp l) (= start end))    (if (or (endp l) (= start end))
2343        start        start
2344        (let* ((eof-marker (load-time-value (list 'eof-marker)))        (let* ((el (funcall read-function stream nil stream)))
2345               (el (funcall read-function stream nil eof-marker)))          (cond ((eq el stream) start)
         (cond ((eq el eof-marker) start)  
2346                (t (setf (first l) el)                (t (setf (first l) el)
2347                   (read-into-list-1 (rest l)                   (read-into-list-1 (rest l)
2348                                     (1+ start)                                     (1+ start)
# Line 1894  POSITION: an INTEGER greater than or equ Line 2352  POSITION: an INTEGER greater than or equ
2352        ))        ))
2353    
2354    
2355  #-:iterative  #-recursive
2356  (defun read-into-list-1 (l start end stream read-function)  (defun read-into-list-1 (l start end stream read-function)
2357    (declare (type list l))    (declare (type list l))
2358    (declare (type stream stream))    (declare (type stream stream))
# Line 1903  POSITION: an INTEGER greater than or equ Line 2361  POSITION: an INTEGER greater than or equ
2361    ;; The declaration for I may be too restrictive in the case of    ;; The declaration for I may be too restrictive in the case of
2362    ;; lists.  But then again, it is still a huge number.    ;; lists.  But then again, it is still a huge number.
2363    (do ((lis l (rest lis))    (do ((lis l (rest lis))
2364         (i start (1+ i))         (i start (1+ i)))
2365         )        ((or (endp lis)
2366        ((or (endp lis) (>= i end)) i)             (>= i end))
2367           i)
2368      (declare (type list lis))      (declare (type list lis))
2369      (declare (type index i))      (declare (type index i))
2370      (let* ((eof-marker (load-time-value (list 'eof-marker)))      (let* ((el (funcall read-function stream nil stream)))
2371             (el (funcall read-function stream nil eof-marker)))        (when (eq el stream)
       (when (eq el eof-marker)  
2372          (return i))          (return i))
2373        (setf (first lis) el))))        (setf (first lis) el))))
2374    
2375    
2376  ;;; READ-INTO-SIMPLE-STRING --  ;;; READ-INTO-SIMPLE-STRING --
2377    
2378    #+nil
2379  (defun read-into-simple-string (s stream start end)  (defun read-into-simple-string (s stream start end)
2380    (declare (type simple-string s))    (declare (type simple-string s))
2381    (declare (type stream stream))    (declare (type stream stream))
# Line 1925  POSITION: an INTEGER greater than or equ Line 2384  POSITION: an INTEGER greater than or equ
2384      (error 'type-error      (error 'type-error
2385             :datum (read-char stream nil #\Null)             :datum (read-char stream nil #\Null)
2386             :expected-type (stream-element-type stream)             :expected-type (stream-element-type stream)
2387             :format-control "Trying to read characters from a binary stream."))             :format-control (intl:gettext "Trying to read characters from a binary stream.")))
2388    ;; Let's go as low level as it seems reasonable.    ;; Let's go as low level as it seems reasonable.
2389    (let* ((numbytes (- end start))    (let* ((numbytes (- end start))
2390           (bytes-read (system:read-n-bytes stream s start numbytes nil))           (total-bytes 0))
2391           )      ;; read-n-bytes may return fewer bytes than requested, so we need
2392      (if (< bytes-read numbytes)      ;; to keep trying.
2393          (+ start bytes-read)      (loop while (plusp numbytes) do
2394          end)))            (let ((bytes-read (system:read-n-bytes stream s start numbytes nil)))
2395                (when (zerop bytes-read)
2396                  (return-from read-into-simple-string start))
2397                (incf total-bytes bytes-read)
2398                (incf start bytes-read)
2399                (decf numbytes bytes-read)))
2400        start))
2401    
2402    
2403    ;;; read-into-simple-string hacked to allow (unsigned-byte 8) stream-element-type
2404    ;;; For some reason applying this change to read-into-simple-string causes CMUCL to die.
2405    #-unicode
2406    (defun read-into-string (s stream start end partial-fill)
2407      (declare (type simple-string s))
2408      (declare (type stream stream))
2409      (declare (type index start end))
2410      (unless (or (subtypep (stream-element-type stream) 'character)
2411                  (equal (stream-element-type stream) '(unsigned-byte 8)))
2412        (error 'type-error
2413               :datum (read-char stream nil #\Null)
2414               :expected-type (stream-element-type stream)
2415               :format-control (intl:gettext "Trying to read characters from a binary stream.")))
2416      ;; Let's go as low level as it seems reasonable.
2417      (let* ((numbytes (- end start))
2418             (total-bytes 0))
2419        ;; read-n-bytes may return fewer bytes than requested, so we need
2420        ;; to keep trying.
2421        (loop while (plusp numbytes) do
2422          (let ((bytes-read (system:read-n-bytes stream s start numbytes nil)))
2423            (incf total-bytes bytes-read)
2424            (incf start bytes-read)
2425            (decf numbytes bytes-read)
2426            (when (or partial-fill (zerop bytes-read))
2427              (return-from read-into-string start))))
2428        start))
2429    
2430  (defun read-into-string (s stream start end)  #+unicode
2431    (defun read-into-string (s stream start end partial-fill)
2432    (declare (type string s))    (declare (type string s))
2433    (declare (type stream stream))    (declare (type stream stream))
2434    (declare (type index start end))    (declare (type index start end))
# Line 1943  POSITION: an INTEGER greater than or equ Line 2436  POSITION: an INTEGER greater than or equ
2436      (error 'type-error      (error 'type-error
2437             :datum (read-char stream nil #\Null)             :datum (read-char stream nil #\Null)
2438             :expected-type (stream-element-type stream)             :expected-type (stream-element-type stream)
2439             :format-control "Trying to read characters from a binary stream."))             :format-control (intl:gettext "Trying to read characters from a binary stream.")))
2440    (do ((i start (1+ i))    (do ((i start (1+ i))
2441         (s-len (length s))         (s-len (length s)))
2442         )        ((or (>= i s-len)
2443        ((or (>= i s-len) (>= i end)) i)             (>= i end))
2444           i)
2445      (declare (type index i s-len))      (declare (type index i s-len))
2446      (let* ((eof-marker (load-time-value (list 'eof-marker)))      (let* ((el (read-char stream nil stream)))
            (el (read-char stream nil eof-marker)))  
2447        (declare (type (or character stream) el))        (declare (type (or character stream) el))
2448        (when (eq el eof-marker)        (when (eq el stream)
2449          (return i))          (return i))
2450        (setf (char s i) (the character el)))))        (setf (char s i) (the character el)))))
2451    
   
2452  ;;; READ-INTO-SIMPLE-ARRAY --  ;;; READ-INTO-SIMPLE-ARRAY --
2453  ;;; We definitively know that we are really reading into a vector.  ;;; We definitively know that we are really reading into a vector.
2454    
# Line 1970  POSITION: an INTEGER greater than or equ Line 2462  POSITION: an INTEGER greater than or equ
2462  ;;; buffers.  ;;; buffers.
2463    
2464  (defparameter *read-into-simple-array-recognized-types*  (defparameter *read-into-simple-array-recognized-types*
2465    '((unsigned-byte 8)    '(base-char                           ; Character types are needed
2466                                            ; to support simple-stream
2467                                            ; semantics for read-vector
2468        character
2469        (unsigned-byte 8)
2470      (unsigned-byte 16)      (unsigned-byte 16)
2471      (unsigned-byte 32)      (unsigned-byte 32)
2472      (signed-byte 8)      (signed-byte 8)
2473      (signed-byte 16)      (signed-byte 16)
   
2474      (signed-byte 32)      (signed-byte 32)
2475        single-float             ; not previously supported by read-sequence
2476        double-float             ; not previously supported by read-sequence
2477      ))      ))
2478    
2479  (defun read-into-simple-array (s stream start end)  (defun read-into-simple-array (s stream start end)
# Line 1995  POSITION: an INTEGER greater than or equ Line 2492  POSITION: an INTEGER greater than or equ
2492                       (simple-array (signed-byte 32) (*))                       (simple-array (signed-byte 32) (*))
2493                       (simple-array (unsigned-byte *) (*))                       (simple-array (unsigned-byte *) (*))
2494                       (simple-array (signed-byte *) (*))                       (simple-array (signed-byte *) (*))
2495                       )                       (simple-array single-float (*))  ; not previously supported by read-sequence
2496                         (simple-array double-float (*))  ; not previously supported by read-sequence
2497                         simple-bit-vector)
2498                   s))                   s))
2499    
2500    (declare (type stream stream))    (declare (type stream stream))
# Line 2004  POSITION: an INTEGER greater than or equ Line 2503  POSITION: an INTEGER greater than or equ
2503      ;; What is the purpose of this explicit test for characters?  It      ;; What is the purpose of this explicit test for characters?  It
2504      ;; prevents reading a string-stream into a vector, like the      ;; prevents reading a string-stream into a vector, like the
2505      ;; example in the CLHS.      ;; example in the CLHS.
2506      (cond #+nil      (cond #+(or)
2507            ((subtypep (stream-element-type stream) 'character)            ((subtypep (stream-element-type stream) 'character)
2508             (error 'type-error             (error 'type-error
2509                    :datum (read-byte stream nil 0)                    :datum (read-byte stream nil 0)
2510                    :expected-type (stream-element-type stream) ; Bogus?!?                    :expected-type (stream-element-type stream) ; Bogus?!?
2511                    :format-control                    :format-control
2512                    "Trying to read binary data from a text stream."))                    (intl:gettext "Trying to read binary data from a text stream.")))
2513    
2514            ;; Let's go as low level as it seems reasonable.            ;; Let's go as low level as it seems reasonable.
2515            ((not (member stream-et            ((not (member stream-et
2516                          *read-into-simple-array-recognized-types*                          *read-into-simple-array-recognized-types*
2517                          :test #'equal))                          :test #'equal))
2518             ;; (format t ">>> Reading vector from binary stream of type ~S~%"             #+nil
2519             ;;         stream-et)             (format t ">>> Reading vector from binary stream of type ~S~%"
2520                       stream-et)
2521    
2522             ;; We resort to the READ-BYTE based operation.             ;; We resort to the READ-BYTE based operation.
2523             (read-into-vector s stream start end))             (read-into-vector s stream start end))
# Line 2081  POSITION: an INTEGER greater than or equ Line 2581  POSITION: an INTEGER greater than or equ
2581                   ((simple-array (signed-byte 32) (*))                   ((simple-array (signed-byte 32) (*))
2582                    (read-n-x8-bytes stream data offset-start offset-end 32))                    (read-n-x8-bytes stream data offset-start offset-end 32))
2583    
2584                     ;; not previously supported by read-sequence
2585                     ((simple-array single-float (*))
2586                      (read-n-x8-bytes stream data offset-start offset-end 32))
2587    
2588                     ;; not previously supported by read-sequence
2589                     ((simple-array double-float (*))
2590                      (read-n-x8-bytes stream data offset-start offset-end 64))
2591    
2592                   ;; Otherwise we resort to the READ-BYTE based operation.                   ;; Otherwise we resort to the READ-BYTE based operation.
2593                     (simple-bit-vector
2594                      (read-into-vector s stream start end))
2595                   ((simple-array (unsigned-byte *) (*))                   ((simple-array (unsigned-byte *) (*))
2596                    (read-into-vector s stream start end))                    (read-into-vector s stream start end))
   
2597                   ((simple-array (signed-byte *) (*))                   ((simple-array (signed-byte *) (*))
2598                    (read-into-vector s stream start end))                    (read-into-vector s stream start end)))))))))
                  ))                     ; with-array-data  
              )                          ; flet  
            ))  
     ))  
   
2599    
2600  ;;; READ-INTO-VECTOR --  ;;; READ-INTO-VECTOR --
2601    
# Line 2102  POSITION: an INTEGER greater than or equ Line 2606  POSITION: an INTEGER greater than or equ
2606    (let* ((stream-et (stream-element-type stream))    (let* ((stream-et (stream-element-type stream))
2607           (read-function (if (subtypep stream-et 'character)           (read-function (if (subtypep stream-et 'character)
2608                              #'read-char                              #'read-char
2609                              #'read-byte))                              #'read-byte)))
          )  
2610      (do ((i start (1+ i))      (do ((i start (1+ i))
2611           (a-len (length v))           (a-len (length v)))
2612           )          ((or (>= i a-len) (>= i end))
2613          ((or (>= i a-len) (>= i end)) i)           i)
2614        (declare (type index i a-len))        (declare (type index i a-len))
2615        (let* ((eof-marker (load-time-value (list 'eof-marker)))        (let* ((el (funcall read-function stream nil stream)))
2616               (el (funcall read-function stream nil eof-marker)))          (when (eq el stream)
         (when (eq el eof-marker)  
2617            (return i))            (return i))
2618          (setf (aref v i) el)))))          (setf (aref v i) el)))))
2619    
2620  (declaim (end-block))                   ; READ-SEQUENCE block  ;(declaim (end-block))                  ; READ-SEQUENCE block
2621    
2622    
2623  (declaim (start-block write-sequence))  (declaim (start-block write-sequence))
# Line 2125  POSITION: an INTEGER greater than or equ Line 2627  POSITION: an INTEGER greater than or equ
2627  ;;; will always puzzle me.  ;;; will always puzzle me.
2628    
2629  (defun write-sequence (seq stream &key (start 0) (end nil))  (defun write-sequence (seq stream &key (start 0) (end nil))
2630    "Writes the elements of the of SEQ bounded by START and END to STREAM.    "Writes the elements of the Seq bounded by Start and End to Stream.
2631  Argument(s):  
2632  SEQ:    a proper SEQUENCE    Argument(s):
2633  STREAM: an output STREAM    SEQ:     a proper SEQUENCE
2634  START:  a bounding index designator of type '(INTEGER 0 *)' (default 0)    STREAM:  an output STREAM
2635  END:    a bounding index designator which be NIL or an INTEGER of    START:   a bounding index designator of type '(INTEGER 0 *)' (default 0)
2636          type '(INTEGER 0 *)' (default NIL)    END:     a bounding index designator which be NIL or an INTEGER of
2637               type '(INTEGER 0 *)' (default NIL)
2638    
2639  Value(s):    Value(s):
2640  SEQ:    a proper SEQUENCE    SEQ:  a proper SEQUENCE
2641  "  "
2642    (declare (type (or list vector) seq))    (declare (type (or list vector) seq))
2643    (declare (type stream stream))    (declare (type stream stream))
# Line 2142  SEQ:   a proper SEQUENCE Line 2645  SEQ:   a proper SEQUENCE
2645    (declare (type (or null (integer 0 *)) end))    (declare (type (or null (integer 0 *)) end))
2646    (declare (values (or list vector)))    (declare (values (or list vector)))
2647    
2648    (when (not (cl::lisp-stream-p stream))    (stream-dispatch stream
2649      (return-from write-sequence (stream-write-sequence stream seq start end)))      ;; simple-stream
2650        (stream::%write-sequence stream seq start end)
2651    (let ((end (or end (length seq))))      ;; lisp-stream
2652      (declare (type (integer 0 *) start end))      (let ((end (or end (length seq))))
2653          (declare (type (integer 0 *) start end))
2654      ;; Just catch some errors earlier than it would be necessary.  
2655      (cond ((not (open-stream-p stream))        ;; Just catch some errors earlier than it would be necessary.
2656             (error 'stream-error        (cond ((not (open-stream-p stream))
2657                    :stream stream               (error 'simple-stream-error
2658                    :format-control "The stream is not open."))                      :stream stream
2659            ((not (output-stream-p stream))                      :format-control (intl:gettext "The stream is not open.")))
2660             (error 'stream-error              ((not (output-stream-p stream))
2661                    :stream stream               (error 'simple-stream-error
2662                    :format-control "The stream is not open for output."))                      :stream stream
2663            ((and seq (>= start end)) seq)                      :format-control (intl:gettext "The stream is not open for output.")))
2664            (t              ((and seq (>= start end)) seq)
2665             ;; So much for object-oriented programming!              (t
2666             ;; Note: order of type clauses is very important.  As a               ;; So much for object-oriented programming!
2667             ;; matter of fact it is patterned after the class               ;; Note: order of type clauses is very important.  As a
2668             ;; precedence list of each of the types listed.               ;; matter of fact it is patterned after the class
2669             (etypecase seq               ;; precedence list of each of the types listed.
2670               (list               (etypecase seq
2671                (write-list-out seq stream start end))                 (list
2672               (simple-string                  (write-list-out seq stream start end))
2673                (write-simple-string-out seq stream start end))                 (string
2674               (string                  (with-array-data ((seq seq) (start start) (end end))
2675                (write-string-out seq stream start end))                    (write-string-out seq stream start end)))
2676               (simple-vector             ; This is necessary because of                 (simple-vector           ; This is necessary because of
2677                                          ; the underlying behavior of                                          ; the underlying behavior of
2678                                          ; OUTPUT-RAW-BYTES.  A vector                                          ; OUTPUT-RAW-BYTES.  A vector
2679                                          ; produced by VECTOR has                                          ; produced by VECTOR has
2680                                          ; element-type T in CMUCL.                                          ; element-type T in CMUCL.
2681                (write-vector-out seq stream start end))                  (write-vector-out seq stream start end))
2682               (simple-array              ; We know it is also a vector!                 (simple-array            ; We know it is also a vector!
2683                (write-simple-array-out seq stream start end))                  (write-simple-array-out seq stream start end))
2684               (vector                 (vector
2685                (write-vector-out seq stream start end)))                  (write-vector-out seq stream start end))))))
2686             ))))      ;; fundamental-stream
2687        (stream-write-sequence stream seq start end))
2688      seq)
2689    
2690    
2691  ;;; The following functions operate under one - possibly wrong -  ;;; The following functions operate under one - possibly wrong -
# Line 2207  SEQ:   a proper SEQUENCE Line 2712  SEQ:   a proper SEQUENCE
2712                        :datum e                        :datum e
2713                        :expected-type type                        :expected-type type
2714                        :format-control                        :format-control
2715                        "Trying to output an element of unproper type to a stream.")))))                        (intl:gettext "Trying to output an element of unproper type to a stream."))))))
2716      (let ((stream-et (stream-element-type stream)))      (let ((stream-et (stream-element-type stream)))
2717    
2718        (check-list-element-types seq stream-et)        (check-list-element-types seq stream-et)
# Line 2240  SEQ:   a proper SEQUENCE Line 2745  SEQ:   a proper SEQUENCE
2745      ))      ))
2746    
2747    
2748  ;;; WRITE-SIMPLE-STRING-OUT, WRITE-STRING-OUT  ;;; WRITE-STRING-OUT
 ;;; These functions are really the same, since they rely on  
 ;;; WRITE-STRING (which should be pretty efficient by itself.)  The  
 ;;; only difference is in the declaration. Maybe the duplication is an  
 ;;; overkill, but it makes things a little more logical.  
   
 (defun write-simple-string-out (seq stream start end)  
   (declare (type simple-string seq))  
   (when (not (subtypep (stream-element-type stream) 'character))  
     (error 'type-error  
            :datum seq  
            :expected-type (stream-element-type stream)  
            :format-control "Trying to output a string to a binary stream."))  
   (write-string seq stream :start start :end end)  
   seq)  
   
2749    
2750  (defun write-string-out (seq stream start end)  (defun write-string-out (seq stream start end)
2751    (declare (type string seq))    (declare (type simple-string seq))
2752    (when (not (subtypep (stream-element-type stream) 'character))    (when (and (not (subtypep (stream-element-type stream) 'character))
2753                 (not (equal (stream-element-type stream) '(unsigned-byte 8))))
2754      (error 'type-error      (error 'type-error
2755             :datum seq             :datum seq
2756             :expected-type (stream-element-type stream)             :expected-type (stream-element-type stream)
2757             :format-control "Trying to output a string to a binary stream."))             :format-control (intl:gettext "Trying to output a string to a binary stream.")))
2758    (write-string seq stream :start start :end end)    (write-string seq stream :start start :end end)
2759    seq)    seq)
2760    
# Line 2292  SEQ:   a proper SEQUENCE Line 2783  SEQ:   a proper SEQUENCE
2783                       (simple-array (unsigned-byte 32) (*))                       (simple-array (unsigned-byte 32) (*))
2784                       (simple-array (signed-byte 32) (*))                       (simple-array (signed-byte 32) (*))
2785                       (simple-array (unsigned-byte *) (*))                       (simple-array (unsigned-byte *) (*))
2786                       (simple-array (signed-byte *) (*)))                       (simple-array (signed-byte *) (*))
2787                         (simple-array single-float (*))
2788                         (simple-array double-float (*)))
2789                      seq))                      seq))
2790    (when (not (subtypep (stream-element-type stream) 'integer))    (when (not (subtypep (stream-element-type stream) 'integer))
2791      (error 'type-error      (error 'simple-type-error
2792             :datum (elt seq 0)             :datum (elt seq 0)
2793             :expected-type (stream-element-type stream)             :expected-type (stream-element-type stream)
2794             :format-control "Trying to output binary data to a text stream."))             :format-control (intl:gettext "Trying to output binary data to a text stream.")))
2795    (cond ((system:fd-stream-p stream)    (cond ((system:fd-stream-p stream)
2796           (flet ((write-n-x8-bytes (stream data start end byte-size)           (flet ((write-n-x8-bytes (stream data start end byte-size)
2797                    (let ((x8-mult (truncate byte-size 8)))                    (let ((x8-mult (truncate byte-size 8)))
# Line 2327  SEQ:   a proper SEQUENCE Line 2820  SEQ:   a proper SEQUENCE
2820                 ((simple-array (signed-byte 32) (*))                 ((simple-array (signed-byte 32) (*))
2821                  (write-n-x8-bytes stream data start end 32))                  (write-n-x8-bytes stream data start end 32))
2822    
2823                   ((simple-array single-float (*))
2824                    (write-n-x8-bytes stream data start end 32))
2825    
2826                   ((simple-array double-float (*))
2827                    (write-n-x8-bytes stream data start end 64))
2828    
2829                 ;; Otherwise we resort to the READ-BYTE based operation.                 ;; Otherwise we resort to the READ-BYTE based operation.
2830                 ((simple-array (unsigned-byte *) (*))                 ((simple-array (unsigned-byte *) (*))
2831                  (write-vector-out seq stream start end))                  (write-vector-out seq stream start end))
2832    
2833                 ((simple-array (signed-byte *) (*))                 ((simple-array (signed-byte *) (*))
2834                  (write-vector-out seq stream start end))                  (write-vector-out seq stream start end))
2835    
2836                   (bit-vector
2837                    (write-vector-out seq stream start end))
2838                 )                 )
2839               seq)))               seq)))
2840    
# Line 2343  SEQ:   a proper SEQUENCE Line 2845  SEQ:   a proper SEQUENCE
2845               (declare (type index i sv-len))               (declare (type index i sv-len))
2846               (write-byte (aref seq i) stream)))))               (write-byte (aref seq i) stream)))))
2847    
   
2848  (defun write-vector-out (seq stream start end)  (defun write-vector-out (seq stream start end)
2849    (when (not (subtypep (stream-element-type stream) 'integer))    (let ((write-function
2850      (error 'type-error           (if (subtypep (stream-element-type stream) 'character)
2851             :datum (elt seq 0)               #'write-char
2852             :expected-type (stream-element-type stream)               #'write-byte)))
2853             :format-control "Trying to output binary data to a text stream."))      (do ((i start (1+ i))
2854    (do ((i start (1+ i))           (a-len (length seq))
2855         (a-len (length seq))           )
2856         )          ((or (>= i end) (>= i a-len)) seq)
2857        ((or (>= i end) (>= i a-len)) seq)        (declare (type index i a-len))
2858      (declare (type index i a-len))        (funcall write-function (aref seq i) stream))))
     (write-byte (aref seq i) stream)))  
2859    
2860  (declaim (end-block))                   ; WRITE-SEQUENCE block.  (declaim (end-block))                   ; WRITE-SEQUENCE block.
2861  #||  #||
2862  ;;; READ-SEQUENCE -- Public  ;;; READ-SEQUENCE -- Public
2863  ;;;  ;;;
2864  (defun read-sequence (seq stream &key (start 0) (end nil))  (defun read-sequence (seq stream &key (start 0) (end nil))
2865    "Destructively modify SEQ by reading elements from STREAM.    _N"Destructively modify SEQ by reading elements from STREAM.
2866    SEQ is bounded by START and END. SEQ is destructively modified by    SEQ is bounded by START and END. SEQ is destructively modified by
2867    copying successive elements into it from STREAM. If the end of file    copying successive elements into it from STREAM. If the end of file
2868    for STREAM is reached before copying all elements of the subsequence,    for STREAM is reached before copying all elements of the subsequence,
# Line 2373  SEQ:   a proper SEQUENCE Line 2873  SEQ:   a proper SEQUENCE
2873             (type index start)             (type index start)
2874             (type sequence-end end)             (type sequence-end end)
2875             (values index))             (values index))
2876    (when (not (cl::lisp-stream-p stream))    (when (not (lisp::lisp-stream-p stream))
2877       (return-from read-sequence (stream-read-sequence seq stream start end)))       (return-from read-sequence (stream-read-sequence seq stream start end)))
2878    (let ((end (or end (length seq))))    (let ((end (or end (length seq))))
2879      (declare (type index end))      (declare (type index end))
# Line 2425  SEQ:   a proper SEQUENCE Line 2925  SEQ:   a proper SEQUENCE
2925  ;;; WRITE-SEQUENCE -- Public  ;;; WRITE-SEQUENCE -- Public
2926  ;;;  ;;;
2927  (defun write-sequence (seq stream &key (start 0) (end nil))  (defun write-sequence (seq stream &key (start 0) (end nil))
2928    "Write the elements of SEQ bounded by START and END to STREAM."    _N"Write the elements of SEQ bounded by START and END to STREAM."
2929    (declare (type sequence seq)    (declare (type sequence seq)
2930             (type stream stream)             (type stream stream)
2931             (type index start)             (type index start)
2932             (type sequence-end end)             (type sequence-end end)
2933             (values sequence))             (values sequence))
2934    (when (not (cl::lisp-stream-p stream))    (when (not (lisp::lisp-stream-p stream))
2935      (return-from write-sequence (stream-write-sequence seq stream start end)))      (return-from write-sequence (stream-write-sequence seq stream start end)))
2936    (let ((end (or end (length seq))))    (let ((end (or end (length seq))))
2937      (declare (type index start end))      (declare (type index start end))

Legend:
Removed from v.1.58.2.1  
changed lines
  Added in v.1.102

  ViewVC Help
Powered by ViewVC 1.1.5