X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=969c5623f68a982c557c46f4ea26064cfa3cb500;hb=731d5dd65a7b94b5d49d1663d9b60c3a406ce38c;hp=73844a06db1179d25d4f4496d92a03190a2113fa;hpb=a6103aace1e40d0948aeb090f7b5d5ca77fc293a;p=sbcl.git

diff --git a/src/code/stream.lisp b/src/code/stream.lisp
index 73844a0..969c562 100644
--- a/src/code/stream.lisp
+++ b/src/code/stream.lisp
@@ -115,6 +115,9 @@
 (defun stream-element-type (stream)
   (ansi-stream-element-type stream))
 
+(defun stream-external-format (stream)
+  (funcall (ansi-stream-misc stream) stream :external-format))
+
 (defun interactive-stream-p (stream)
   (declare (type stream stream))
   (funcall (ansi-stream-misc stream) stream :interactive-p))
@@ -142,19 +145,25 @@
 ;;;; file position and file length
 
 ;;; Call the MISC method with the :FILE-POSITION operation.
-(defun file-position (stream &optional position)
+#!-sb-fluid (declaim (inline ansi-stream-file-position))
+(defun ansi-stream-file-position (stream position)
   (declare (type stream stream))
-  (declare (type (or index (alien sb!unix:off-t) (member nil :start :end)) position))
+  (declare (type (or index (alien sb!unix:off-t) (member nil :start :end))
+                 position))
   (cond
-   (position
-    (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
-    (funcall (ansi-stream-misc stream) stream :file-position position))
-   (t
-    (let ((res (funcall (ansi-stream-misc stream) stream :file-position nil)))
-      (when res
-	(- res
-	   (- +ansi-stream-in-buffer-length+
-	      (ansi-stream-in-index stream))))))))
+    (position
+     (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
+     (funcall (ansi-stream-misc stream) stream :file-position position))
+    (t
+     (let ((res (funcall (ansi-stream-misc stream) stream :file-position nil)))
+       (when res
+         (- res
+            (- +ansi-stream-in-buffer-length+
+               (ansi-stream-in-index stream))))))))
+
+
+(defun file-position (stream &optional position)
+  (ansi-stream-file-position stream position))
 
 ;;; This is a literal translation of the ANSI glossary entry "stream
 ;;; associated with a file".
@@ -183,6 +192,7 @@
 	   ;; EXPECTED-TYPE? This SATISFIES type (with a nonstandard
 	   ;; private predicate function..) is ugly and confusing, but
 	   ;; I can't see any other way. -- WHN 2001-04-14
+	   :datum stream
 	   :expected-type '(satisfies stream-associated-with-file-p)
 	   :format-control
 	   "~@<The stream ~2I~_~S ~I~_isn't associated with a file.~:>"
@@ -194,17 +204,25 @@
   ;; cause cross-compiler hangup.
   ;;
   ;; (declare (type (or file-stream synonym-stream) stream))
-  (stream-must-be-associated-with-file stream)
+  ;; 
+  ;; The description for FILE-LENGTH says that an error must be raised
+  ;; for streams not associated with files (which broadcast streams
+  ;; aren't according to the glossary). However, the behaviour of
+  ;; FILE-LENGTH for broadcast streams is explicitly described in the
+  ;; BROADCAST-STREAM entry.
+  (unless (typep stream 'broadcast-stream)	      
+    (stream-must-be-associated-with-file stream))
   (funcall (ansi-stream-misc stream) stream :file-length))
+
+(defun file-string-length (stream object)
+  (funcall (ansi-stream-misc stream) stream :file-string-length object))
 
 ;;;; input functions
 
-(defun read-line (&optional (stream *standard-input*) (eof-error-p t) eof-value
-			    recursive-p)
+#!-sb-fluid (declaim (inline ansi-stream-read-line))
+(defun ansi-stream-read-line (stream eof-error-p eof-value recursive-p)
   (declare (ignore recursive-p))
-  (let ((stream (in-synonym-of stream)))
-    (if (ansi-stream-p stream)
-	(prepare-for-fast-read-char stream
+  (prepare-for-fast-read-char stream
 	  (let ((res (make-string 80))
 		(len 80)
 		(index 0))
@@ -231,95 +249,131 @@
 		     ;; shouldn't do another READ-CHAR.
 		     (t
 		      (done-with-fast-read-char)
-		      (return (values (shrink-vector res index) t))))))))
+		      (return (values (shrink-vector res index) t)))))))))
+
+(defun read-line (&optional (stream *standard-input*) (eof-error-p t) eof-value
+			    recursive-p)
+  (let ((stream (in-synonym-of stream)))
+    (if (ansi-stream-p stream)
+	(ansi-stream-read-line stream eof-error-p eof-value recursive-p)
 	;; must be Gray streams FUNDAMENTAL-STREAM
 	(multiple-value-bind (string eof) (stream-read-line stream)
 	  (if (and eof (zerop (length string)))
 	      (values (eof-or-lose stream eof-error-p eof-value) t)
 	      (values string eof))))))
 
