X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=88b2f987018999e01aa8d7d58da1d66988e05778;hb=8643c93d4db277f6e1cb880a42407ff29e19f618;hp=1f43db72f981b90d01037525ee70f70e8393df53;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git

diff --git a/src/code/stream.lisp b/src/code/stream.lisp
index 1f43db7..88b2f98 100644
--- a/src/code/stream.lisp
+++ b/src/code/stream.lisp
@@ -150,6 +150,8 @@
   (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: This doesn't look interrupt safe.
   (cond
     (position
      (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
@@ -157,13 +159,29 @@
     (t
      (let ((res (funcall (ansi-stream-misc stream) stream :file-position nil)))
        (when res
+         #!-sb-unicode
          (- res
             (- +ansi-stream-in-buffer-length+
-               (ansi-stream-in-index stream))))))))
-
+               (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)))
+           (- 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)))))))))))
 
 (defun file-position (stream &optional position)
-  (ansi-stream-file-position stream position))
+  (if (ansi-stream-p stream)
+      (ansi-stream-file-position stream position)
+      (stream-file-position stream position)))
 
 ;;; This is a literal translation of the ANSI glossary entry "stream
 ;;; associated with a file".
@@ -223,33 +241,50 @@
 (defun ansi-stream-read-line (stream eof-error-p eof-value recursive-p)
   (declare (ignore recursive-p))
   (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)))))))))
+    ;; 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)))))))))
 
 (defun read-line (&optional (stream *standard-input*) (eof-error-p t) eof-value
                             recursive-p)
@@ -371,14 +406,13 @@
       (done-with-fast-read-byte))))
 
 (defun read-byte (stream &optional (eof-error-p t) eof-value)
-  (let ((stream (in-synonym-of stream)))
-    (if (ansi-stream-p stream)
-        (ansi-stream-read-byte stream eof-error-p eof-value nil)
-        ;; must be Gray streams FUNDAMENTAL-STREAM
-        (let ((char (stream-read-byte stream)))
-          (if (eq char :eof)
-              (eof-or-lose stream eof-error-p eof-value)
-              char)))))
+  (if (ansi-stream-p stream)
+      (ansi-stream-read-byte stream eof-error-p eof-value nil)
+      ;; must be Gray streams FUNDAMENTAL-STREAM
+      (let ((char (stream-read-byte stream)))
+        (if (eq char :eof)
+            (eof-or-lose stream eof-error-p eof-value)
+            char))))
 
 ;;; Read NUMBYTES bytes into BUFFER beginning at START, and return the
 ;;; number of bytes read.
@@ -596,8 +630,8 @@
   nil)
 
 (defun write-byte (integer stream)
-  (with-out-stream stream (ansi-stream-bout integer)
-                   (stream-write-byte integer))
+  (with-out-stream/no-synonym stream (ansi-stream-bout integer)
+                              (stream-write-byte integer))
   integer)
 
 
@@ -1102,14 +1136,14 @@
             (truly-the index (+ index copy)))
       ;; FIXME: why are we VECTOR-SAP'ing things here?  what's the point?
       ;; and are there SB-UNICODE issues here as well?  --njf, 2005-03-24
-      (sb!sys:without-gcing
-       (system-area-ub8-copy (vector-sap string)
-                             index
-                             (if (typep buffer 'system-area-pointer)
-                                 buffer
-                                 (vector-sap buffer))
-                             start
-                             copy)))
+      (with-pinned-objects (string buffer)
+        (system-area-ub8-copy (vector-sap string)
+                              index
+                              (if (typep buffer 'system-area-pointer)
+                                  buffer
+                                  (vector-sap buffer))
+                              start
+                              copy)))
     (if (and (> requested copy) eof-error-p)
         (error 'end-of-file :stream stream)
         copy)))
@@ -1156,7 +1190,22 @@
        end))))
 
 ;;;; STRING-OUTPUT-STREAM stuff
+;;;;
+;;;; FIXME: This, like almost none of the stream code is particularly
+;;;; interrupt or thread-safe. While it should not be possible to
+;;;; corrupt the heap here, it certainly is possible to end up with
+;;;; a string-output-stream whose internal state is messed up.
+;;;;
+;;;; FIXME: It would be nice to support space-efficient
+;;;; string-output-streams with element-type base-char. This would
+;;;; mean either a separate subclass, or typecases in functions.
+
+(defparameter *string-output-stream-buffer-initial-size* 64)
 
