diff --git a/pcl/simple-streams/rt/simple-streams-test.lisp b/pcl/simple-streams/rt/simple-streams-test.lisp
index 038336180c2429cf7f0b33867a7200cd1221fea4..2d8ce51120fea1907f0c2a540eb7afb65b890fb9 100644
--- a/pcl/simple-streams/rt/simple-streams-test.lisp
+++ b/pcl/simple-streams/rt/simple-streams-test.lisp
@@ -512,3 +512,24 @@
 	(let ((seq (read-line s)))
 	  (string= string seq))))
   t)
+
+#+unicode
+(deftest unicode-write-large-1
+    ;; Tests if writing unicode surrogates work
+    (let ((string (concatenate 'string
+			       (map 'string #'code-char '(#xd800 #xdc00))
+			       (make-string 5000 :initial-element #\X))))
+      (with-open-file (s *test-file*
+			 :class 'file-simple-stream
+			 :direction :output
+			 :if-exists :supersede
+			 :if-does-not-exist :create
+			 :external-format :utf8)
+	(write-string string s))
+      (with-open-file (s *test-file*
+			 :direction :input
+			 :if-does-not-exist :error
+			 :external-format :utf8)
+	(let ((seq (read-line s)))
+	  (string= string seq))))
+  t)
diff --git a/pcl/simple-streams/strategy.lisp b/pcl/simple-streams/strategy.lisp
index e05858ea21cd5f90567aaa1dc2cbd11114859406..00fbfa99bef2bd2d7a180b8f44fbed9784aaa45b 100644
--- a/pcl/simple-streams/strategy.lisp
+++ b/pcl/simple-streams/strategy.lisp
@@ -5,7 +5,7 @@
 ;;; domain.
 ;;; 
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/strategy.lisp,v 1.16 2009/07/23 04:26:58 rtoy Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/strategy.lisp,v 1.17 2009/07/23 15:47:21 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -128,7 +128,9 @@
       (bref (sm buffer stream) ptr))))
 
 ;;;;
+#+(or)
 (defconstant +ef-obs-oc+ 0)
+#+(or)
 (defconstant +ef-obs-co+ 1)
 
 #+(or)
@@ -174,6 +176,7 @@
 (defconstant +ss-ef-wchars+ 3)
 (defconstant +ss-ef-max+ 4)
 
+;; Read one character from a simple-stream.
 (def-ef-macro %read-char-fn (ef simple-streams +ss-ef-max+ +ss-ef-rchar+)
   `(lambda (stream max refill)
      (declare (type simple-stream stream)
@@ -189,6 +192,7 @@
 			 (incf (sm buffpos stream)))
 		       (lambda (n) (decf (sm buffpos stream) n))))))
 
+;; Read many characters from a simple-stream and place them in a string.
 (def-ef-macro %read-chars-fn (ef simple-streams +ss-ef-max+ +ss-ef-rchars+)
   `(lambda (stream string search start end max refill)
      (declare (type simple-stream stream)
@@ -226,6 +230,8 @@
 	     (multiple-value-bind (hi lo)
 		 (lisp::surrogates code)
 	       (output hi (char-code hi) (sm control-in stream))
+	       ;; What do we do if the low (trailing surrogate) wants
+	       ;; to be placed after the specified end of the string?
 	       (when lo
 		 (incf posn)
 		 (incf count)
@@ -254,6 +260,42 @@
 	       (incf (sm charpos stream)))))))
      character))
 