-;;; We proclaim them INLINE here, then proclaim them MAYBE-INLINE at EOF,
+;;; We proclaim them INLINE here, then proclaim them NOTINLINE later on,
 ;;; so, except in this file, they are not inline by default, but they can be.
 #!-sb-fluid (declaim (inline read-char unread-char read-byte listen))
 
+#!-sb-fluid (declaim (inline ansi-stream-read-char))
+(defun ansi-stream-read-char (stream eof-error-p eof-value recursive-p)
+  (declare (ignore recursive-p))
+  (prepare-for-fast-read-char stream
+    (prog1
+        (fast-read-char eof-error-p eof-value)
+      (done-with-fast-read-char))))
+
 (defun read-char (&optional (stream *standard-input*)
 			    (eof-error-p t)
 			    eof-value
 			    recursive-p)
-  (declare (ignore recursive-p))
   (let ((stream (in-synonym-of stream)))
     (if (ansi-stream-p stream)
-	(prepare-for-fast-read-char stream
-	  (prog1
-	      (fast-read-char eof-error-p eof-value)
-	    (done-with-fast-read-char)))
+	(ansi-stream-read-char stream eof-error-p eof-value recursive-p)
 	;; must be Gray streams FUNDAMENTAL-STREAM
 	(let ((char (stream-read-char stream)))
 	  (if (eq char :eof)
 	      (eof-or-lose stream eof-error-p eof-value)
 	      char)))))
 
+#!-sb-fluid (declaim (inline ansi-stream-unread-char))
+(defun ansi-stream-unread-char (character stream)
+  (let ((index (1- (ansi-stream-in-index stream)))
+        (buffer (ansi-stream-cin-buffer stream)))
+    (declare (fixnum index))
+    (when (minusp index) (error "nothing to unread"))
+    (cond (buffer
+           (setf (aref buffer index) character)
+           (setf (ansi-stream-in-index stream) index))
+          (t
+           (funcall (ansi-stream-misc stream) stream
+                    :unread character)))))
+
 (defun unread-char (character &optional (stream *standard-input*))
   (let ((stream (in-synonym-of stream)))
     (if (ansi-stream-p stream)
-	(let ((index (1- (ansi-stream-in-index stream)))
-	      (buffer (ansi-stream-in-buffer stream)))
-	  (declare (fixnum index))
-	  (when (minusp index) (error "nothing to unread"))
-	  (cond (buffer
-		 (setf (aref buffer index) (char-code character))
-		 (setf (ansi-stream-in-index stream) index))
-		(t
-		 (funcall (ansi-stream-misc stream) stream
-			  :unread character))))
+	(ansi-stream-unread-char character stream)
 	;; must be Gray streams FUNDAMENTAL-STREAM
 	(stream-unread-char stream character)))
   nil)
 
+#!-sb-fluid (declaim (inline ansi-stream-listen))
+(defun ansi-stream-listen (stream)
+  (or (/= (the fixnum (ansi-stream-in-index stream))
+          +ansi-stream-in-buffer-length+)
+      ;; Handle :EOF return from misc methods specially
+      (let ((result (funcall (ansi-stream-misc stream) stream :listen)))
+	(if (eq result :eof)
+	    nil
+	    result))))
+
 (defun listen (&optional (stream *standard-input*))
   (let ((stream (in-synonym-of stream)))
     (if (ansi-stream-p stream)
-	(or (/= (the fixnum (ansi-stream-in-index stream))
-		+ansi-stream-in-buffer-length+)
-	    ;; Test for T explicitly since misc methods return :EOF sometimes.
-	    (eq (funcall (ansi-stream-misc stream) stream :listen) t))
+	(ansi-stream-listen stream)
 	;; Fall through to Gray streams FUNDAMENTAL-STREAM case.
 	(stream-listen stream))))
 
+#!-sb-fluid (declaim (inline ansi-stream-read-char-no-hang))
+(defun ansi-stream-read-char-no-hang (stream eof-error-p eof-value recursive-p)
+  (if (funcall (ansi-stream-misc stream) stream :listen)
+      ;; On T or :EOF get READ-CHAR to do the work.
+      (ansi-stream-read-char stream eof-error-p eof-value recursive-p)
+      nil))
+
 (defun read-char-no-hang (&optional (stream *standard-input*)
 				    (eof-error-p t)
 				    eof-value
 				    recursive-p)
-  (declare (ignore recursive-p))
   (let ((stream (in-synonym-of stream)))
     (if (ansi-stream-p stream)
-	(if (funcall (ansi-stream-misc stream) stream :listen)
-	    ;; On T or :EOF get READ-CHAR to do the work.
-	    (read-char stream eof-error-p eof-value)
-	    nil)
+	(ansi-stream-read-char-no-hang stream eof-error-p eof-value
+                                       recursive-p)
 	;; must be Gray streams FUNDAMENTAL-STREAM
 	(let ((char (stream-read-char-no-hang stream)))
 	  (if (eq char :eof)
 	      (eof-or-lose stream eof-error-p eof-value)
 	      char)))))
 
