Fix bug 242 for fd-streams

  ... fd-streams have a method that writes n octets; use it.

diff --git a/BUGS b/BUGS
index d7c3679..df38981 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -730,6 +730,11 @@ WORKAROUND:
   (UNSIGNED-BYTE 8) will write to the stream one byte at a time,
   rather than writing the sequence in one go, leading to severe
   performance degradation.
+  As of sbcl-0.9.0.36, this is solved for fd-streams, so is less of a
+  problem in practice.  (Fully fixing this would require adding a
+  ansi-stream-n-bout slot and associated methods to write a byte
+  sequence to ansi-stream, similar to the existing ansi-stream-sout
+  slot/functions.)
 
 243: "STYLE-WARNING overenthusiasm for unused variables"
   (observed from clx compilation)

diff --git a/src/code/stream.lisp b/src/code/stream.lisp
index d9d1b06..b8ac730 100644 (file)
--- a/src/code/stream.lisp
+++ b/src/code/stream.lisp
@@ -1795,20 +1795,32 @@
                  (ansi-stream-bout stream))))
         (do ((rem (nthcdr start seq) (rest rem))
              (i start (1+ i)))
-            ((or (endp rem) (>= i end)) seq)
+            ((or (endp rem) (>= i end)))
           (declare (type list rem)
                    (type index i))
           (funcall write-function stream (first rem)))))
       (string
        (%write-string seq stream start end))
       (vector
-       (let ((write-function
-             (if (subtypep (stream-element-type stream) 'character)
-                 (ansi-stream-out stream)
-                 (ansi-stream-bout stream))))
-        (do ((i start (1+ i)))
-            ((>= i end) seq)
-          (declare (type index i))
-          (funcall write-function stream (aref seq i))))))))
+       (with-array-data ((data seq) (offset-start start) (offset-end end))
+        (labels
+            ((output-seq-in-loop ()
+               (let ((write-function
+                      (if (subtypep (stream-element-type stream) 'character)
+                          (ansi-stream-out stream)
+                          (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))))))))
+  seq)
 \f
 ;;;; etc.

diff --git a/version.lisp-expr b/version.lisp-expr
index 3661de3..e6026ed 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.0.35"
+"0.9.0.36"