FAST-READ-BYTE refactoring

[sbcl.git] / src / code / stream.lisp

diff --git a/src/code/stream.lisp b/src/code/stream.lisp
index cbbdf97..30f0e68 100644 (file)
--- a/src/code/stream.lisp
+++ b/src/code/stream.lisp
@@ -53,44 +53,36 @@
          :format-arguments (list stream)))
 (defun closed-flame (stream &rest ignore)
   (declare (ignore ignore))
          :format-arguments (list stream)))
 (defun closed-flame (stream &rest ignore)
   (declare (ignore ignore))

-  (error "~S is closed." stream))
+  (error 'closed-stream-error :stream stream))

 (defun no-op-placeholder (&rest ignore)
   (declare (ignore ignore)))
 \f
 ;;; stream manipulation functions
 
 (defun no-op-placeholder (&rest ignore)
   (declare (ignore ignore)))
 \f
 ;;; stream manipulation functions
 

-(declaim (inline ansi-stream-input-stream-p))

 (defun ansi-stream-input-stream-p (stream)
   (declare (type ansi-stream stream))
 (defun ansi-stream-input-stream-p (stream)
   (declare (type ansi-stream stream))

-
-  (when (synonym-stream-p stream)
-    (setf stream
-          (symbol-value (synonym-stream-symbol stream))))
-
-  (and (not (eq (ansi-stream-in stream) #'closed-flame))
+  (if (synonym-stream-p stream)
+      (input-stream-p (symbol-value (synonym-stream-symbol stream)))
+      (and (not (eq (ansi-stream-in stream) #'closed-flame))

        ;;; KLUDGE: It's probably not good to have EQ tests on function
        ;;; values like this. What if someone's redefined the function?
        ;;; Is there a better way? (Perhaps just VALID-FOR-INPUT and
        ;;; VALID-FOR-OUTPUT flags? -- WHN 19990902
        ;;; KLUDGE: It's probably not good to have EQ tests on function
        ;;; values like this. What if someone's redefined the function?
        ;;; Is there a better way? (Perhaps just VALID-FOR-INPUT and
        ;;; VALID-FOR-OUTPUT flags? -- WHN 19990902

-       (or (not (eq (ansi-stream-in stream) #'ill-in))
-           (not (eq (ansi-stream-bin stream) #'ill-bin)))))
+           (or (not (eq (ansi-stream-in stream) #'ill-in))
+               (not (eq (ansi-stream-bin stream) #'ill-bin))))))

 
 (defun input-stream-p (stream)
   (declare (type stream stream))
   (and (ansi-stream-p stream)
        (ansi-stream-input-stream-p stream)))
 
 
 (defun input-stream-p (stream)
   (declare (type stream stream))
   (and (ansi-stream-p stream)
        (ansi-stream-input-stream-p stream)))
 

-(declaim (inline ansi-stream-output-stream-p))

 (defun ansi-stream-output-stream-p (stream)
   (declare (type ansi-stream stream))
 (defun ansi-stream-output-stream-p (stream)
   (declare (type ansi-stream stream))

-
-  (when (synonym-stream-p stream)
-    (setf stream (symbol-value
-                  (synonym-stream-symbol stream))))
-
-  (and (not (eq (ansi-stream-in stream) #'closed-flame))
-       (or (not (eq (ansi-stream-out stream) #'ill-out))
-           (not (eq (ansi-stream-bout stream) #'ill-bout)))))
+  (if (synonym-stream-p stream)
+      (output-stream-p (symbol-value (synonym-stream-symbol stream)))
+      (and (not (eq (ansi-stream-in stream) #'closed-flame))
+           (or (not (eq (ansi-stream-out stream) #'ill-out))
+               (not (eq (ansi-stream-bout stream) #'ill-bout))))))

 
 (defun output-stream-p (stream)
   (declare (type stream stream))
 
 (defun output-stream-p (stream)
   (declare (type stream stream))

@@ -136,13 +128,14 @@
   (setf (ansi-stream-in stream) #'closed-flame)
   (setf (ansi-stream-bin stream) #'closed-flame)
   (setf (ansi-stream-n-bin stream) #'closed-flame)
   (setf (ansi-stream-in stream) #'closed-flame)
   (setf (ansi-stream-bin stream) #'closed-flame)
   (setf (ansi-stream-n-bin stream) #'closed-flame)

-  (setf (ansi-stream-in stream) #'closed-flame)

   (setf (ansi-stream-out stream) #'closed-flame)
   (setf (ansi-stream-bout stream) #'closed-flame)
   (setf (ansi-stream-sout stream) #'closed-flame)
   (setf (ansi-stream-misc stream) #'closed-flame))
 \f
   (setf (ansi-stream-out stream) #'closed-flame)
   (setf (ansi-stream-bout stream) #'closed-flame)
   (setf (ansi-stream-sout stream) #'closed-flame)
   (setf (ansi-stream-misc stream) #'closed-flame))
 \f

-;;;; file position and file length
+;;;; for file position and file length
+(defun external-format-char-size (external-format)
+  (ef-char-size (get-external-format external-format)))

 
 ;;; Call the MISC method with the :FILE-POSITION operation.
 #!-sb-fluid (declaim (inline ansi-stream-file-position))
 
 ;;; Call the MISC method with the :FILE-POSITION operation.
 #!-sb-fluid (declaim (inline ansi-stream-file-position))

@@ -150,7 +143,7 @@
   (declare (type stream stream))
   (declare (type (or index (alien sb!unix:off-t) (member nil :start :end))
                  position))
   (declare (type stream stream))
   (declare (type (or index (alien sb!unix:off-t) (member nil :start :end))
                  position))

-  ;; FIXME: It woud be good to comment on the stuff that is done here...
+  ;; FIXME: It would be good to comment on the stuff that is done here...

   ;; FIXME: This doesn't look interrupt safe.
   (cond
     (position
   ;; FIXME: This doesn't look interrupt safe.
   (cond
     (position

@@ -164,19 +157,20 @@
             (- +ansi-stream-in-buffer-length+
                (ansi-stream-in-index stream)))
          #!+sb-unicode
             (- +ansi-stream-in-buffer-length+
                (ansi-stream-in-index stream)))
          #!+sb-unicode

-         (let* ((external-format (stream-external-format stream))
-                (ef-entry (find-external-format external-format))
-                (variable-width-p (variable-width-external-format-p ef-entry))
-                (char-len (bytes-for-char-fun ef-entry)))
+         (let ((char-size (if (fd-stream-p stream)
+                              (fd-stream-char-size stream)
+                              (external-format-char-size (stream-external-format stream)))))

            (- res
            (- res

-              (if variable-width-p
-                  (loop with buffer = (ansi-stream-cin-buffer stream)
-                        with start = (ansi-stream-in-index stream)
-                        for i from start below +ansi-stream-in-buffer-length+
-                        sum (funcall char-len (aref buffer i)))
-                  (* (funcall char-len #\x)  ; arbitrary argument
-                     (- +ansi-stream-in-buffer-length+
-                        (ansi-stream-in-index stream)))))))))))
+              (etypecase char-size
+                (function
+                 (loop with buffer = (ansi-stream-cin-buffer stream)
+                       with start = (ansi-stream-in-index stream)
+                       for i from start below +ansi-stream-in-buffer-length+
+                       sum (funcall char-size (aref buffer i))))
+                (fixnum
+                 (* char-size
+                    (- +ansi-stream-in-buffer-length+
+                       (ansi-stream-in-index stream))))))))))))

 
 (defun file-position (stream &optional position)
   (if (ansi-stream-p stream)
 
 (defun file-position (stream &optional position)
   (if (ansi-stream-p stream)

@@ -237,54 +231,101 @@
 \f
 ;;;; input functions
 
 \f
 ;;;; input functions
 

+(defun ansi-stream-read-line-from-frc-buffer (stream eof-error-p eof-value)
+  (prepare-for-fast-read-char stream
+    (declare (ignore %frc-method%))
+    (let ((chunks-total-length 0)
+          (chunks nil))
+      (declare (type index chunks-total-length)
+               (list chunks))
+      (labels ((refill-buffer ()
+                 (prog1
+                     (fast-read-char-refill stream nil nil)
+                   (setf %frc-index% (ansi-stream-in-index %frc-stream%))))
+               (newline-position ()
+                 (position #\Newline (the (simple-array character (*))
+                                       %frc-buffer%)
+                           :test #'char=
+                           :start %frc-index%))
+               (make-and-return-result-string (pos)
+                 (let* ((len (+ (- (or pos %frc-index%)
+                                   %frc-index%)
+                                chunks-total-length))
+                        (res (make-string len))
+                        (start 0))
+                   (declare (type index start))
+                   (when chunks
+                     (dolist (chunk (nreverse chunks))
+                       (declare (type (simple-array character) chunk))
+                       (replace res chunk :start1 start)
+                       (incf start (length chunk))))
+                   (unless (null pos)
+                     (replace res %frc-buffer%
+                              :start1 start
+                              :start2 %frc-index% :end2 pos)
+                     (setf %frc-index% (1+ pos)))
+                   (done-with-fast-read-char)
+                   (return-from ansi-stream-read-line-from-frc-buffer (values res (null pos)))))
+               (add-chunk ()
+                 (let* ((end (length %frc-buffer%))
+                        (len (- end %frc-index%))
+                        (chunk (make-string len)))
+                   (replace chunk %frc-buffer% :start2 %frc-index% :end2 end)
+                   (push chunk chunks)
+                   (incf chunks-total-length len)
+                   (when (refill-buffer)
+                     (make-and-return-result-string nil)))))
+        (declare (inline make-and-return-result-string
+                         refill-buffer))
+        (when (and (= %frc-index% +ansi-stream-in-buffer-length+)
+                   (refill-buffer))
+          ;; EOF had been reached before we read anything
+          ;; at all. Return the EOF value or signal the error.
+          (done-with-fast-read-char)
+          (return-from ansi-stream-read-line-from-frc-buffer
+            (values (eof-or-lose stream eof-error-p eof-value) t)))
+        (loop
+           (let ((pos (newline-position)))
+             (if pos
+                 (make-and-return-result-string pos)
+                 (add-chunk))))))))
+

 #!-sb-fluid (declaim (inline ansi-stream-read-line))
 (defun ansi-stream-read-line (stream eof-error-p eof-value recursive-p)
   (declare (ignore recursive-p))
 #!-sb-fluid (declaim (inline ansi-stream-read-line))
 (defun ansi-stream-read-line (stream eof-error-p eof-value recursive-p)
   (declare (ignore recursive-p))

-  (prepare-for-fast-read-char stream
-    ;; Check whether the FAST-READ-CHAR buffer contains a newline. If it
-    ;; does, we can do things quickly by just copying the line from the
-    ;; buffer instead of doing repeated calls to FAST-READ-CHAR.
-    (when %frc-buffer%
-      (locally
-          ;; For %FIND-POSITION transform
-          (declare (optimize (speed 2)))
-        (let ((pos (position #\Newline %frc-buffer%
-                             :test #'char=
-                             :start %frc-index%)))
-          (when pos
-            (let* ((len (- pos %frc-index%))
-                   (res (make-string len)))
-              (replace res %frc-buffer% :start2 %frc-index% :end2 pos)
-              (setf %frc-index% (1+ pos))
-              (done-with-fast-read-char)
-              (return-from ansi-stream-read-line res))))))
-    (let ((res (make-string 80))
-          (len 80)
-          (index 0))
-      (loop
-         (let ((ch (fast-read-char nil nil)))
-           (cond (ch
-                  (when (char= ch #\newline)
-                    (done-with-fast-read-char)
-                    (return (values (%shrink-vector res index) nil)))
-                  (when (= index len)
-                    (setq len (* len 2))
-                    (let ((new (make-string len)))
-                      (replace new res)
-                      (setq res new)))
-                  (setf (schar res index) ch)
-                  (incf index))
-                 ((zerop index)
-                  (done-with-fast-read-char)
-                  (return (values (eof-or-lose stream
-                                               eof-error-p
-                                               eof-value)
-                                  t)))
-                 ;; Since FAST-READ-CHAR already hit the eof char, we
-                 ;; shouldn't do another READ-CHAR.
-                 (t
-                  (done-with-fast-read-char)
-                  (return (values (%shrink-vector res index) t)))))))))
+  (if (ansi-stream-cin-buffer stream)
+      ;; Stream has a fast-read-char buffer. Copy large chunks directly
+      ;; out of the buffer.
+      (ansi-stream-read-line-from-frc-buffer stream eof-error-p eof-value)
+      ;; Slow path, character by character.
+      (prepare-for-fast-read-char stream
+        (let ((res (make-string 80))
+              (len 80)
+              (index 0))
+          (loop
+             (let ((ch (fast-read-char nil nil)))
+               (cond (ch
+                      (when (char= ch #\newline)
+                        (done-with-fast-read-char)
+                        (return (values (%shrink-vector res index) nil)))
+                      (when (= index len)
+                        (setq len (* len 2))
+                        (let ((new (make-string len)))
+                          (replace new res)
+                          (setq res new)))
+                      (setf (schar res index) ch)
+                      (incf index))
+                     ((zerop index)
+                      (done-with-fast-read-char)
+                      (return (values (eof-or-lose stream
+                                                   eof-error-p
+                                                   eof-value)
+                                      t)))
+                     ;; Since FAST-READ-CHAR already hit the eof char, we
+                     ;; shouldn't do another READ-CHAR.
+                     (t
+                      (done-with-fast-read-char)
+                      (return (values (%shrink-vector res index) t))))))))))

 
 (defun read-line (&optional (stream *standard-input*) (eof-error-p t) eof-value
                             recursive-p)
 
 (defun read-line (&optional (stream *standard-input*) (eof-error-p t) eof-value
                             recursive-p)

@@ -400,10 +441,8 @@
   ;; a-s-read-sequence and needs a lambda list that's congruent with
   ;; that of a-s-read-char
   (declare (ignore recursive-p))
   ;; a-s-read-sequence and needs a lambda list that's congruent with
   ;; that of a-s-read-char
   (declare (ignore recursive-p))

-  (prepare-for-fast-read-byte stream
-    (prog1
-        (fast-read-byte eof-error-p eof-value t)
-      (done-with-fast-read-byte))))
+  (with-fast-read-byte (t stream eof-error-p eof-value)
+    (fast-read-byte)))

 
 (defun read-byte (stream &optional (eof-error-p t) eof-value)
   (if (ansi-stream-p stream)
 
 (defun read-byte (stream &optional (eof-error-p t) eof-value)
   (if (ansi-stream-p stream)

@@ -424,7 +463,17 @@
 ;;; some cases, but it wasn't being used in SBCL, so it was dropped.
 ;;; If we ever need it, it could be added later as a new variant N-BIN
 ;;; method (perhaps N-BIN-ASAP?) or something.
 ;;; some cases, but it wasn't being used in SBCL, so it was dropped.
 ;;; If we ever need it, it could be added later as a new variant N-BIN
 ;;; method (perhaps N-BIN-ASAP?) or something.

+#!-sb-fluid (declaim (inline read-n-bytes))

 (defun read-n-bytes (stream buffer start numbytes &optional (eof-error-p t))
 (defun read-n-bytes (stream buffer start numbytes &optional (eof-error-p t))

+  (if (ansi-stream-p stream)
+      (ansi-stream-read-n-bytes stream buffer start numbytes eof-error-p)
+      ;; We don't need to worry about element-type size here is that
+      ;; callers are supposed to have checked everything is kosher.
+      (let* ((end (+ start numbytes))
+             (read-end (stream-read-sequence stream buffer start end)))
+        (eof-or-lose stream (and eof-error-p (< read-end end)) (- read-end start)))))
+
+(defun ansi-stream-read-n-bytes (stream buffer start numbytes eof-error-p)

   (declare (type ansi-stream stream)
            (type index numbytes start)
            (type (or (simple-array * (*)) system-area-pointer) buffer))
   (declare (type ansi-stream stream)
            (type index numbytes start)
            (type (or (simple-array * (*)) system-area-pointer) buffer))

@@ -477,7 +526,8 @@
 
 ;;; This function is called by the FAST-READ-CHAR expansion to refill
 ;;; the IN-BUFFER for text streams. There is definitely an IN-BUFFER,
 
 ;;; This function is called by the FAST-READ-CHAR expansion to refill
 ;;; the IN-BUFFER for text streams. There is definitely an IN-BUFFER,

-;;; and hence must be an N-BIN method.
+;;; and hence must be an N-BIN method. It's also called by other stream
+;;; functions which directly peek into the frc buffer.

 (defun fast-read-char-refill (stream eof-error-p eof-value)
   (let* ((ibuf (ansi-stream-cin-buffer stream))
          (count (funcall (ansi-stream-n-bin stream)
 (defun fast-read-char-refill (stream eof-error-p eof-value)
   (let* ((ibuf (ansi-stream-cin-buffer stream))
          (count (funcall (ansi-stream-n-bin stream)

@@ -490,9 +540,32 @@
          (start (- +ansi-stream-in-buffer-length+ count)))
     (declare (type index start count))
     (cond ((zerop count)
          (start (- +ansi-stream-in-buffer-length+ count)))
     (declare (type index start count))
     (cond ((zerop count)

-           (setf (ansi-stream-in-index stream)
-                 +ansi-stream-in-buffer-length+)
-           (funcall (ansi-stream-in stream) stream eof-error-p eof-value))
+           ;; An empty count does not necessarily mean that we reached
+           ;; the EOF, it's also possible that it's e.g. due to a
+           ;; invalid octet sequence in a multibyte stream. To handle
+           ;; the resyncing case correctly we need to call the reading
+           ;; function and check whether an EOF was really reached. If
+           ;; not, we can just fill the buffer by one character, and
+           ;; hope that the next refill will not need to resync.
+           ;;
+           ;; KLUDGE: we can't use FD-STREAM functions (which are the
+           ;; only ones which will give us decoding errors) here,
+           ;; because this code is generic.  We can't call the N-BIN
+           ;; function, because near the end of a real file that can
+           ;; legitimately bounce us to the IN function.  So we have
+           ;; to call ANSI-STREAM-IN.
+           (let* ((index (1- +ansi-stream-in-buffer-length+))
+                  (value (funcall (ansi-stream-in stream) stream nil :eof)))
+             (cond
+               ((eql value :eof)
+                ;; definitely EOF now
+                (setf (ansi-stream-in-index stream)
+                      +ansi-stream-in-buffer-length+)
+                (values t (eof-or-lose stream eof-error-p eof-value)))
+               ;; we resynced or were given something instead
+               (t
+                (setf (aref ibuf index) value)
+                (values nil (setf (ansi-stream-in-index stream) index))))))

           (t
            (when (/= start +ansi-stream-in-buffer-extra+)
              (#.(let* ((n-character-array-bits
           (t
            (when (/= start +ansi-stream-in-buffer-extra+)
              (#.(let* ((n-character-array-bits

@@ -506,8 +579,8 @@
                 ibuf +ansi-stream-in-buffer-extra+
                 ibuf start
                 count))
                 ibuf +ansi-stream-in-buffer-extra+
                 ibuf start
                 count))

-           (setf (ansi-stream-in-index stream) (1+ start))
-           (aref ibuf start)))))
+           (values nil
+                   (setf (ansi-stream-in-index stream) start))))))

 
 ;;; This is similar to FAST-READ-CHAR-REFILL, but we don't have to
 ;;; leave room for unreading.
 
 ;;; This is similar to FAST-READ-CHAR-REFILL, but we don't have to
 ;;; leave room for unreading.

@@ -553,58 +626,46 @@
         ;; must be Gray streams FUNDAMENTAL-STREAM
         (stream-fresh-line stream))))
 
         ;; must be Gray streams FUNDAMENTAL-STREAM
         (stream-fresh-line stream))))
 

-(defun write-string (string &optional (stream *standard-output*)
-                            &key (start 0) end)
-  (declare (type string string))
-  ;; Note that even though you might expect, based on the behavior of
-  ;; things like AREF, that the correct upper bound here is
-  ;; (ARRAY-DIMENSION STRING 0), the ANSI glossary definitions for
-  ;; "bounding index" and "length" indicate that in this case (i.e.
-  ;; for the ANSI-specified functions WRITE-STRING [and WRITE-LINE]),
-  ;; (LENGTH STRING) is the required upper bound. A foolish
-  ;; consistency is the hobgoblin of lesser languages..
-  (%write-string string stream start (%check-vector-sequence-bounds
-                                      string start end))
-  string)
-

 #!-sb-fluid (declaim (inline ansi-stream-write-string))
 (defun ansi-stream-write-string (string stream start end)
 #!-sb-fluid (declaim (inline ansi-stream-write-string))
 (defun ansi-stream-write-string (string stream start end)

-  (declare (type string string))
-  (declare (type ansi-stream stream))
-  (declare (type index start end))
-  (if (array-header-p string)
-      (with-array-data ((data string) (offset-start start)
-                        (offset-end end))
-        (funcall (ansi-stream-sout stream)
-                 stream data offset-start offset-end))
-      (funcall (ansi-stream-sout stream) stream string start end))
-  string)
+  (with-array-data ((data string) (offset-start start)
+                    (offset-end end)
+                    :check-fill-pointer t)
+    (funcall (ansi-stream-sout stream)
+             stream data offset-start offset-end)))

 
 (defun %write-string (string stream start end)
 
 (defun %write-string (string stream start end)

+  (let ((stream (out-synonym-of stream)))
+    (if (ansi-stream-p stream)
+        (ansi-stream-write-string string stream start end)
+        ;; must be Gray streams FUNDAMENTAL-STREAM
+        (stream-write-string stream string start end)))
+  string)
+
+(defun write-string (string &optional (stream *standard-output*)
+                            &key (start 0) end)

   (declare (type string string))
   (declare (type stream-designator stream))
   (declare (type string string))
   (declare (type stream-designator stream))

-  (declare (type index start end))
-  (let ((stream (out-synonym-of stream)))
-    (if(ansi-stream-p stream)
-       (ansi-stream-write-string string stream start end)
-       ;; must be Gray streams FUNDAMENTAL-STREAM
-       (stream-write-string stream string start end))))
+  (%write-string string stream start end))

 
 ;;; A wrapper function for all those (MACROLET OUT-FUN) definitions,
 
 ;;; A wrapper function for all those (MACROLET OUT-FUN) definitions,

-;;; which cannot deal with keyword arguments.
+;;; which cannot deal with keyword arguments. %WRITE-STRING cannot
+;;; replace this, as this needs to deal with simple-strings as well.

 (declaim (inline write-string-no-key))
 (defun write-string-no-key (string stream start end)
   (write-string string stream :start start :end end))
 
 (defun write-line (string &optional (stream *standard-output*)
 (declaim (inline write-string-no-key))
 (defun write-string-no-key (string stream start end)
   (write-string string stream :start start :end end))
 
 (defun write-line (string &optional (stream *standard-output*)

-                          &key (start 0) end)
+                   &key (start 0) end)

   (declare (type string string))
   (declare (type string string))

-  ;; FIXME: Why is there this difference between the treatments of the
-  ;; STREAM argument in WRITE-STRING and WRITE-LINE?
-  (let ((defaulted-stream (out-synonym-of stream)))
-    (%write-string string defaulted-stream start (%check-vector-sequence-bounds
-                                                  string start end))
-    (write-char #\newline defaulted-stream))
+  (declare (type stream-designator stream))
+  (let ((stream (out-synonym-of stream)))
+    (cond ((ansi-stream-p stream)
+           (ansi-stream-write-string string stream start end)
+           (funcall (ansi-stream-out stream) stream #\newline))
+          (t
+           (stream-write-string stream string start end)
+           (stream-write-char stream #\newline))))

   string)
 
 (defun charpos (&optional (stream *standard-output*))
   string)
 
 (defun charpos (&optional (stream *standard-output*))

@@ -878,7 +939,6 @@
 
 (macrolet ((in-fun (name fun &rest args)
              `(defun ,name (stream ,@args)
 
 (macrolet ((in-fun (name fun &rest args)
              `(defun ,name (stream ,@args)

-                (force-output (two-way-stream-output-stream stream))

                 (,fun (two-way-stream-input-stream stream) ,@args))))
   (in-fun two-way-in read-char eof-error-p eof-value)
   (in-fun two-way-bin read-byte eof-error-p eof-value)
                 (,fun (two-way-stream-input-stream stream) ,@args))))
   (in-fun two-way-in read-char eof-error-p eof-value)
   (in-fun two-way-bin read-byte eof-error-p eof-value)

@@ -1021,7 +1081,7 @@
                       (n-bin #'echo-n-bin))
             (:constructor %make-echo-stream (input-stream output-stream))
             (:copier nil))
                       (n-bin #'echo-n-bin))
             (:constructor %make-echo-stream (input-stream output-stream))
             (:copier nil))

-  unread-stuff)
+  (unread-stuff nil :type boolean))

 (def!method print-object ((x echo-stream) stream)
   (print-unreadable-object (x stream :type t :identity t)
     (format stream
 (def!method print-object ((x echo-stream) stream)
   (print-unreadable-object (x stream :type t :identity t)
     (format stream

@@ -1046,47 +1106,55 @@
 
 (macrolet ((in-fun (name in-fun out-fun &rest args)
              `(defun ,name (stream ,@args)
 
 (macrolet ((in-fun (name in-fun out-fun &rest args)
              `(defun ,name (stream ,@args)

-                (or (pop (echo-stream-unread-stuff stream))
-                    (let* ((in (echo-stream-input-stream stream))
-                           (out (echo-stream-output-stream stream))
-                           (result (if eof-error-p
-                                       (,in-fun in ,@args)
-                                       (,in-fun in nil in))))
-                      (cond
-                        ((eql result in) eof-value)
-                        (t (,out-fun result out) result)))))))
+                (let* ((unread-stuff-p (echo-stream-unread-stuff stream))
+                       (in (echo-stream-input-stream stream))
+                       (out (echo-stream-output-stream stream))
+                       (result (if eof-error-p
+                                   (,in-fun in ,@args)
+                                   (,in-fun in nil in))))
+                  (setf (echo-stream-unread-stuff stream) nil)
+                  (cond
+                    ((eql result in) eof-value)
+                    ;; If unread-stuff was true, the character read
+                    ;; from the input stream was previously echoed.
+                    (t (unless unread-stuff-p (,out-fun result out)) result))))))

   (in-fun echo-in read-char write-char eof-error-p eof-value)
   (in-fun echo-bin read-byte write-byte eof-error-p eof-value))
 
 (defun echo-n-bin (stream buffer start numbytes eof-error-p)
   (in-fun echo-in read-char write-char eof-error-p eof-value)
   (in-fun echo-bin read-byte write-byte eof-error-p eof-value))
 
 (defun echo-n-bin (stream buffer start numbytes eof-error-p)

-  (let ((new-start start)
-        (read 0))
-    (loop
-     (let ((thing (pop (echo-stream-unread-stuff stream))))
-       (cond
-         (thing
-          (setf (aref buffer new-start) thing)
-          (incf new-start)
-          (incf read)
-          (when (= read numbytes)
-            (return-from echo-n-bin numbytes)))
-         (t (return nil)))))
-    (let ((bytes-read (read-n-bytes (echo-stream-input-stream stream) buffer
-                                    new-start (- numbytes read) nil)))
-      (cond
-        ((not eof-error-p)
-         (write-sequence buffer (echo-stream-output-stream stream)
-                         :start new-start :end (+ new-start bytes-read))
-         (+ bytes-read read))
-        ((> numbytes (+ read bytes-read))
-         (write-sequence buffer (echo-stream-output-stream stream)
-                         :start new-start :end (+ new-start bytes-read))
-         (error 'end-of-file :stream stream))
-        (t
-         (write-sequence buffer (echo-stream-output-stream stream)
-                         :start new-start :end (+ new-start bytes-read))
-         (aver (= numbytes (+ new-start bytes-read)))
-         numbytes)))))
+  (let ((bytes-read 0))
+    ;; Note: before ca 1.0.27.18, the logic for handling unread
+    ;; characters never could have worked, so probably nobody has ever
+    ;; tried doing bivalent block I/O through an echo stream; this may
+    ;; not work either.
+    (when (echo-stream-unread-stuff stream)
+      (let* ((char (read-char stream))
+             (octets (string-to-octets
+                      (string char)
+                      :external-format
+                      (stream-external-format
+                       (echo-stream-input-stream stream))))
+             (octet-count (length octets))
+             (blt-count (min octet-count numbytes)))
+        (replace buffer octets :start1 start :end1 (+ start blt-count))
+        (incf start blt-count)
+        (decf numbytes blt-count)))
+    (incf bytes-read (read-n-bytes (echo-stream-input-stream stream) buffer
+                                   start numbytes nil))
+    (cond
+      ((not eof-error-p)
+       (write-sequence buffer (echo-stream-output-stream stream)
+                       :start start :end (+ start bytes-read))
+       bytes-read)
+      ((> numbytes bytes-read)
+       (write-sequence buffer (echo-stream-output-stream stream)
+                       :start start :end (+ start bytes-read))
+       (error 'end-of-file :stream stream))
+      (t
+       (write-sequence buffer (echo-stream-output-stream stream)
+                       :start start :end (+ start bytes-read))
+       (aver (= numbytes (+ start bytes-read)))
+       numbytes))))

 \f
 ;;;; STRING-INPUT-STREAM stuff
 
 \f
 ;;;; STRING-INPUT-STREAM stuff
 

@@ -1181,8 +1249,8 @@
   (declare (type string string)
            (type index start)
            (type (or index null) end))
   (declare (type string string)
            (type index start)
            (type (or index null) end))

-  (let* ((string (coerce string '(simple-array character (*))))
-         (end (%check-vector-sequence-bounds string start end)))
+  (let* ((string (coerce string '(simple-array character (*)))))
+    ;; FIXME: Why WITH-ARRAY-DATA, since the array is already simple?

     (with-array-data ((string string) (start start) (end end))
       (internal-make-string-input-stream
        string ;; now simple
     (with-array-data ((string string) (start start) (end end))
       (internal-make-string-input-stream
        string ;; now simple

@@ -1227,11 +1295,11 @@
   ;; Global location in the stream
   (index 0 :type index)
   ;; Index cache: when we move backwards we save the greater of this
   ;; Global location in the stream
   (index 0 :type index)
   ;; Index cache: when we move backwards we save the greater of this

-  ;; and index here, so the the greater of index and this is always
-  ;; the end of the stream.
+  ;; and index here, so the greater of index and this is always the
+  ;; end of the stream.

   (index-cache 0 :type index)
   ;; Requested element type
   (index-cache 0 :type index)
   ;; Requested element type

-  (element-type 'character))
+  (element-type 'character :type type-specifier))

 
 #!+sb-doc
 (setf (fdocumentation 'make-string-output-stream 'function)
 
 #!+sb-doc
 (setf (fdocumentation 'make-string-output-stream 'function)

@@ -1390,6 +1458,7 @@ benefit of the function GET-OUTPUT-STREAM-STRING.")
 
 (defun string-out-misc (stream operation &optional arg1 arg2)
   (declare (ignore arg2))
 
 (defun string-out-misc (stream operation &optional arg1 arg2)
   (declare (ignore arg2))

+  (declare (optimize speed))

   (case operation
     (:charpos
      ;; Keeping this first is a silly micro-optimization: FRESH-LINE
   (case operation
     (:charpos
      ;; Keeping this first is a silly micro-optimization: FRESH-LINE

@@ -1399,8 +1468,10 @@ benefit of the function GET-OUTPUT-STREAM-STRING.")
             (buffer (string-output-stream-buffer stream))
             (prev (string-output-stream-prev stream))
             (base 0))
             (buffer (string-output-stream-buffer stream))
             (prev (string-output-stream-prev stream))
             (base 0))

+        (declare (type (or null (simple-array character (*))) buffer))

       :next
       :next

-      (let ((pos (position #\newline buffer :from-end t :end pointer)))
+      (let ((pos (when buffer
+                   (position #\newline buffer :from-end t :end pointer))))

         (when (or pos (not buffer))
           ;; If newline is at index I, and pointer at index I+N, charpos
           ;; is N-1. If there is no newline, and pointer is at index N,
         (when (or pos (not buffer))
           ;; If newline is at index I, and pointer at index I+N, charpos
           ;; is N-1. If there is no newline, and pointer is at index N,

@@ -1460,14 +1531,20 @@ benefit of the function GET-OUTPUT-STREAM-STRING.")
     (flet ((replace-all (fun)
              (let ((start 0))
                (declare (index start))
     (flet ((replace-all (fun)
              (let ((start 0))
                (declare (index start))

-               (dolist (buffer (nreverse prev))
+               (setf prev (nreverse prev))
+               (dolist (buffer prev)

                  (funcall fun buffer start)
                  (incf start (length buffer)))
                (funcall fun this start)
                (incf start (length this))
                (dolist (buffer next)
                  (funcall fun buffer start)
                  (funcall fun buffer start)
                  (incf start (length buffer)))
                (funcall fun this start)
                (incf start (length this))
                (dolist (buffer next)
                  (funcall fun buffer start)

-                 (incf start (length buffer))))))
+                 (incf start (length buffer)))
+               ;; Hack: erase the pointers to strings, to make it less
+               ;; likely that the conservative GC will accidentally
+               ;; retain the buffers.
+               (fill prev nil)
+               (fill next nil))))

       (macrolet ((frob (type)
                    `(replace-all (lambda (buffer from)
                                    (declare (type ,type result)
       (macrolet ((frob (type)
                    `(replace-all (lambda (buffer from)
                                    (declare (type ,type result)

@@ -1490,11 +1567,16 @@ benefit of the function GET-OUTPUT-STREAM-STRING.")
 ;;; the CLM, but they are required for the implementation of
 ;;; WITH-OUTPUT-TO-STRING.
 
 ;;; the CLM, but they are required for the implementation of
 ;;; WITH-OUTPUT-TO-STRING.
 

-;;; FIXME: need to support (VECTOR BASE-CHAR) and (VECTOR NIL),
-;;; ideally without destroying all hope of efficiency.
+;;; FIXME: need to support (VECTOR NIL), ideally without destroying all hope
+;;; of efficiency.
+(declaim (inline vector-with-fill-pointer))
+(defun vector-with-fill-pointer-p (x)
+  (and (vectorp x)
+       (array-has-fill-pointer-p x)))
+

 (deftype string-with-fill-pointer ()
 (deftype string-with-fill-pointer ()

-  '(and (vector character)
-        (satisfies array-has-fill-pointer-p)))
+  `(and (or (vector character) (vector base-char))
+        (satisfies vector-with-fill-pointer-p)))

 
 (defstruct (fill-pointer-output-stream
             (:include ansi-stream
 
 (defstruct (fill-pointer-output-stream
             (:include ansi-stream

@@ -1512,53 +1594,63 @@ benefit of the function GET-OUTPUT-STREAM-STRING.")
          (current+1 (1+ current)))
     (declare (fixnum current))
     (with-array-data ((workspace buffer) (start) (end))
          (current+1 (1+ current)))
     (declare (fixnum current))
     (with-array-data ((workspace buffer) (start) (end))

-      (declare (type (simple-array character (*)) workspace))
-      (let ((offset-current (+ start current)))
-        (declare (fixnum offset-current))
-        (if (= offset-current end)
-            (let* ((new-length (1+ (* current 2)))
-                   (new-workspace (make-string new-length)))
-              (declare (type (simple-array character (*)) new-workspace))
-              (replace new-workspace workspace
-                       :start2 start :end2 offset-current)
-              (setf workspace new-workspace
-                    offset-current current)
-              (set-array-header buffer workspace new-length
-                                current+1 0 new-length nil))
-            (setf (fill-pointer buffer) current+1))
-        (setf (schar workspace offset-current) character)))
+      (string-dispatch
+          ((simple-array character (*))
+           (simple-array base-char (*)))
+          workspace
+        (let ((offset-current (+ start current)))
+          (declare (fixnum offset-current))
+          (if (= offset-current end)
+              (let* ((new-length (1+ (* current 2)))
+                     (new-workspace
+                      (ecase (array-element-type workspace)
+                        (character (make-string new-length
+                                                :element-type 'character))
+                        (base-char (make-string new-length
+                                                :element-type 'base-char)))))
+                (replace new-workspace workspace :start2 start :end2 offset-current)
+                (setf workspace new-workspace
+                      offset-current current)
+                (set-array-header buffer workspace new-length
+                                  current+1 0 new-length nil nil))
+              (setf (fill-pointer buffer) current+1))
+          (setf (char workspace offset-current) character))))

     current+1))
 
 (defun fill-pointer-sout (stream string start end)
     current+1))
 
 (defun fill-pointer-sout (stream string start end)

-  (declare (simple-string string) (fixnum start end))
-  (let* ((string (if (typep string '(simple-array character (*)))
-                     string
-                     (coerce string '(simple-array character (*)))))
-         (buffer (fill-pointer-output-stream-string stream))
-         (current (fill-pointer buffer))
-         (string-len (- end start))
-         (dst-end (+ string-len current)))
-    (declare (fixnum current dst-end string-len))
-    (with-array-data ((workspace buffer) (dst-start) (dst-length))
-      (declare (type (simple-array character (*)) workspace))
-      (let ((offset-dst-end (+ dst-start dst-end))
-            (offset-current (+ dst-start current)))
-        (declare (fixnum offset-dst-end offset-current))
-        (if (> offset-dst-end dst-length)
-            (let* ((new-length (+ (the fixnum (* current 2)) string-len))
-                   (new-workspace (make-string new-length)))
-              (declare (type (simple-array character (*)) new-workspace))
-              (replace new-workspace workspace
-                       :start2 dst-start :end2 offset-current)
-              (setf workspace new-workspace
-                    offset-current current
-                    offset-dst-end dst-end)
-              (set-array-header buffer workspace new-length
-                                dst-end 0 new-length nil))
-            (setf (fill-pointer buffer) dst-end))
-        (replace workspace string
-                 :start1 offset-current :start2 start :end2 end)))
-    dst-end))
+  (declare (fixnum start end))
+  (string-dispatch
+      ((simple-array character (*))
+       (simple-array base-char (*)))
+      string
+    (let* ((buffer (fill-pointer-output-stream-string stream))
+           (current (fill-pointer buffer))
+           (string-len (- end start))
+           (dst-end (+ string-len current)))
+      (declare (fixnum current dst-end string-len))
+      (with-array-data ((workspace buffer) (dst-start) (dst-length))
+        (let ((offset-dst-end (+ dst-start dst-end))
+              (offset-current (+ dst-start current)))
+          (declare (fixnum offset-dst-end offset-current))
+          (if (> offset-dst-end dst-length)
+              (let* ((new-length (+ (the fixnum (* current 2)) string-len))
+                     (new-workspace
+                      (ecase (array-element-type workspace)
+                        (character (make-string new-length
+                                                :element-type 'character))
+                        (base-char (make-string new-length
+                                                :element-type 'base-char)))))
+                (replace new-workspace workspace
+                         :start2 dst-start :end2 offset-current)
+                (setf workspace new-workspace
+                      offset-current current
+                      offset-dst-end dst-end)
+                (set-array-header buffer workspace new-length
+                                  dst-end 0 new-length nil nil))
+              (setf (fill-pointer buffer) dst-end))
+          (replace workspace string
+                   :start1 offset-current :start2 start :end2 end)))
+      dst-end)))

 
 (defun fill-pointer-misc (stream operation &optional arg1 arg2)
   (declare (ignore arg2))
 
 (defun fill-pointer-misc (stream operation &optional arg1 arg2)
   (declare (ignore arg2))

@@ -1592,93 +1684,9 @@ benefit of the function GET-OUTPUT-STREAM-STRING.")
            (if found
                (- end (the fixnum found))
                current)))))
            (if found
                (- end (the fixnum found))
                current)))))

-     (:element-type (array-element-type
-                     (fill-pointer-output-stream-string stream)))))
-\f
-;;;; indenting streams
-
-(defstruct (indenting-stream (:include ansi-stream
-                                       (out #'indenting-out)
-                                       (sout #'indenting-sout)
-                                       (misc #'indenting-misc))
-                             (:constructor make-indenting-stream (stream))
-                             (:copier nil))
-  ;; the stream we're based on
-  stream
-  ;; how much we indent on each line
-  (indentation 0))
-
-#!+sb-doc
-(setf (fdocumentation 'make-indenting-stream 'function)
- "Return an output stream which indents its output by some amount.")
-
-;;; INDENTING-INDENT writes the correct number of spaces needed to indent
-;;; output on the given STREAM based on the specified SUB-STREAM.
-(defmacro indenting-indent (stream sub-stream)
-  ;; KLUDGE: bare magic number 60
-  `(do ((i 0 (+ i 60))
-        (indentation (indenting-stream-indentation ,stream)))
-       ((>= i indentation))
-     (%write-string
-      #.(make-string 60 :initial-element #\Space)
-      ,sub-stream
-      0
-      (min 60 (- indentation i)))))
-
-;;; INDENTING-OUT writes a character to an indenting stream.
-(defun indenting-out (stream char)
-  (let ((sub-stream (indenting-stream-stream stream)))
-    (write-char char sub-stream)
-    (if (char= char #\newline)
-        (indenting-indent stream sub-stream))))
-
-;;; INDENTING-SOUT writes a string to an indenting stream.
-(defun indenting-sout (stream string start end)
-  (declare (simple-string string) (fixnum start end))
-  (do ((i start)
-       (sub-stream (indenting-stream-stream stream)))
-      ((= i end))
-    (let ((newline (position #\newline string :start i :end end)))
-      (cond (newline
-             (%write-string string sub-stream i (1+ newline))
-             (indenting-indent stream sub-stream)
-             (setq i (+ newline 1)))
-            (t
-             (%write-string string sub-stream i end)
-             (setq i end))))))
-
-;;; INDENTING-MISC just treats just the :LINE-LENGTH message
-;;; differently. INDENTING-CHARPOS says the charpos is the charpos of
-;;; the base stream minus the stream's indentation.
-(defun indenting-misc (stream operation &optional arg1 arg2)
-  (let ((sub-stream (indenting-stream-stream stream)))
-    (if (ansi-stream-p sub-stream)
-        (let ((method (ansi-stream-misc sub-stream)))
-          (case operation
-            (:line-length
-             (let ((line-length (funcall method sub-stream operation)))
-               (if line-length
-                   (- line-length (indenting-stream-indentation stream)))))
-            (:charpos
-             (let ((charpos (funcall method sub-stream operation)))
-               (if charpos
-                   (- charpos (indenting-stream-indentation stream)))))
-            (t
-             (funcall method sub-stream operation arg1 arg2))))
-        ;; must be Gray streams FUNDAMENTAL-STREAM
-        (case operation
-          (:line-length
-           (let ((line-length (stream-line-length sub-stream)))
-             (if line-length
-                 (- line-length (indenting-stream-indentation stream)))))
-          (:charpos
-           (let ((charpos (stream-line-column sub-stream)))
-             (if charpos
-                 (- charpos (indenting-stream-indentation stream)))))
-          (t
-           (stream-misc-dispatch sub-stream operation arg1 arg2))))))
-
-(declaim (maybe-inline read-char unread-char read-byte listen))
+     (:element-type
+      (array-element-type
+       (fill-pointer-output-stream-string stream)))))

 \f
 ;;;; case frobbing streams, used by FORMAT ~(...~)
 
 \f
 ;;;; case frobbing streams, used by FORMAT ~(...~)
 

@@ -1969,34 +1977,86 @@ benefit of the function GET-OUTPUT-STREAM-STRING.")
                (return i))
              (setf (first rem) el)))))
       (vector
                (return i))
              (setf (first rem) el)))))
       (vector

-       (with-array-data ((data seq) (offset-start start) (offset-end end))
-         (if (compatible-vector-and-stream-element-types-p data stream)
-             (let* ((numbytes (- end start))
-                    (bytes-read (read-n-bytes stream data offset-start
-                                              numbytes nil)))
-               (if (< bytes-read numbytes)
-                   (+ start bytes-read)
-                   end))
-             (let ((read-function
-                    (if (subtypep (stream-element-type stream) 'character)
-                        ;; If the stream-element-type is CHARACTER,
-                        ;; this might be a bivalent stream. If the
-                        ;; sequence is a specialized unsigned-byte
-                        ;; vector, try to read use binary IO. It'll
-                        ;; signal an error if stream is an pure
-                        ;; character stream.
-                        (if (subtypep (array-element-type data)
-                                      'unsigned-byte)
-                            #'ansi-stream-read-byte
-                            #'ansi-stream-read-char)
-                        #'ansi-stream-read-byte)))
-               (do ((i offset-start (1+ i)))
-                   ((>= i offset-end) end)
-                 (declare (type index i))
-                 (let ((el (funcall read-function stream nil :eof nil)))
-                   (when (eq el :eof)
-                     (return (+ start (- i offset-start))))
-                   (setf (aref data i) el))))))))))
+       (with-array-data ((data seq) (offset-start start) (offset-end end)
+                         :check-fill-pointer t)
+         (cond ((compatible-vector-and-stream-element-types-p data stream)
+                (let* ((numbytes (- end start))
+                       (bytes-read (read-n-bytes stream data offset-start
+                                                 numbytes nil)))
+                  (if (< bytes-read numbytes)
+                      (+ start bytes-read)
+                      end)))
+               ((and (ansi-stream-cin-buffer stream)
+                     (typep seq 'simple-string))
+                (ansi-stream-read-string-from-frc-buffer seq stream
+                                                         start %end))
+               (t
+                (let ((read-function
+                       (if (subtypep (stream-element-type stream) 'character)
+                           ;; If the stream-element-type is CHARACTER,
+                           ;; this might be a bivalent stream. If the
+                           ;; sequence is a specialized unsigned-byte
+                           ;; vector, try to read use binary IO. It'll
+                           ;; signal an error if stream is an pure
+                           ;; character stream.
+                           (if (subtypep (array-element-type data)
+                                         'unsigned-byte)
+                               #'ansi-stream-read-byte
+                               #'ansi-stream-read-char)
+                           #'ansi-stream-read-byte)))
+                  (do ((i offset-start (1+ i)))
+                      ((>= i offset-end) end)
+                    (declare (type index i))
+                    (let ((el (funcall read-function stream nil :eof nil)))
+                      (when (eq el :eof)
+                        (return (+ start (- i offset-start))))
+                      (setf (aref data i) el)))))))))))
+
+(defun ansi-stream-read-string-from-frc-buffer (seq stream start %end)
+  (declare (type simple-string seq)
+           (type ansi-stream stream)
+           (type index start)
+           (type (or null index) %end))
+  (let ((needed (- (or %end (length seq))
+                   start))
+        (read 0))
+    (prepare-for-fast-read-char stream
+      (declare (ignore %frc-method%))
+      (unless %frc-buffer%
+        (return-from ansi-stream-read-string-from-frc-buffer nil))
+      (labels ((refill-buffer ()
+                 (prog1
+                     (fast-read-char-refill stream nil nil)
+                   (setf %frc-index% (ansi-stream-in-index %frc-stream%))))
+               (add-chunk ()
+                 (let* ((end (length %frc-buffer%))
+                        (len (min (- end %frc-index%)
+                                  (- needed read))))
+                   (declare (type index end len read needed))
+                   (string-dispatch (simple-base-string
+                                     (simple-array character (*)))
+                       seq
+                     (replace seq %frc-buffer%
+                              :start1 (+ start read)
+                              :end1 (+ start read len)
+                              :start2 %frc-index%
+                              :end2 (+ %frc-index% len)))
+                   (incf read len)
+                   (incf %frc-index% len)
+                   (when (or (eql needed read)
+                             (refill-buffer))
+                     (done-with-fast-read-char)
+                     (return-from ansi-stream-read-string-from-frc-buffer
+                       (+ start read))))))
+        (declare (inline refill-buffer))
+        (when (and (= %frc-index% +ansi-stream-in-buffer-length+)
+                   (refill-buffer))
+          ;; EOF had been reached before we read anything
+          ;; at all. Return the EOF value or signal the error.
+          (done-with-fast-read-char)
+          (return-from ansi-stream-read-string-from-frc-buffer start))
+        (loop (add-chunk))))))
+

 \f
 ;;;; WRITE-SEQUENCE
 
 \f
 ;;;; WRITE-SEQUENCE
 

@@ -2036,7 +2096,8 @@ benefit of the function GET-OUTPUT-STREAM-STRING.")
       (string
        (%write-string seq stream start end))
       (vector
       (string
        (%write-string seq stream start end))
       (vector

-       (with-array-data ((data seq) (offset-start start) (offset-end end))
+       (with-array-data ((data seq) (offset-start start) (offset-end end)
+                         :check-fill-pointer t)

          (labels
              ((output-seq-in-loop ()
                 (let ((write-function
          (labels
              ((output-seq-in-loop ()
                 (let ((write-function

@@ -2058,7 +2119,7 @@ benefit of the function GET-OUTPUT-STREAM-STRING.")
                     (funcall write-function stream (aref data i))))))
            (if (and (fd-stream-p stream)
                     (compatible-vector-and-stream-element-types-p data stream))
                     (funcall write-function stream (aref data i))))))
            (if (and (fd-stream-p stream)
                     (compatible-vector-and-stream-element-types-p data stream))

-               (output-raw-bytes stream data offset-start offset-end)
+               (buffer-output stream data offset-start offset-end)

                (output-seq-in-loop)))))))
   seq)
 \f
                (output-seq-in-loop)))))))
   seq)
 \f