+#!-sb-fluid (declaim (inline ansi-stream-clear-input))
+(defun ansi-stream-clear-input (stream)
+  (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
+  (funcall (ansi-stream-misc stream) stream :clear-input))
+
 (defun clear-input (&optional (stream *standard-input*))
   (let ((stream (in-synonym-of stream)))
-    (cond ((ansi-stream-p stream)
-	   (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
-	   (funcall (ansi-stream-misc stream) stream :clear-input))
-	  (t
-	   (stream-clear-input stream))))
+    (if (ansi-stream-p stream)
+        (ansi-stream-clear-input stream)
+        ;; must be Gray streams FUNDAMENTAL-STREAM
+        (stream-clear-input stream)))
   nil)
 
-(declaim (maybe-inline read-byte))
+#!-sb-fluid (declaim (inline ansi-stream-read-byte))
+(defun ansi-stream-read-byte (stream eof-error-p eof-value recursive-p)
+  ;; Why the "recursive-p" parameter?  a-s-r-b is funcall'ed from
+  ;; 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))))
+
 (defun read-byte (stream &optional (eof-error-p t) eof-value)
   (let ((stream (in-synonym-of stream)))
     (if (ansi-stream-p stream)
-	(prepare-for-fast-read-byte stream
-	  (prog1
-	      (fast-read-byte eof-error-p eof-value t)
-	    (done-with-fast-read-byte)))
+	(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)
@@ -354,13 +408,23 @@
 	       numbytes
 	       eof-error-p))
      ((<= numbytes num-buffered)
+      #+nil
+      (let ((copy-function (typecase buffer
+                             ((simple-array * (*)) #'ub8-bash-copy)
+                             (system-area-pointer #'copy-ub8-to-system-area))))
+        (funcall copy-function in-buffer index buffer start numbytes))
       (%byte-blt in-buffer index
 		 buffer start (+ start numbytes))
       (setf (ansi-stream-in-index stream) (+ index numbytes))
       numbytes)
      (t
       (let ((end (+ start num-buffered)))
-	(%byte-blt in-buffer index buffer start end)
+	#+nil
+        (let ((copy-function (typecase buffer
+                             ((simple-array * (*)) #'ub8-bash-copy)
+                             (system-area-pointer #'copy-ub8-to-system-area))))
+          (funcall copy-function in-buffer index buffer start num-buffered))
+        (%byte-blt in-buffer index buffer start end)
 	(setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
 	(+ (funcall (ansi-stream-n-bin stream)
 		    stream
@@ -381,31 +445,35 @@
 ;;; the IN-BUFFER for text streams. There is definitely an IN-BUFFER,
 ;;; and hence must be an N-BIN method.
 (defun fast-read-char-refill (stream eof-error-p eof-value)
-  (let* ((ibuf (ansi-stream-in-buffer stream))
-	 (count (funcall (ansi-stream-n-bin stream)
-			 stream
-			 ibuf
-			 +ansi-stream-in-buffer-extra+
-			 (- +ansi-stream-in-buffer-length+
-			    +ansi-stream-in-buffer-extra+)
-			 nil))
-	 (start (- +ansi-stream-in-buffer-length+ count)))
+  (let* ((ibuf (ansi-stream-cin-buffer stream))
+         (count (funcall (ansi-stream-n-bin stream)
+                         stream
+                         ibuf
+                         +ansi-stream-in-buffer-extra+
+                         (- +ansi-stream-in-buffer-length+
+                            +ansi-stream-in-buffer-extra+)
+                         nil))
+         (start (- +ansi-stream-in-buffer-length+ count)))
     (declare (type index start count))
     (cond ((zerop count)
-	   (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+)
-	   (funcall (ansi-stream-in stream) stream eof-error-p eof-value))
-	  (t
-	   (when (/= start +ansi-stream-in-buffer-extra+)
-	     (bit-bash-copy ibuf (+ (* +ansi-stream-in-buffer-extra+
-				       sb!vm:n-byte-bits)
-				    (* sb!vm:vector-data-offset
-				       sb!vm:n-word-bits))
-			    ibuf (+ (the index (* start sb!vm:n-byte-bits))
-				    (* sb!vm:vector-data-offset
-				       sb!vm:n-word-bits))
-			    (* count sb!vm:n-byte-bits)))
-	   (setf (ansi-stream-in-index stream) (1+ start))
-	   (code-char (aref ibuf start))))))
+           (setf (ansi-stream-in-index stream)
+                 +ansi-stream-in-buffer-length+)
+           (funcall (ansi-stream-in stream) stream eof-error-p eof-value))
+          (t
+           (when (/= start +ansi-stream-in-buffer-extra+)
+             (#.(let* ((n-character-array-bits
+                        (sb!vm:saetp-n-bits
+                         (find 'character
+                               sb!vm:*specialized-array-element-type-properties*
+                               :key #'sb!vm:saetp-specifier)))
+                       (bash-function (intern (format nil "UB~A-BASH-COPY" n-character-array-bits)
+                                              (find-package "SB!KERNEL"))))
+                  bash-function)
+                ibuf +ansi-stream-in-buffer-extra+
+                ibuf start
+                count))
+           (setf (ansi-stream-in-index stream) (1+ start))
+           (aref ibuf start)))))
 
 ;;; This is similar to FAST-READ-CHAR-REFILL, but we don't have to
 ;;; leave room for unreading.
@@ -421,11 +489,9 @@
 	   (funcall (ansi-stream-bin stream) stream eof-error-p eof-value))
 	  (t
 	   (unless (zerop start)
-	     (bit-bash-copy ibuf (* sb!vm:vector-data-offset sb!vm:n-word-bits)
-			    ibuf (+ (the index (* start sb!vm:n-byte-bits))
-				    (* sb!vm:vector-data-offset
-				       sb!vm:n-word-bits))
-			    (* count sb!vm:n-byte-bits)))
+             (ub8-bash-copy ibuf 0
+                            ibuf start 
+                            count))
 	   (setf (ansi-stream-in-index stream) (1+ start))
 	   (aref ibuf start)))))
 
@@ -440,12 +506,16 @@
   (with-out-stream stream (ansi-stream-out #\newline) (stream-terpri))
   nil)
 
+#!-sb-fluid (declaim (inline ansi-stream-fresh-line))
+(defun ansi-stream-fresh-line (stream)
+  (when (/= (or (charpos stream) 1) 0)
+    (funcall (ansi-stream-out stream) stream #\newline)
+    t))
+
 (defun fresh-line (&optional (stream *standard-output*))
   (let ((stream (out-synonym-of stream)))
     (if (ansi-stream-p stream)
-	(when (/= (or (charpos stream) 1) 0)
-	  (funcall (ansi-stream-out stream) stream #\newline)
-	  t)
+	(ansi-stream-fresh-line stream)
 	;; must be Gray streams FUNDAMENTAL-STREAM
 	(stream-fresh-line stream))))
 
@@ -463,21 +533,28 @@
 				      string start end))
   string)
 
+#!-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))
+  (if (array-header-p string)
+      (with-array-data ((data string) (offset-start start)
+                        (offset-end end))
+        (funcall (ansi-stream-sout stream)
+                 stream data offset-start offset-end))
+      (funcall (ansi-stream-sout stream) stream string start end))
+  string)
+
 (defun %write-string (string stream start end)
   (declare (type string string))
-  (declare (type streamlike stream))
+  (declare (type stream-designator stream))
   (declare (type index start end))
   (let ((stream (out-synonym-of stream)))
-    (cond ((ansi-stream-p stream)
-	   (if (array-header-p string)
-	       (with-array-data ((data string) (offset-start start)
-				 (offset-end end))
-		 (funcall (ansi-stream-sout stream)
-			  stream data offset-start offset-end))
-	       (funcall (ansi-stream-sout stream) stream string start end))
-	   string)
-	  (t ; must be Gray streams FUNDAMENTAL-STREAM
-	   (stream-write-string stream string start end)))))
+    (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))))
 
 ;;; A wrapper function for all those (MACROLET OUT-FUN) definitions,
 ;;; which cannot deal with keyword arguments.
@@ -528,7 +605,7 @@
 ;;; globally.  And we must not inline them in the rest of this file if
 ;;; dispatch to gray or simple streams is to work, since both redefine
 ;;; these functions later.)
-(declaim (maybe-inline read-char unread-char read-byte listen))
+(declaim (notinline read-char unread-char read-byte listen))
 
 ;;; This is called from ANSI-STREAM routines that encapsulate CLOS
 ;;; streams to handle the misc routines and dispatch to the
@@ -554,6 +631,8 @@
      (finish-output stream))
     (:element-type
      (stream-element-type stream))
+    (:stream-external-format
+     (stream-external-format stream))
     (:interactive-p
      (interactive-stream-p stream))
     (:line-length
@@ -562,6 +641,8 @@
      (charpos stream))
     (:file-length
      (file-length stream))
+    (:file-string-length
+     (file-string-length stream arg1))
     (:file-position
      (file-position stream arg1))))
 