+#!-sb-fluid
+(declaim (inline string-output-string-stream-buffer
+                 string-output-string-stream-pointer
+                 string-output-string-stream-index))
 (defstruct (string-output-stream
             (:include ansi-stream
                       (out #'string-ouch)
@@ -1164,136 +1213,276 @@
                       (misc #'string-out-misc))
             (:constructor make-string-output-stream
                           (&key (element-type 'character)
-                           &aux (string (make-string 40))))
+                           &aux (buffer
+                                 (make-string
+                                  *string-output-stream-buffer-initial-size*))))
             (:copier nil))
   ;; The string we throw stuff in.
-  (string (missing-arg) :type (simple-array character (*)))
-  ;; Index of the next location to use.
-  (index 0 :type fixnum)
-  ;; Index cache for string-output-stream-last-index
-  (index-cache 0 :type fixnum)
+  (buffer (missing-arg) :type (simple-array character (*)))
+  ;; Chains of buffers to use
+  (prev nil)
+  (next nil)
+  ;; Index of the next location to use in the current string.
+  (pointer 0 :type index)
+  ;; 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 greater of index and this is always the
+  ;; end of the stream.
+  (index-cache 0 :type index)
   ;; Requested element type
   (element-type 'character))
 
 #!+sb-doc
 (setf (fdocumentation 'make-string-output-stream 'function)
-  "Return an output stream which will accumulate all output given it for
-   the benefit of the function GET-OUTPUT-STREAM-STRING.")
-
-(defun string-output-stream-last-index (stream)
-  (max (string-output-stream-index stream)
-       (string-output-stream-index-cache stream)))
+  "Return an output stream which will accumulate all output given it for the
+benefit of the function GET-OUTPUT-STREAM-STRING.")
+
+;;; Pushes the current segment onto the prev-list, and either pops
+;;; or allocates a new one.
+(defun string-output-stream-new-buffer (stream size)
+  (declare (index size))
+  (/show0 "/string-output-stream-new-buffer")
+  (push (string-output-stream-buffer stream)
+        (string-output-stream-prev stream))
+  (setf (string-output-stream-buffer stream)
+        (or (pop (string-output-stream-next stream))
+            ;; FIXME: This would be the correct place to detect that
+            ;; more then FIXNUM characters are being written to the
+            ;; stream, and do something about it.
+            (make-string size))))
+
+;;; Moves to the end of the next segment or the current one if there are
+;;; no more segments. Returns true as long as there are next segments.
+(defun string-output-stream-next-buffer (stream)
+  (/show0 "/string-output-stream-next-buffer")
+  (let* ((old (string-output-stream-buffer stream))
+         (new (pop (string-output-stream-next stream)))
+         (old-size (length old))
+         (skipped (- old-size (string-output-stream-pointer stream))))
+    (cond (new
+           (let ((new-size (length new)))
+             (push old (string-output-stream-prev stream))
+             (setf (string-output-stream-buffer stream) new
+                   (string-output-stream-pointer stream) new-size)
+             (incf (string-output-stream-index stream) (+ skipped new-size)))
+           t)
+          (t
+           (setf (string-output-stream-pointer stream) old-size)
+           (incf (string-output-stream-index stream) skipped)
+           nil))))
+
+;;; Moves to the start of the previous segment or the current one if there
+;;; are no more segments. Returns true as long as there are prev segments.
+(defun string-output-stream-prev-buffer (stream)
+  (/show0 "/string-output-stream-prev-buffer")
+  (let ((old (string-output-stream-buffer stream))
+        (new (pop (string-output-stream-prev stream)))
+        (skipped (string-output-stream-pointer stream)))
+    (cond (new
+           (push old (string-output-stream-next stream))
+           (setf (string-output-stream-buffer stream) new
+                 (string-output-stream-pointer stream) 0)
+           (decf (string-output-stream-index stream) (+ skipped (length new)))
+           t)
+          (t
+           (setf (string-output-stream-pointer stream) 0)
+           (decf (string-output-stream-index stream) skipped)
+           nil))))
 
 (defun string-ouch (stream character)
-  (let ((current (string-output-stream-index stream))
-        (workspace (string-output-stream-string stream)))
-    (declare (type (simple-array character (*)) workspace)
-             (type fixnum current))
-    (if (= current (the fixnum (length workspace)))
-        (let ((new-workspace (make-string (* current 2))))
-          (replace new-workspace workspace)
-          (setf (aref new-workspace current) character
-                (string-output-stream-string stream) new-workspace))
-        (setf (aref workspace current) character))
-    (setf (string-output-stream-index stream) (1+ current))))
+  (/show0 "/string-ouch")
+  (let ((pointer (string-output-stream-pointer stream))
+        (buffer (string-output-stream-buffer stream))
+        (index (string-output-stream-index stream)))
+    (cond ((= pointer (length buffer))
+           (setf buffer (string-output-stream-new-buffer stream index)
+                 (aref buffer 0) character
+                 (string-output-stream-pointer stream) 1))
+          (t
+           (setf (aref buffer pointer) character
+                 (string-output-stream-pointer stream) (1+ pointer))))
+    (setf (string-output-stream-index stream) (1+ index))))
 
 (defun string-sout (stream string start end)
   (declare (type simple-string string)
-           (type fixnum start end))
-  (let* ((string (if (typep string '(simple-array character (*)))
-                     string
-                     (coerce string '(simple-array character (*)))))
-         (current (string-output-stream-index stream))
-         (length (- end start))
-         (dst-end (+ length current))
-         (workspace (string-output-stream-string stream)))
-    (declare (type (simple-array character (*)) workspace string)
-             (type fixnum current length dst-end))
-    (if (> dst-end (the fixnum (length workspace)))
-        (let ((new-workspace (make-string (+ (* current 2) length))))
-          (replace new-workspace workspace :end2 current)
-          (replace new-workspace string
-                   :start1 current :end1 dst-end
-                   :start2 start :end2 end)
-          (setf (string-output-stream-string stream) new-workspace))
-        (replace workspace string
-                 :start1 current :end1 dst-end
-                 :start2 start :end2 end))
-    (setf (string-output-stream-index stream) dst-end)))
+           (type index start end))
+  (let* ((full-length (- end start))
+         (length full-length)
+         (buffer (string-output-stream-buffer stream))
+         (pointer (string-output-stream-pointer stream))
+         (space (- (length buffer) pointer))
+         (here (min space length))
+         (stop (+ start here))
+         (overflow (- length space)))
+    (declare (index length space here stop full-length)
+             (fixnum overflow)
+             (type (simple-array character (*)) buffer))
+    (tagbody
+     :more
+       (when (plusp here)
+         (etypecase string
+           ((simple-array character (*))
+            (replace buffer string :start1 pointer :start2 start :end2 stop))
+           (simple-base-string
+            (replace buffer string :start1 pointer :start2 start :end2 stop))
+           ((simple-array nil (*))
+            (replace buffer string :start1 pointer :start2 start :end2 stop)))
+         (setf (string-output-stream-pointer stream) (+ here pointer)))
+       (when (plusp overflow)
+         (setf start stop
+               length (- end start)
+               buffer (string-output-stream-new-buffer
+                       stream (max overflow (string-output-stream-index stream)))
+               pointer 0
+               space (length buffer)
+               here (min space length)
+               stop (+ start here)
+               ;; there may be more overflow if we used a buffer
+               ;; already allocated to the stream
+               overflow (- length space))
+         (go :more)))
+    (incf (string-output-stream-index stream) full-length)))
+
+;;; Factored out of the -misc method due to size.
+(defun set-string-output-stream-file-position (stream pos)
+  (let* ((index (string-output-stream-index stream))
+         (end (max index (string-output-stream-index-cache stream))))
+    (declare (index index end))
+    (setf (string-output-stream-index-cache stream) end)
+    (cond ((eq :start pos)
+           (loop while (string-output-stream-prev-buffer stream)))
+          ((eq :end pos)
+           (loop while (string-output-stream-next-buffer stream))
+           (let ((over (- (string-output-stream-index stream) end)))
+             (decf (string-output-stream-pointer stream) over))
+           (setf (string-output-stream-index stream) end))
+          ((< pos index)
+           (loop while (< pos index)
+                 do (string-output-stream-prev-buffer stream)
+                 (setf index (string-output-stream-index stream)))
+           (let ((step (- pos index)))
+             (incf (string-output-stream-pointer stream) step)
+             (setf (string-output-stream-index stream) pos)))
+          ((> pos index)
+           ;; We allow moving beyond the end of stream, implicitly
+           ;; extending the output stream.
+           (let ((next (string-output-stream-next-buffer stream)))
+             ;; Update after -next-buffer, INDEX is kept pointing at
+             ;; the end of the current buffer.
+             (setf index (string-output-stream-index stream))
+             (loop while (and next (> pos index))
+                   do (setf next (string-output-stream-next-buffer stream)
+                            index (string-output-stream-index stream))))
+           ;; Allocate new buffer if needed, or step back to
+           ;; the desired index and set pointer and index
+           ;; correctly.
+           (let ((diff (- pos index)))
+             (if (plusp diff)
+                 (let* ((new (string-output-stream-new-buffer stream diff))
+                        (size (length new)))
+                   (aver (= pos (+ index size)))
+                   (setf (string-output-stream-pointer stream) size
+                         (string-output-stream-index stream) pos))
+                 (let ((size (length (string-output-stream-buffer stream))))
+                   (setf (string-output-stream-pointer stream) (+ size diff)
+                         (string-output-stream-index stream) pos))))))))
 
 (defun string-out-misc (stream operation &optional arg1 arg2)
   (declare (ignore arg2))
   (case operation
-    (:file-position
-     (if arg1
-         (let ((end (string-output-stream-last-index stream)))
-           (setf (string-output-stream-index-cache stream) end
-                 (string-output-stream-index stream)
-                 (case arg1
-                   (:start 0)
-                   (:end end)
-                   (t
-                    ;; We allow moving beyond the end of stream,
-                    ;; implicitly extending the output stream.
-                    (let ((buffer (string-output-stream-string stream)))
-                      (when (> arg1 (length buffer))
-                        (setf (string-output-stream-string stream)
-                              (make-string
-                               arg1 :element-type (array-element-type buffer))
-                              (subseq (string-output-stream-string stream)
-                                      0 end)
-                              (subseq buffer 0 end))))
-                      arg1))))
-         (string-output-stream-index stream)))
-    (:close (set-closed-flame stream))
     (:charpos
-     (do ((index (1- (the fixnum (string-output-stream-index stream)))
-                 (1- index))
-          (count 0 (1+ count))
-          (string (string-output-stream-string stream)))
-         ((< index 0) count)
-       (declare (type (simple-array character (*)) string)
-                (type fixnum index count))
-       (if (char= (schar string index) #\newline)
-           (return count))))
-    (:element-type (array-element-type (string-output-stream-string stream)))))
+     ;; Keeping this first is a silly micro-optimization: FRESH-LINE
+     ;; makes this the most common one.
+     (/show0 "/string-out-misc charpos")
+     (prog ((pointer (string-output-stream-pointer stream))
+            (buffer (string-output-stream-buffer stream))
+            (prev (string-output-stream-prev stream))
+            (base 0))
+      :next
+      (let ((pos (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,
+          ;; charpos is N.
+          (return (+ base (if pos (- pointer pos 1) pointer))))
+        (setf base (+ base pointer)
+              buffer (pop prev)
+              pointer (length buffer))
+        (/show0 "/string-out-misc charpos next")
+        (go :next))))
+    (:file-position
+     (/show0 "/string-out-misc file-position")
+     (when arg1
+       (set-string-output-stream-file-position stream arg1))
+     (string-output-stream-index stream))
+    (:close
+     (/show0 "/string-out-misc close")
+     (set-closed-flame stream))
+    (:element-type (string-output-stream-element-type stream))))
 
 ;;; Return a string of all the characters sent to a stream made by
 ;;; MAKE-STRING-OUTPUT-STREAM since the last call to this function.
 (defun get-output-stream-string (stream)
   (declare (type string-output-stream stream))
-  (let* ((length (string-output-stream-last-index stream))
+  (let* ((length (max (string-output-stream-index stream)
+                      (string-output-stream-index-cache stream)))
          (element-type (string-output-stream-element-type stream))
+         (prev (string-output-stream-prev stream))
+         (this (string-output-stream-buffer stream))
+         (next (string-output-stream-next stream))
          (result
           (case element-type
             ;; overwhelmingly common case: can be inlined
+            ;;
+            ;; FIXME: If we were willing to use %SHRINK-VECTOR here,
+            ;; and allocate new strings the size of 2 * index in
+            ;; STRING-SOUT, we would not need to allocate one here in
+            ;; the common case, but could just use the last one
+            ;; allocated, and chop it down to size..
+            ;;
             ((character) (make-string length))
             ;; slightly less common cases: inline it anyway
             ((base-char standard-char)
              (make-string length :element-type 'base-char))
-            (t (make-string length :element-type element-type)))))
-    ;; For the benefit of the REPLACE transform, let's do this, so
-    ;; that the common case isn't ludicrously expensive.
-    (etypecase result
-      ((simple-array character (*))
-       (replace result (string-output-stream-string stream)))
-      (simple-base-string
-       (replace result (string-output-stream-string stream)))
-      ((simple-array nil (*))
-       (replace result (string-output-stream-string stream))))
+            (t
+             (make-string length :element-type element-type)))))
+
     (setf (string-output-stream-index stream) 0
-          (string-output-stream-index-cache stream) 0)
-    result))
+          (string-output-stream-index-cache stream) 0
+          (string-output-stream-pointer stream) 0
+          ;; throw them away for simplicity's sake: this way the rest of the
+          ;; implementation can assume that the greater of INDEX and INDEX-CACHE
+          ;; is always within the last buffer.
+          (string-output-stream-prev stream) nil
+          (string-output-stream-next stream) nil)
+
+    (flet ((replace-all (fun)
+             (let ((start 0))
+               (declare (index start))
+               (dolist (buffer (nreverse prev))
+                 (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))))))
+      (macrolet ((frob (type)
+                   `(replace-all (lambda (buffer from)
+                                   (declare (type ,type result)
+                                            (type (simple-array character (*))
+                                                  buffer))
+                                   (replace result buffer :start1 from)))))
+        (etypecase result
+          ((simple-array character (*))
+           (frob (simple-array character (*))))
+          (simple-base-string
+           (frob simple-base-string))
+          ((simple-array nil (*))
+           (frob (simple-array nil (*)))))))
 
-;;; Dump the characters buffer up in IN-STREAM to OUT-STREAM as
-;;; GET-OUTPUT-STREAM-STRING would return them.
-(defun dump-output-stream-string (in-stream out-stream)
-  (%write-string (string-output-stream-string in-stream)
-                 out-stream
-                 0
-                 (string-output-stream-last-index in-stream))
-  (setf (string-output-stream-index in-stream) 0
-        (string-output-stream-index-cache in-stream) 0))
+    result))
 
 ;;;; fill-pointer streams
 
@@ -1747,6 +1936,15 @@
       ;; must be Gray streams FUNDAMENTAL-STREAM
       (stream-read-sequence stream seq start end)))
 
+(declaim (inline compatible-vector-and-stream-element-types-p))
+(defun compatible-vector-and-stream-element-types-p (vector stream)
+  (declare (type vector vector)
+           (type ansi-stream stream))
+  (or (and (typep vector '(simple-array (unsigned-byte 8) (*)))
+           (subtypep (stream-element-type stream) '(unsigned-byte 8)))
+      (and (typep vector '(simple-array (signed-byte 8) (*)))
+           (subtypep (stream-element-type stream) '(signed-byte 8)))))
+
 (defun ansi-stream-read-sequence (seq stream start %end)
   (declare (type sequence seq)
            (type ansi-stream stream)
@@ -1772,27 +1970,33 @@
              (setf (first rem) el)))))
       (vector
        (with-array-data ((data seq) (offset-start start) (offset-end end))
-         (typecase data
-           ((or (simple-array (unsigned-byte 8) (*))
-                (simple-array (signed-byte 8) (*)))
-            (let* ((numbytes (- end start))
-                   (bytes-read (read-n-bytes stream data offset-start
-                                             numbytes nil)))
-              (if (< bytes-read numbytes)
-                  (+ start bytes-read)
-                  end)))
-           (t
-            (let ((read-function
-                   (if (subtypep (stream-element-type stream) 'character)
-                       #'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)))))))))))
+         (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))))))))))
 
 ;;;; WRITE-SEQUENCE
 
@@ -1837,20 +2041,25 @@
              ((output-seq-in-loop ()
                 (let ((write-function
                        (if (subtypep (stream-element-type stream) 'character)
-                           (ansi-stream-out stream)
+                           (lambda (stream object)
+                             ;; This might be a bivalent stream, so we need
+                             ;; to dispatch on a per-element basis, rather
+                             ;; than just based on the sequence or stream
+                             ;; element types.
+                             (if (characterp object)
+                                 (funcall (ansi-stream-out stream)
+                                          stream object)
+                                 (funcall (ansi-stream-bout stream)
+                                          stream object)))
                            (ansi-stream-bout stream))))
                   (do ((i offset-start (1+ i)))
                       ((>= i offset-end))
                     (declare (type index i))
                     (funcall write-function stream (aref data i))))))
-           (typecase data
-             ((or (simple-array (unsigned-byte 8) (*))
-                  (simple-array (signed-byte 8) (*)))
-              (if (fd-stream-p stream)
-                  (output-raw-bytes stream data offset-start offset-end)
-                  (output-seq-in-loop)))
-             (t
-              (output-seq-in-loop))))))))
+           (if (and (fd-stream-p stream)
+                    (compatible-vector-and-stream-element-types-p data stream))
+               (buffer-output stream data offset-start offset-end)
+               (output-seq-in-loop)))))))
   seq)
 
 ;;;; etc.