From 5da5805594423a2d2a841b88617fd2c87fc05750 Mon Sep 17 00:00:00 2001
From: Rudi Schlatte <rudi@constantly.at>
Date: Mon, 16 May 2005 19:40:08 +0000
Subject: [PATCH] Fix bug 242 for fd-streams   ... fd-streams have a method
 that writes n octets; use it.

---
 BUGS                 |    5 +++++
 src/code/stream.lisp |   30 +++++++++++++++++++++---------
 version.lisp-expr    |    2 +-
 3 files changed, 27 insertions(+), 10 deletions(-)

diff --git a/BUGS b/BUGS
index d7c3679..df38981 100644
--- 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
--- 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)
 
 ;;;; etc.
diff --git a/version.lisp-expr b/version.lisp-expr
index 3661de3..e6026ed 100644
--- 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"
-- 
1.7.10.4