+(def-ef-macro %sc-write-chars-fn (ef simple-streams +ss-ef-max+ +ss-ef-wchars+)
+  `(lambda (string stream start end)
+     (declare (string string)
+	      (type simple-stream stream))
+     (with-stream-class (simple-stream stream)
+       (do ((ef (sm external-format stream))
+	    (len (length string))
+	    (ctrl (sm control-out stream))
+	    (posn start (1+ posn))
+	    (count 0 (1+ count)))
+	   ((>= posn end)
+	    count)
+	 (declare (type fixnum posn count))
+	 (flet ((output (code)
+		  (unless (and (< code 32) ctrl (svref ctrl code)
+			       (funcall (the (or symbol function) (svref ctrl code))
+					stream (code-char code)))
+		    (codepoint-to-octets ,ef
+					 code
+					 (sm oc-state stream)
+					 (lambda (byte)
+					   (when (>= (sm buffpos stream) (sm buffer-ptr stream))
+					     (setf (sm buffpos stream) (flush-buffer stream t)))
+					   (setf (bref (sm buffer stream) (sm buffpos stream)) byte)
+					   (incf (sm buffpos stream)))))
+		  (sc-set-dirty stream)
+		  (when (sm charpos stream)
+		    (incf (sm charpos stream)))))
+	   (multiple-value-bind (code widep)
+	       (lisp::codepoint string posn len)
+	     (output code)
+	     (when widep
+	       (incf posn)
+	       (incf count))))))))
+
+
 (def-ef-macro %dc-write-char-fn (ef simple-streams +ss-ef-max+ +ss-ef-wchar+)
   `(lambda (character stream)
      (declare (type simple-stream stream))
@@ -275,6 +317,40 @@
 	     (when (sm charpos stream)
 	       (incf (sm charpos stream)))))))
      character))
+
+(def-ef-macro %dc-write-chars-fn (ef simple-streams +ss-ef-max+ +ss-ef-wchars+)
+  `(lambda (string stream start end)
+     (declare (string string)
+	      (type simple-stream stream))
+     (with-stream-class (simple-stream stream)
+       (do ((ef (sm external-format stream))
+	    (len (length string))
+	    (ctrl (sm control-out stream))
+	    (posn start (1+ posn))
+	    (count 0 (1+ count)))
+	   ((>= posn end)
+	    count)
+	 (declare (type fixnum posn count))
+	 (flet ((output (code)
+		  (unless (and (< code 32) ctrl (svref ctrl code)
+			       (funcall (the (or symbol function) (svref ctrl code))
+					stream (code-char code)))
+		    (codepoint-to-octets ,ef
+					 code
+					 (sm oc-state stream)
+					 (lambda (byte)
+					   (when (>= (sm buffpos stream) (sm max-out-pos stream))
+					     (setf (sm outpos stream) (flush-buffer stream t)))
+					   (setf (bref (sm out-buffer stream) (sm outpos stream)) byte)
+					   (incf (sm outpos stream)))))
+		  (when (sm charpos stream)
+		    (incf (sm charpos stream)))))
+	   (multiple-value-bind (code widep)
+	       (lisp::codepoint string posn len)
+	     (output code)
+	     (when widep
+	       (incf posn)
+	       (incf count))))))))
 
 ;;;; Single-Channel-Simple-Stream strategy functions
 
@@ -515,20 +591,8 @@
 (declaim (ftype j-write-chars-fn (sc write-chars :ef)))
 (defun (sc write-chars :ef) (string stream start end)
   (with-stream-class (simple-stream stream)
-    (do ((ef (sm external-format stream))
-         (ctrl (sm control-out stream))
-         (posn start (1+ posn))
-         (count 0 (1+ count)))
-        ((>= posn end)
-	 count)
-      (declare (type fixnum posn count))
-      (let* ((char (char string posn))
-             (code (char-code char)))
-        (unless (and (< code 32) ctrl (svref ctrl code)
-                     (funcall (the (or symbol function) (svref ctrl code))
-                              stream char))
-	  (funcall (%sc-write-char-fn ef)
-		   char stream))))))
+    (funcall (%sc-write-chars-fn (sm external-format stream))
+	     string stream start end)))
 
 
 ;;;; Dual-Channel-Simple-Stream strategy functions
@@ -544,19 +608,8 @@
 (declaim (ftype j-write-chars-fn (dc write-chars :ef)))
 (defun (dc write-chars :ef) (string stream start end)
   (with-stream-class (dual-channel-simple-stream stream)
-    (do ((ctrl (sm control-out stream))
-         (posn start (1+ posn))
-         (count 0 (1+ count)))
-        ((>= posn end)
-	 count)
-      (declare (type fixnum posn count))
-      (let* ((char (char string posn))
-             (code (char-code char)))
-        (unless (and (< code 32) ctrl (svref ctrl code)
-                     (funcall (the (or symbol function) (svref ctrl code))
-                              stream char))
-	  (funcall (%dc-write-char-fn (sm external-format stream))
-		   char stream))))))
+    (funcall (%dc-write-chars-fn (sm external-format stream))
+	     string stream start end)))
 
 
 ;;;; String-Simple-Stream strategy functions