Fix typos in docstrings and function names.

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

diff --git a/src/code/stream.lisp b/src/code/stream.lisp
index 4f69d9d..2bc1aa7 100644 (file)
--- a/src/code/stream.lisp
+++ b/src/code/stream.lisp
@@ -53,7 +53,7 @@
          :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
 (defun no-op-placeholder (&rest ignore)
   (declare (ignore ignore)))
 \f

@@ -128,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))

@@ -142,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

@@ -156,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)

@@ -263,7 +265,7 @@
                               :start2 %frc-index% :end2 pos)
                      (setf %frc-index% (1+ pos)))
                    (done-with-fast-read-char)
                               :start2 %frc-index% :end2 pos)
                      (setf %frc-index% (1+ pos)))
                    (done-with-fast-read-char)

-                   (return-from ansi-stream-read-line-from-frc-buffer res)))
+                   (return-from ansi-stream-read-line-from-frc-buffer (values res (null pos)))))

                (add-chunk ()
                  (let* ((end (length %frc-buffer%))
                         (len (- end %frc-index%))
                (add-chunk ()
                  (let* ((end (length %frc-buffer%))
                         (len (- end %frc-index%))

@@ -273,7 +275,8 @@
                    (incf chunks-total-length len)
                    (when (refill-buffer)
                      (make-and-return-result-string nil)))))
                    (incf chunks-total-length len)
                    (when (refill-buffer)
                      (make-and-return-result-string nil)))))

-        (declare (inline make-and-return-result-string))
+        (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
         (when (and (= %frc-index% +ansi-stream-in-buffer-length+)
                    (refill-buffer))
           ;; EOF had been reached before we read anything

@@ -438,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)

@@ -542,22 +543,27 @@
            ;; 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
            ;; 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
-           ;; single-character 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.
-           (let* ((value (funcall (ansi-stream-in stream) stream nil :eof))
-                  (index (1- +ansi-stream-in-buffer-length+)))
-             (case value
-               ((:eof)
-                ;; Mark buffer as empty.
+           ;; 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+)
                 (setf (ansi-stream-in-index stream)
                       +ansi-stream-in-buffer-length+)

-                ;; EOF. Redo the read, this time with the real eof parameters.
-                (values t (funcall (ansi-stream-in stream)
-                                   stream eof-error-p eof-value)))
-               (otherwise
+                (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
                 (setf (aref ibuf index) value)
                 (values nil (setf (ansi-stream-in-index stream) index))))))
           (t

@@ -620,57 +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))

   (with-array-data ((data string) (offset-start start)
                     (offset-end end)
                     :check-fill-pointer t)
     (funcall (ansi-stream-sout stream)
   (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))
-  string)
+             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*))

@@ -692,7 +687,7 @@
 
 (defun clear-output (&optional (stream *standard-output*))
   (with-out-stream stream (ansi-stream-misc :clear-output)
 
 (defun clear-output (&optional (stream *standard-output*))
   (with-out-stream stream (ansi-stream-misc :clear-output)

-                   (stream-force-output))
+                   (stream-clear-output))

   nil)
 
 (defun write-byte (integer stream)
   nil)
 
 (defun write-byte (integer stream)

@@ -944,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)

@@ -1087,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

@@ -1112,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
 

@@ -1297,7 +1299,7 @@
   ;; end of the stream.
   (index-cache 0 :type index)
   ;; Requested element type
   ;; end of the stream.
   (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)

@@ -1456,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

@@ -1465,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,

@@ -1526,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)

@@ -1556,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

@@ -1578,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))

@@ -1658,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 ~(...~)
 

@@ -2105,13 +2047,14 @@ benefit of the function GET-OUTPUT-STREAM-STRING.")
                              (refill-buffer))
                      (done-with-fast-read-char)
                      (return-from ansi-stream-read-string-from-frc-buffer
                              (refill-buffer))
                      (done-with-fast-read-char)
                      (return-from ansi-stream-read-string-from-frc-buffer

-                       read)))))
+                       (+ 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)
         (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 0))
+          (return-from ansi-stream-read-string-from-frc-buffer start))

         (loop (add-chunk))))))
 
 \f
         (loop (add-chunk))))))
 
 \f