@@ -629,6 +710,27 @@
 	     ((null streams) res)
 	   (when (null (cdr streams))
 	     (setq res (stream-element-type (car streams)))))))
+      (:external-format
+       (let ((res :default))
+	 (dolist (stream streams res)
+	   (setq res (stream-external-format stream)))))
+      (:file-length
+       (let ((last (last streams)))
+	 (if last	     
+	     (file-length (car last))
+	     0)))
+      (:file-position
+       (if arg1
+	   (let ((res (or (eql arg1 :start) (eql arg1 0))))
+	     (dolist (stream streams res)
+	       (setq res (file-position stream arg1))))
+	   (let ((res 0))
+	     (dolist (stream streams res)
+	       (setq res (file-position stream))))))
+      (:file-string-length
+       (let ((res 1))
+	 (dolist (stream streams res)
+	   (setq res (file-string-length stream arg1)))))
       (:close
        (set-closed-flame stream))
       (t
@@ -759,7 +861,7 @@
 	   (or (/= (the fixnum (ansi-stream-in-index in))
 		   +ansi-stream-in-buffer-length+)
 	       (funcall (ansi-stream-misc in) in :listen))
-	   (stream-listen in)))
+	   (listen in)))
       ((:finish-output :force-output :clear-output)
        (if out-ansi-stream-p
 	   (funcall (ansi-stream-misc out) out operation arg1 arg2)
@@ -789,20 +891,10 @@
 		      (bin #'concatenated-bin)
 		      (n-bin #'concatenated-n-bin)
 		      (misc #'concatenated-misc))
-	    (:constructor %make-concatenated-stream
-			  (&rest streams &aux (current streams)))
+	    (:constructor %make-concatenated-stream (&rest streams))
 	    (:copier nil))
   ;; The car of this is the substream we are reading from now.
-  current
-  ;; This is a list of all the substreams there ever were. We need to
-  ;; remember them so that we can close them.
-  ;;
-  ;; FIXME: ANSI says this is supposed to be the list of streams that
-  ;; we still have to read from. So either this needs to become a
-  ;; private member %STREAM (with CONCATENATED-STREAM-STREAMS a wrapper
-  ;; around it which discards closed files from the head of the list)
-  ;; or we need to update it as we run out of files.
-  (streams nil :type list :read-only t))
+  (streams nil :type list))
 (def!method print-object ((x concatenated-stream) stream)
   (print-unreadable-object (x stream :type t :identity t)
     (format stream
@@ -822,66 +914,68 @@
 
 (macrolet ((in-fun (name fun)
 	     `(defun ,name (stream eof-error-p eof-value)
-		(do ((current (concatenated-stream-current stream)
-			      (cdr current)))
-		    ((null current)
+		(do ((streams (concatenated-stream-streams stream)
+			      (cdr streams)))
+		    ((null streams)
 		     (eof-or-lose stream eof-error-p eof-value))
-		  (let* ((stream (car current))
+		  (let* ((stream (car streams))
 			 (result (,fun stream nil nil)))
 		    (when result (return result)))
-		  (pop (concatenated-stream-current stream))))))
+		  (pop (concatenated-stream-streams stream))))))
   (in-fun concatenated-in read-char)
   (in-fun concatenated-bin read-byte))
 
 (defun concatenated-n-bin (stream buffer start numbytes eof-errorp)
-  (do ((current (concatenated-stream-current stream) (cdr current))
+  (do ((streams (concatenated-stream-streams stream) (cdr streams))
        (current-start start)
        (remaining-bytes numbytes))
-      ((null current)
+      ((null streams)
        (if eof-errorp
 	   (error 'end-of-file :stream stream)
 	   (- numbytes remaining-bytes)))
-    (let* ((stream (car current))
+    (let* ((stream (car streams))
            (bytes-read (read-n-bytes stream buffer current-start
 	                             remaining-bytes nil)))
       (incf current-start bytes-read)
       (decf remaining-bytes bytes-read)
       (when (zerop remaining-bytes) (return numbytes)))
-    (setf (concatenated-stream-current stream) (cdr current))))
+    (setf (concatenated-stream-streams stream) (cdr streams))))
 
 (defun concatenated-misc (stream operation &optional arg1 arg2)
-  (let ((left (concatenated-stream-current stream)))
-    (when left
-      (let* ((current (car left)))
-	(case operation
-	  (:listen
-	   (loop
-	     (let ((stuff (if (ansi-stream-p current)
-			      (funcall (ansi-stream-misc current) current
-				       :listen)
-			      (stream-misc-dispatch current :listen))))
-	       (cond ((eq stuff :eof)
-		      ;; Advance CURRENT, and try again.
-		      (pop (concatenated-stream-current stream))
-		      (setf current
-			    (car (concatenated-stream-current stream)))
-		      (unless current
-			;; No further streams. EOF.
-			(return :eof)))
-		     (stuff
-		      ;; Stuff's available.
-		      (return t))
-		     (t
-		      ;; Nothing is available yet.
-		      (return nil))))))
-          (:clear-input (clear-input current))
-          (:unread (unread-char arg1 current))
-          (:close
-	   (set-closed-flame stream))
-	  (t
-	   (if (ansi-stream-p current)
-	       (funcall (ansi-stream-misc current) current operation arg1 arg2)
-	       (stream-misc-dispatch current operation arg1 arg2))))))))
+  (let* ((left (concatenated-stream-streams stream))
+	 (current (car left)))
+    (case operation
+      (:listen
+       (unless left
+	 (return-from concatenated-misc :eof))
+       (loop
+	(let ((stuff (if (ansi-stream-p current)
+			 (funcall (ansi-stream-misc current) current
+				  :listen)
+			 (stream-misc-dispatch current :listen))))
+	  (cond ((eq stuff :eof)
+		 ;; Advance STREAMS, and try again.
+		 (pop (concatenated-stream-streams stream))
+		 (setf current
+		       (car (concatenated-stream-streams stream)))
+		 (unless current
+		   ;; No further streams. EOF.
+		   (return :eof)))
+		(stuff
+		 ;; Stuff's available.
+		 (return t))
+		(t
+		 ;; Nothing is available yet.
+		 (return nil))))))
+      (:clear-input (when left (clear-input current)))
+      (:unread (when left (unread-char arg1 current)))
+      (:close
+       (set-closed-flame stream))
+      (t
+       (when left
+	 (if (ansi-stream-p current)
+	     (funcall (ansi-stream-misc current) current operation arg1 arg2)
+	     (stream-misc-dispatch current operation arg1 arg2)))))))
 
 ;;;; echo streams
 
@@ -890,7 +984,7 @@
 		      (in #'echo-in)
 		      (bin #'echo-bin)
 		      (misc #'echo-misc)
-		      (n-bin #'ill-bin))
+		      (n-bin #'echo-n-bin))
 	    (:constructor %make-echo-stream (input-stream output-stream))
 	    (:copier nil))
   unread-stuff)
@@ -921,38 +1015,57 @@
 		(or (pop (echo-stream-unread-stuff stream))
 		    (let* ((in (echo-stream-input-stream stream))
 			   (out (echo-stream-output-stream stream))
-			   (result (,in-fun in ,@args)))
-		      (,out-fun result out)
-		      result)))))
+			   (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)))))))
   (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))
-
-;;;; base STRING-STREAM stuff
-
-(defstruct (string-stream
-             (:include ansi-stream)
-             (:constructor nil)
-             (:copier nil))
-  ;; FIXME: This type declaration is true, and will probably continue
-  ;; to be true.  However, note well the comments in DEFTRANSFORM
-  ;; REPLACE, implying that performance of REPLACE is somewhat
-  ;; critical to performance of string streams.  If (VECTOR CHARACTER)
-  ;; ever becomes different from (VECTOR BASE-CHAR), the transform
-  ;; probably needs to be extended.
-  (string (missing-arg) :type (vector character)))
+
+(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)))))
 
 ;;;; STRING-INPUT-STREAM stuff
 
 (defstruct (string-input-stream
-	     (:include string-stream
+	     (:include ansi-stream
 		       (in #'string-inch)
 		       (bin #'ill-bin)
-		       (n-bin #'string-stream-read-n-bytes)
-		       (misc #'string-in-misc)
-                       (string (missing-arg) :type simple-string))
+		       (n-bin #'ill-bin)
+		       (misc #'string-in-misc))
 	     (:constructor internal-make-string-input-stream
 			   (string current end))
 	     (:copier nil))
+  (string (missing-arg) :type simple-string)
   (current (missing-arg) :type index)
   (end (missing-arg) :type index))
 
@@ -987,14 +1100,16 @@
     (when (plusp copy)
       (setf (string-input-stream-current stream)
 	    (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-copy (vector-sap string)
-			 (* index sb!vm:n-byte-bits)
-			 (if (typep buffer 'system-area-pointer)
-			     buffer
-			     (vector-sap buffer))
-			 (* start sb!vm:n-byte-bits)
-			 (* copy sb!vm:n-byte-bits))))
+       (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)))
@@ -1019,6 +1134,7 @@
     ;; This is checked by FILE-LENGTH, so no need to do it here either.
     ;; (:file-length (length (string-input-stream-string stream)))
     (:unread (decf (string-input-stream-current stream)))
+    (:close (set-closed-flame stream))
     (:listen (or (/= (the index (string-input-stream-current stream))
 		     (the index (string-input-stream-end stream)))
 		 :eof))
@@ -1042,17 +1158,16 @@
 ;;;; STRING-OUTPUT-STREAM stuff
 
 (defstruct (string-output-stream
-	    (:include string-stream
+	    (:include ansi-stream
 		      (out #'string-ouch)
 		      (sout #'string-sout)
-		      (misc #'string-out-misc)
-                      ;; The string we throw stuff in.
-                      (string (missing-arg)
-			      :type (simple-array character (*))))
+		      (misc #'string-out-misc))
 	    (:constructor make-string-output-stream 
 			  (&key (element-type 'character)
 			   &aux (string (make-string 40))))
 	    (: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
@@ -1130,6 +1245,7 @@
 			      (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))
@@ -1150,14 +1266,19 @@
 	 (element-type (string-output-stream-element-type stream))
 	 (result 
 	  (case element-type
-	    ;; Overwhelmingly common case; can be inlined.
+	    ;; overwhelmingly common case: can be inlined
 	    ((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))))
     (setf (string-output-stream-index stream) 0
@@ -1180,22 +1301,21 @@
 ;;; 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.
 (deftype string-with-fill-pointer ()
   '(and (vector character)
 	(satisfies array-has-fill-pointer-p)))
 
 (defstruct (fill-pointer-output-stream
- 	    (:include string-stream
+ 	    (:include ansi-stream
 		      (out #'fill-pointer-ouch)
 		      (sout #'fill-pointer-sout)
-		      (misc #'fill-pointer-misc)
-                      ;; a string with a fill pointer where we stuff
-                      ;; the stuff we write
-                      (string (missing-arg)
-                              :type string-with-fill-pointer
-                              :read-only t))
+		      (misc #'fill-pointer-misc))
 	    (:constructor make-fill-pointer-output-stream (string))
-	    (:copier nil)))
+	    (:copier nil))
+  ;; a string with a fill pointer where we stuff the stuff we write
+  (string (missing-arg) :type string-with-fill-pointer :read-only t))
 
 (defun fill-pointer-ouch (stream character)
   (let* ((buffer (fill-pointer-output-stream-string stream))
@@ -1209,9 +1329,9 @@
 	(if (= offset-current end)
 	    (let* ((new-length (1+ (* current 2)))
 		   (new-workspace (make-string new-length)))
-	      (declare (simple-string new-workspace))
-	      (%byte-blt workspace start
-			 new-workspace 0 current)
+	      (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
@@ -1239,25 +1359,20 @@
 	    (let* ((new-length (+ (the fixnum (* current 2)) string-len))
 		   (new-workspace (make-string new-length)))
 	      (declare (type (simple-array character (*)) new-workspace))
-	      (%byte-blt workspace dst-start
-			 new-workspace 0 current)
-	      (setf workspace new-workspace)
-	      (setf offset-current current)
-	      (setf offset-dst-end dst-end)
-	      (set-array-header buffer
-				workspace
-				new-length
-				dst-end
-				0
-				new-length
-				nil))
+              (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))
-	(%byte-blt string start
-		   workspace offset-current offset-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 arg1 arg2))
+  (declare (ignore arg2))
   (case operation
     (:file-position
      (let ((buffer (fill-pointer-output-stream-string stream)))
@@ -1316,7 +1431,7 @@
 	(indentation (indenting-stream-indentation ,stream)))
        ((>= i indentation))
      (%write-string
-      "							    "
+      #.(make-string 60 :initial-element #\Space)
       ,sub-stream
       0
       (min 60 (- indentation i)))))
@@ -1389,12 +1504,12 @@
   #!+sb-doc
   "Return a stream that sends all output to the stream TARGET, but modifies
    the case of letters, depending on KIND, which should be one of:
-     :upcase - convert to upper case.
-     :downcase - convert to lower case.
-     :capitalize - convert the first letter of words to upper case and the
-	rest of the word to lower case.
-     :capitalize-first - convert the first letter of the first word to upper
-	case and everything else to lower case."
+     :UPCASE - convert to upper case.
+     :DOWNCASE - convert to lower case.
+     :CAPITALIZE - convert the first letter of words to upper case and the
+        rest of the word to lower case.
+     :CAPITALIZE-FIRST - convert the first letter of the first word to upper
+        case and everything else to lower case."
   (declare (type stream target)
 	   (type (member :upcase :downcase :capitalize :capitalize-first)
 		 kind)
@@ -1433,7 +1548,7 @@
 
 (defun case-frob-upcase-out (stream char)
   (declare (type case-frob-stream stream)
-	   (type base-char char))
+	   (type character char))
   (let ((target (case-frob-stream-target stream))
 	(char (char-upcase char)))
     (if (ansi-stream-p target)
@@ -1442,7 +1557,7 @@
 
 (defun case-frob-upcase-sout (stream str start end)
   (declare (type case-frob-stream stream)
-	   (type simple-base-string str)
+	   (type simple-string str)
 	   (type index start)
 	   (type (or index null) end))
   (let* ((target (case-frob-stream-target stream))
@@ -1458,7 +1573,7 @@
 
 (defun case-frob-downcase-out (stream char)
   (declare (type case-frob-stream stream)
-	   (type base-char char))
+	   (type character char))
   (let ((target (case-frob-stream-target stream))
 	(char (char-downcase char)))
     (if (ansi-stream-p target)
@@ -1467,7 +1582,7 @@
 
 (defun case-frob-downcase-sout (stream str start end)
   (declare (type case-frob-stream stream)
-	   (type simple-base-string str)
+	   (type simple-string str)
 	   (type index start)
 	   (type (or index null) end))
   (let* ((target (case-frob-stream-target stream))
@@ -1483,7 +1598,7 @@
 
 (defun case-frob-capitalize-out (stream char)
   (declare (type case-frob-stream stream)
-	   (type base-char char))
+	   (type character char))
   (let ((target (case-frob-stream-target stream)))
     (cond ((alphanumericp char)
 	   (let ((char (char-upcase char)))
@@ -1500,7 +1615,7 @@
 
 (defun case-frob-capitalize-sout (stream str start end)
   (declare (type case-frob-stream stream)
-	   (type simple-base-string str)
+	   (type simple-string str)
 	   (type index start)
 	   (type (or index null) end))
   (let* ((target (case-frob-stream-target stream))
@@ -1527,7 +1642,7 @@
 
 (defun case-frob-capitalize-aux-out (stream char)
   (declare (type case-frob-stream stream)
-	   (type base-char char))
+	   (type character char))
   (let ((target (case-frob-stream-target stream)))
     (cond ((alphanumericp char)
 	   (let ((char (char-downcase char)))
@@ -1545,7 +1660,7 @@
 
 (defun case-frob-capitalize-aux-sout (stream str start end)
   (declare (type case-frob-stream stream)
-	   (type simple-base-string str)
+	   (type simple-string str)
 	   (type index start)
 	   (type (or index null) end))
   (let* ((target (case-frob-stream-target stream))
@@ -1572,7 +1687,7 @@
 
 (defun case-frob-capitalize-first-out (stream char)
   (declare (type case-frob-stream stream)
-	   (type base-char char))
+	   (type character char))
   (let ((target (case-frob-stream-target stream)))
     (cond ((alphanumericp char)
 	   (let ((char (char-upcase char)))
@@ -1590,7 +1705,7 @@
 
 (defun case-frob-capitalize-first-sout (stream str start end)
   (declare (type case-frob-stream stream)
-	   (type simple-base-string str)
+	   (type simple-string str)
 	   (type index start)
 	   (type (or index null) end))
   (let* ((target (case-frob-stream-target stream))
@@ -1644,14 +1759,14 @@
       (list
        (let ((read-function
 	      (if (subtypep (stream-element-type stream) 'character)
-		  #'read-char
-		  #'read-byte)))
+		  #'ansi-stream-read-char
+		  #'ansi-stream-read-byte)))
 	 (do ((rem (nthcdr start seq) (rest rem))
 	      (i start (1+ i)))
 	     ((or (endp rem) (>= i end)) i)
 	   (declare (type list rem)
 		    (type index i))
-	   (let ((el (funcall read-function stream nil :eof)))
+	   (let ((el (funcall read-function stream nil :eof nil)))
 	     (when (eq el :eof)
 	       (return i))
 	     (setf (first rem) el)))))
@@ -1659,26 +1774,22 @@
        (with-array-data ((data seq) (offset-start start) (offset-end end))
          (typecase data
 	   ((or (simple-array (unsigned-byte 8) (*))
-		(simple-array (signed-byte 8) (*))
-		simple-string)
+		(simple-array (signed-byte 8) (*)))
 	    (let* ((numbytes (- end start))
-		   (bytes-read (sb!sys:read-n-bytes stream
-						    data
-						    offset-start
-						    numbytes
-						    nil)))
+		   (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)
-		       #'read-char
-		       #'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)))
+		(let ((el (funcall read-function stream nil :eof nil)))
 		  (when (eq el :eof)
 		    (return (+ start (- i offset-start))))
 		  (setf (aref data i) el)))))))))))
@@ -1710,24 +1821,36 @@
       (list
        (let ((write-function
 	      (if (subtypep (stream-element-type stream) 'character)
-		  #'write-char
-		  #'write-byte)))
+		  (ansi-stream-out stream)
+		  (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 (first rem) stream))))
+	   (funcall write-function stream (first rem)))))
       (string
        (%write-string seq stream start end))
       (vector
-       (let ((write-function
-	      (if (subtypep (stream-element-type stream) 'character)
-		  #'write-char
-		  #'write-byte)))
-	 (do ((i start (1+ i)))
-	     ((>= i end) seq)
-	   (declare (type index i))
-	   (funcall write-function (aref seq i) stream)))))))
+       (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.