X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=d658516140fced218cb6c0959e17c17d05fa97e9;hb=b08e81cd5a06fe5d792f0be1d1c2bf3409a4ae60;hp=5e5b8926f54a69f53cc35a06572a07c290136e32;hpb=a63a3a68cdf694ea8076731ed7dfbfd88d127108;p=sbcl.git

diff --git a/src/code/stream.lisp b/src/code/stream.lisp
index 5e5b892..d658516 100644
--- a/src/code/stream.lisp
+++ b/src/code/stream.lisp
@@ -63,7 +63,6 @@
 (defun ansi-stream-input-stream-p (stream)
   (declare (type ansi-stream stream))
 
-  #!+high-security
   (when (synonym-stream-p stream)
     (setf stream
 	  (symbol-value (synonym-stream-symbol stream))))
@@ -85,7 +84,6 @@
 (defun ansi-stream-output-stream-p (stream)
   (declare (type ansi-stream stream))
 
-  #!+high-security
   (when (synonym-stream-p stream)
     (setf stream (symbol-value
 		  (synonym-stream-symbol stream))))
@@ -103,6 +101,7 @@
 (declaim (inline ansi-stream-open-stream-p))
 (defun ansi-stream-open-stream-p (stream)
   (declare (type ansi-stream stream))
+  ;; CLHS 22.1.4 lets us not worry about synonym streams here.
   (not (eq (ansi-stream-in stream) #'closed-flame)))
 
 (defun open-stream-p (stream)
@@ -116,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))
@@ -143,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 (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".
@@ -184,8 +192,9 @@
 	   ;; 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-string
+	   :format-control
 	   "~@<The stream ~2I~_~S ~I~_isn't associated with a file.~:>"
 	   :format-arguments (list stream))))
 
@@ -195,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))
@@ -232,185 +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)
 
-
-;;; In the interest of ``once and only once'' this macro contains the
-;;; framework necessary to implement a peek-char function, which has
-;;; two special-cases (one for gray streams and one for echo streams)
-;;; in addition to the normal case.
-;;;
-;;; All arguments are forms which will be used for a specific purpose
-;;; PEEK-TYPE - the current peek-type as defined by ANSI CL
-;;; EOF-VALUE - the eof-value argument to peek-char
-;;; CHAR-VAR - the variable which will be used to store the current character
-;;; READ-FORM - the form which will be used to read a character
-;;; UNREAD-FORM - ditto for unread-char
-;;; SKIPPED-CHAR-FORM - the form to execute when skipping a character
-;;; EOF-DETECTED-FORM - the form to execute when EOF has been detected
-;;;                     (this will default to CHAR-VAR)
-(defmacro generalized-peeking-mechanism (peek-type eof-value char-var read-form unread-form &optional (skipped-char-form nil) (eof-detected-form nil))
-  `(let ((,char-var ,read-form))
-    (cond ((eql ,char-var ,eof-value) 
-	   ,(if eof-detected-form
-		eof-detected-form
-		char-var))
-	  ((characterp ,peek-type)
-	   (do ((,char-var ,char-var ,read-form))
-	       ((or (eql ,char-var ,eof-value) 
-		    (char= ,char-var ,peek-type))
-		(cond ((eql ,char-var ,eof-value)
-		       ,(if eof-detected-form
-			    eof-detected-form
-			    char-var))
-		      (t ,unread-form
-			 ,char-var)))
-	     ,skipped-char-form))
-	  ((eql ,peek-type t)
-	   (do ((,char-var ,char-var ,read-form))
-	       ((or (eql ,char-var ,eof-value)
-		    (not (whitespace-char-p ,char-var)))
-		(cond ((eql ,char-var ,eof-value)
-		       ,(if eof-detected-form
-			    eof-detected-form
-			    char-var))
-		      (t ,unread-form
-			 ,char-var)))
-	     ,skipped-char-form))
-	  ((null ,peek-type)
-	   ,unread-form
-	   ,char-var)
-	  (t
-	   (bug "Impossible case reached in PEEK-CHAR")))))
-
-(defun peek-char (&optional (peek-type nil)
-			    (stream *standard-input*)
-			    (eof-error-p t)
-			    eof-value
-			    recursive-p)
-  (declare (ignore recursive-p))
-  ;; FIXME: The type of PEEK-TYPE is also declared in a DEFKNOWN, but
-  ;; the compiler doesn't seem to be smart enough to go from there to
-  ;; imposing a type check. Figure out why (because PEEK-TYPE is an
-  ;; &OPTIONAL argument?) and fix it, and then this explicit type
-  ;; check can go away.
-  (unless (typep peek-type '(or character boolean))
-    (error 'simple-type-error
-	   :datum peek-type
-	   :expected-type '(or character boolean)
-	   :format-control "~@<bad PEEK-TYPE=~S, ~_expected ~S~:>"
-	   :format-arguments (list peek-type '(or character boolean))))
-  (let ((stream (in-synonym-of stream)))
-    (cond ((typep stream 'echo-stream)
-	   (echo-misc stream 
-		      :peek-char
-		      peek-type
-		      (list eof-error-p eof-value)))
-	  ((ansi-stream-p stream)
-	   (generalized-peeking-mechanism
-	    peek-type eof-value char
-	    (read-char stream eof-error-p eof-value)
-	    (unread-char char stream)))
-	  (t
-	   ;; by elimination, must be Gray streams FUNDAMENTAL-STREAM
-	   (generalized-peeking-mechanism
-	    peek-type :eof char
-	    (if (null peek-type)
-		(stream-peek-char stream)
-		(stream-read-char stream))
-	    (if (null peek-type)
-		()
-		(stream-unread-char stream char))
-	    ()
-	    (eof-or-lose stream eof-error-p eof-value))))))
+#!-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)
@@ -445,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
@@ -472,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~D-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.
@@ -512,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)))))
 
@@ -531,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))))
 
@@ -554,21 +533,34 @@
 				      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.
+(declaim (inline write-string-no-key))
+(defun write-string-no-key (string stream start end)
+  (write-string string stream :start start :end end))
 
 (defun write-line (string &optional (stream *standard-output*)
 			  &key (start 0) end)
@@ -608,39 +600,49 @@
 		   (stream-write-byte integer))
   integer)
 
+
+;;; (These were inline throughout this file, but that's not appropriate
+;;; 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 (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
-;;; appropriate Gray stream functions.
+;;; appropriate SIMPLE- or FUNDAMENTAL-STREAM functions.
 (defun stream-misc-dispatch (stream operation &optional arg1 arg2)
-  (declare (type fundamental-stream stream)
-	   (ignore arg2))
-  (case operation
+  (declare (type stream stream) (ignore arg2))
+  (ecase operation
     (:listen
      ;; Return T if input available, :EOF for end-of-file, otherwise NIL.
-     (let ((char (stream-read-char-no-hang stream)))
+     (let ((char (read-char-no-hang stream nil :eof)))
        (when (characterp char)
-	 (stream-unread-char stream char))
+	 (unread-char char stream))
        char))
     (:unread
-     (stream-unread-char stream arg1))
+     (unread-char arg1 stream))
     (:close
      (close stream))
     (:clear-input
-     (stream-clear-input stream))
+     (clear-input stream))
     (:force-output
-     (stream-force-output stream))
+     (force-output stream))
     (:finish-output
-     (stream-finish-output stream))
+     (finish-output stream))
     (:element-type
      (stream-element-type stream))
+    (:stream-external-format
+     (stream-external-format stream))
     (:interactive-p
      (interactive-stream-p stream))
     (:line-length
-     (stream-line-length stream))
+     (line-length stream))
     (:charpos
-     (stream-line-column stream))
+     (charpos stream))
     (:file-length
      (file-length stream))
+    (:file-string-length
+     (file-string-length stream arg1))
     (:file-position
      (file-position stream arg1))))
 
@@ -659,31 +661,37 @@
 
 (defun make-broadcast-stream (&rest streams)
   (dolist (stream streams)
-    (unless (or (and (synonym-stream-p stream)
-		     (output-stream-p (symbol-value
-				       (synonym-stream-symbol stream))))
-		(output-stream-p stream))
+    (unless (output-stream-p stream)
       (error 'type-error
 	     :datum stream
 	     :expected-type '(satisfies output-stream-p))))
   (apply #'%make-broadcast-stream streams))
 
-(macrolet ((out-fun (fun method stream-method &rest args)
-	     `(defun ,fun (stream ,@args)
+(macrolet ((out-fun (name fun &rest args)
+	     `(defun ,name (stream ,@args)
 		(dolist (stream (broadcast-stream-streams stream))
-		  (if (ansi-stream-p stream)
-		      (funcall (,method stream) stream ,@args)
-		      (,stream-method stream ,@args))))))
-  (out-fun broadcast-out ansi-stream-out stream-write-char char)
-  (out-fun broadcast-bout ansi-stream-bout stream-write-byte byte)
-  (out-fun broadcast-sout ansi-stream-sout stream-write-string
-	   string start end))
+		  (,fun ,(car args) stream ,@(cdr args))))))
+  (out-fun broadcast-out write-char char)
+  (out-fun broadcast-bout write-byte byte)
+  (out-fun broadcast-sout write-string-no-key string start end))
 
 (defun broadcast-misc (stream operation &optional arg1 arg2)
   (let ((streams (broadcast-stream-streams stream)))
     (case operation
+      ;; FIXME: This may not be the best place to note this, but I
+      ;; think the :CHARPOS protocol needs revision.  Firstly, I think
+      ;; this is the last place where a NULL return value was possible
+      ;; (before adjusting it to be 0), so a bunch of conditionals IF
+      ;; CHARPOS can be removed; secondly, it is my belief that
+      ;; FD-STREAMS, when running FILE-POSITION, do not update the
+      ;; CHARPOS, and consequently there will be much wrongness.
+      ;;
+      ;; FIXME: see also TWO-WAY-STREAM treatment of :CHARPOS -- why
+      ;; is it testing the :charpos of an input stream?
+      ;;
+      ;; -- CSR, 2004-02-04
       (:charpos
-       (dolist (stream streams)
+       (dolist (stream streams 0)
 	 (let ((charpos (charpos stream)))
 	   (if charpos (return charpos)))))
       (:line-length
@@ -692,10 +700,39 @@
 	   (let ((res (line-length stream)))
 	     (when res (setq min (if min (min res min) res)))))))
       (:element-type
+       #+nil ; old, arguably more logical, version
        (let (res)
-	 (dolist (stream streams (if (> (length res) 1) `(and ,@res) res))
-	   (pushnew (stream-element-type stream) res :test #'equal))))
-      (:close)
+	 (dolist (stream streams (if (> (length res) 1) `(and ,@res) t))
+	   (pushnew (stream-element-type stream) res :test #'equal)))
+       ;; ANSI-specified version (under System Class BROADCAST-STREAM)
+       (let ((res t))
+	 (do ((streams streams (cdr streams)))
+	     ((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
        (let ((res nil))
 	 (dolist (stream streams res)
@@ -723,18 +760,16 @@
   (print-unreadable-object (x stream :type t :identity t)
     (format stream ":SYMBOL ~S" (synonym-stream-symbol x))))
 
-;;; The output simple output methods just call the corresponding method
-;;; in the synonymed stream.
-(macrolet ((out-fun (name slot stream-method &rest args)
+;;; The output simple output methods just call the corresponding
+;;; function on the synonymed stream.
+(macrolet ((out-fun (name fun &rest args)
 	     `(defun ,name (stream ,@args)
 		(declare (optimize (safety 1)))
 		(let ((syn (symbol-value (synonym-stream-symbol stream))))
-		  (if (ansi-stream-p syn)
-		      (funcall (,slot syn) syn ,@args)
-		      (,stream-method syn ,@args))))))
-  (out-fun synonym-out ansi-stream-out stream-write-char ch)
-  (out-fun synonym-bout ansi-stream-bout stream-write-byte n)
-  (out-fun synonym-sout ansi-stream-sout stream-write-string string start end))
+		  (,fun ,(car args) syn ,@(cdr args))))))
+  (out-fun synonym-out write-char ch)
+  (out-fun synonym-bout write-byte n)
+  (out-fun synonym-sout write-string-no-key string start end))
 
 ;;; For the input methods, we just call the corresponding function on the
 ;;; synonymed stream. These functions deal with getting input out of
@@ -789,31 +824,23 @@
   ;; FIXME: This idiom of the-real-stream-of-a-possibly-synonym-stream
   ;; should be encapsulated in a function, and used here and most of
   ;; the other places that SYNONYM-STREAM-P appears.
-  (unless (or (and (synonym-stream-p output-stream)
-	 	   (output-stream-p (symbol-value
-				     (synonym-stream-symbol output-stream))))
-	      (output-stream-p output-stream))
+  (unless (output-stream-p output-stream)
     (error 'type-error
 	   :datum output-stream
 	   :expected-type '(satisfies output-stream-p)))
-  (unless (or (and (synonym-stream-p input-stream)
-		   (input-stream-p (symbol-value
-				    (synonym-stream-symbol input-stream))))
-	      (input-stream-p input-stream))
+  (unless (input-stream-p input-stream)
     (error 'type-error
 	   :datum input-stream
 	   :expected-type '(satisfies input-stream-p)))
   (funcall #'%make-two-way-stream input-stream output-stream))
 
-(macrolet ((out-fun (name slot stream-method &rest args)
+(macrolet ((out-fun (name fun &rest args)
 	     `(defun ,name (stream ,@args)
 		(let ((syn (two-way-stream-output-stream stream)))
-		  (if (ansi-stream-p syn)
-		      (funcall (,slot syn) syn ,@args)
-		      (,stream-method syn ,@args))))))
-  (out-fun two-way-out ansi-stream-out stream-write-char ch)
-  (out-fun two-way-bout ansi-stream-bout stream-write-byte n)
-  (out-fun two-way-sout ansi-stream-sout stream-write-string string start end))
+		  (,fun ,(car args) syn ,@(cdr args))))))
+  (out-fun two-way-out write-char ch)
+  (out-fun two-way-bout write-byte n)
+  (out-fun two-way-sout write-string-no-key string start end))
 
 (macrolet ((in-fun (name fun &rest args)
 	     `(defun ,name (stream ,@args)
@@ -834,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)
@@ -864,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
@@ -889,10 +906,7 @@
   "Return a stream which takes its input from each of the streams in turn,
    going on to the next at EOF."
   (dolist (stream streams)
-    (unless (or (and (synonym-stream-p stream)
-		     (input-stream-p (symbol-value
-				      (synonym-stream-symbol stream))))
-		(input-stream-p stream))
+    (unless (input-stream-p stream)
       (error 'type-error
 	     :datum stream
 	     :expected-type '(satisfies input-stream-p))))
@@ -900,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
 
@@ -968,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)
@@ -984,150 +1000,94 @@
   "Return a bidirectional stream which gets its input from INPUT-STREAM and
    sends its output to OUTPUT-STREAM. In addition, all input is echoed to
    the output stream."
-  (unless (or (and (synonym-stream-p output-stream)
-	 	   (output-stream-p (symbol-value
-				     (synonym-stream-symbol output-stream))))
-	      (output-stream-p output-stream))
+  (unless (output-stream-p output-stream)
     (error 'type-error
 	   :datum output-stream
 	   :expected-type '(satisfies output-stream-p)))
-  (unless (or (and (synonym-stream-p input-stream)
-		   (input-stream-p (symbol-value
-				    (synonym-stream-symbol input-stream))))
-	      (input-stream-p input-stream))
+  (unless (input-stream-p input-stream)
     (error 'type-error
 	   :datum input-stream
 	   :expected-type '(satisfies input-stream-p)))
   (funcall #'%make-echo-stream input-stream output-stream))
 
-(macrolet ((in-fun (name fun out-slot stream-method &rest args)
+(macrolet ((in-fun (name in-fun out-fun &rest args)
 	     `(defun ,name (stream ,@args)
 		(or (pop (echo-stream-unread-stuff stream))
 		    (let* ((in (echo-stream-input-stream stream))
 			   (out (echo-stream-output-stream stream))
-			   (result (,fun in ,@args)))
-		      (if (ansi-stream-p out)
-			  (funcall (,out-slot out) out result)
-			  (,stream-method out result))
-		      result)))))
-  (in-fun echo-in read-char ansi-stream-out stream-write-char
-	  eof-error-p eof-value)
-  (in-fun echo-bin read-byte ansi-stream-bout stream-write-byte
-	  eof-error-p eof-value))
-
-(defun echo-misc (stream operation &optional arg1 arg2)
-  (let* ((in (two-way-stream-input-stream stream))
-	 (out (two-way-stream-output-stream stream)))
-    (case operation
-      (:listen
-       (or (not (null (echo-stream-unread-stuff stream)))
-	   (if (ansi-stream-p in)
-	       (or (/= (the fixnum (ansi-stream-in-index in))
-		       +ansi-stream-in-buffer-length+)
-		   (funcall (ansi-stream-misc in) in :listen))
-	       (stream-misc-dispatch in :listen))))
-      (:unread (push arg1 (echo-stream-unread-stuff stream)))
-      (:element-type
-       (let ((in-type (stream-element-type in))
-	     (out-type (stream-element-type out)))
-	 (if (equal in-type out-type)
-	     in-type `(and ,in-type ,out-type))))
-      (:close
-       (set-closed-flame stream))
-      (:peek-char
-       ;; For the special case of peeking into an echo-stream
-       ;; arg1 is PEEK-TYPE, arg2 is (EOF-ERROR-P EOF-VALUE)
-       ;; returns peeked-char, eof-value, or errors end-of-file
-       ;;
-       ;; Note: This code could be moved into PEEK-CHAR if desired.
-       ;; I am unsure whether this belongs with echo-streams because it is
-       ;; echo-stream specific, or PEEK-CHAR because it is peeking code.
-       ;; -- mrd 2002-11-18
-       ;;
-       ;; UNREAD-CHAR-P indicates whether the current character was one
-       ;; that was previously unread.  In that case, we need to ensure that
-       ;; the semantics for UNREAD-CHAR are held; the character should
-       ;; not be echoed again.
-       (let ((unread-char-p nil))
-	 (flet ((outfn (c)
-		  (unless unread-char-p
-		    (if (ansi-stream-p out)
-			(funcall (ansi-stream-out out) out c)
-			;; gray-stream
-			(stream-write-char out c))))
-		(infn ()
-		  ;; Obtain input from unread buffer or input stream,
-		  ;; and set the flag appropriately.
-		  (cond ((not (null (echo-stream-unread-stuff stream)))
-			 (setf unread-char-p t)
-			 (pop (echo-stream-unread-stuff stream)))
-			(t
-			 (setf unread-char-p nil)
-			 (read-char in (first arg2) (second arg2))))))
-	   (generalized-peeking-mechanism
-	    arg1 (second arg2) char
-	    (infn)
-	    (unread-char char in)
-	    (outfn char)))))
-      (t
-       (or (if (ansi-stream-p in)
-	       (funcall (ansi-stream-misc in) in operation arg1 arg2)
-	       (stream-misc-dispatch in operation arg1 arg2))
-	   (if (ansi-stream-p out)
-	       (funcall (ansi-stream-misc out) out operation arg1 arg2)
-	       (stream-misc-dispatch out operation arg1 arg2)))))))
-
-;;;; 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)))
+			   (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))
+
+(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 #'string-binch)
-		       (n-bin #'string-stream-read-n-bytes)
-		       (misc #'string-in-misc)
-                       (string (missing-arg)
-			       :type (simple-array character (*))))
+		       (bin #'ill-bin)
+		       (n-bin #'ill-bin)
+		       (misc #'string-in-misc))
 	     (:constructor internal-make-string-input-stream
 			   (string current end))
 	     (:copier nil))
-  (current nil :type index)
-  (end nil :type index))
+  (string (missing-arg) :type simple-string)
+  (current (missing-arg) :type index)
+  (end (missing-arg) :type index))
 
 (defun string-inch (stream eof-error-p eof-value)
+  (declare (type string-input-stream stream))
   (let ((string (string-input-stream-string stream))
 	(index (string-input-stream-current stream)))
-    (declare (type (simple-array character (*)) string)
-	     (type fixnum index))
-    (cond ((= index (the index (string-input-stream-end stream)))
+    (cond ((>= index (the index (string-input-stream-end stream)))
 	   (eof-or-lose stream eof-error-p eof-value))
 	  (t
 	   (setf (string-input-stream-current stream) (1+ index))
-	   (aref string index)))))
+	   (char string index)))))
 
 (defun string-binch (stream eof-error-p eof-value)
+  (declare (type string-input-stream stream))
   (let ((string (string-input-stream-string stream))
 	(index (string-input-stream-current stream)))
-    (declare (type (simple-array character (*)) string)
-	     (type index index))
-    (cond ((= index (the index (string-input-stream-end stream)))
+    (cond ((>= index (the index (string-input-stream-end stream)))
 	   (eof-or-lose stream eof-error-p eof-value))
 	  (t
 	   (setf (string-input-stream-current stream) (1+ index))
-	   (char-code (aref string index))))))
+	   (char-code (char string index))))))
 
 (defun string-stream-read-n-bytes (stream buffer start requested eof-error-p)
   (declare (type string-input-stream stream)
@@ -1136,71 +1096,94 @@
 	 (index (string-input-stream-current stream))
 	 (available (- (string-input-stream-end stream) index))
 	 (copy (min available requested)))
-    (declare (type (simple-array character (*)) string)
-	     (type index index available copy))
+    (declare (type simple-string string))
     (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)))
 
 (defun string-in-misc (stream operation &optional arg1 arg2)
-  (declare (ignore arg2))
+  (declare (type string-input-stream stream)
+	   (ignore arg2))
   (case operation
     (:file-position
      (if arg1
-	 (setf (string-input-stream-current stream) arg1)
+	 (setf (string-input-stream-current stream)
+	       (case arg1
+		 (:start 0)
+		 (:end (string-input-stream-end stream))
+		 ;; We allow moving position beyond EOF. Errors happen
+		 ;; on read, not move -- or the user may extend the
+		 ;; input string.
+		 (t arg1)))
 	 (string-input-stream-current stream)))
-    (:file-length (length (string-input-stream-string stream)))
+    ;; According to ANSI: "Should signal an error of type type-error
+    ;; if stream is not a stream associated with a file."
+    ;; 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)))
-    (:listen (or (/= (the fixnum (string-input-stream-current stream))
-		     (the fixnum (string-input-stream-end stream)))
+    (:close (set-closed-flame stream))
+    (:listen (or (/= (the index (string-input-stream-current stream))
+		     (the index (string-input-stream-end stream)))
 		 :eof))
-    (:element-type 'base-char)))
+    (:element-type (array-element-type (string-input-stream-string stream)))))
 
-(defun make-string-input-stream (string &optional
-					(start 0) end)
+(defun make-string-input-stream (string &optional (start 0) end)
   #!+sb-doc
   "Return an input stream which will supply the characters of STRING between
   START and END in order."
   (declare (type string string)
 	   (type index start)
 	   (type (or index null) end))
-  
-  (internal-make-string-input-stream
-   (coerce string 'simple-string)
-   start
-   (%check-vector-sequence-bounds string start end)))
+  (let* ((string (coerce string '(simple-array character (*))))
+	 (end (%check-vector-sequence-bounds string start end)))
+    (with-array-data ((string string) (start start) (end end))
+      (internal-make-string-input-stream
+       string ;; now simple
+       start
+       end))))
 
 ;;;; 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 (make-string 40)
-			      :type (simple-array character (*))))
-	    (:constructor make-string-output-stream ())
+		      (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 0 :type fixnum)
+  ;; Index cache for string-output-stream-last-index
+  (index-cache 0 :type fixnum)
+  ;; 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)))
+
 (defun string-ouch (stream character)
   (let ((current (string-output-stream-index stream))
 	(workspace (string-output-stream-string stream)))
@@ -1209,8 +1192,8 @@
     (if (= current (the fixnum (length workspace)))
 	(let ((new-workspace (make-string (* current 2))))
 	  (replace new-workspace workspace)
-	  (setf (aref new-workspace current) character)
-	  (setf (string-output-stream-string stream) new-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))))
 
@@ -1242,8 +1225,27 @@
   (declare (ignore arg2))
   (case operation
     (:file-position
-     (if (null arg1)
+     (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))
@@ -1254,16 +1256,33 @@
 		(type fixnum index count))
        (if (char= (schar string index) #\newline)
 	   (return count))))
-    (:element-type 'base-char)))
+    (:element-type (array-element-type (string-output-stream-string 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-index stream))
-	 (result (make-string length)))
-    (replace result (string-output-stream-string stream))
-    (setf (string-output-stream-index stream) 0)
+  (let* ((length (string-output-stream-last-index stream))
+	 (element-type (string-output-stream-element-type stream))
+	 (result 
+	  (case element-type
+	    ;; 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
+	  (string-output-stream-index-cache stream) 0)
     result))
 
 ;;; Dump the characters buffer up in IN-STREAM to OUT-STREAM as
@@ -1272,8 +1291,9 @@
   (%write-string (string-output-stream-string in-stream)
 		 out-stream
 		 0
-		 (string-output-stream-index in-stream))
-  (setf (string-output-stream-index in-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))
 
 ;;;; fill-pointer streams
 
@@ -1281,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 (error "missing argument")
-                              :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))
@@ -1310,11 +1329,11 @@
 	(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)
-	      (setf workspace new-workspace)
-	      (setf offset-current 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
 				current+1 0 new-length nil))
 	    (setf (fill-pointer buffer) current+1))
@@ -1340,26 +1359,40 @@
 	    (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)))
+       (if arg1
+	   (setf (fill-pointer buffer)
+		 (case arg1
+		   (:start 0)
+		   ;; Fill-pointer is always at fill-pointer we will
+		   ;; make :END move to the end of the actual string.
+		   (:end (array-total-size buffer))
+		   ;; We allow moving beyond the end of string if the
+		   ;; string is adjustable.
+		   (t (when (>= arg1 (array-total-size buffer))
+			(if (adjustable-array-p buffer)
+			    (adjust-array buffer arg1)
+			    (error "Cannot move FILE-POSITION beyond the end ~
+                                    of WITH-OUTPUT-TO-STRING stream ~
+                                    constructed with non-adjustable string.")))
+		      arg1)))
+	   (fill-pointer buffer))))
     (:charpos
      (let* ((buffer (fill-pointer-output-stream-string stream))
 	    (current (fill-pointer buffer)))
@@ -1370,7 +1403,8 @@
 	   (if found
 	       (- end (the fixnum found))
 	       current)))))
-     (:element-type 'base-char)))
+     (:element-type (array-element-type
+		     (fill-pointer-output-stream-string stream)))))
 
 ;;;; indenting streams
 
@@ -1397,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)))))
@@ -1470,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)
@@ -1504,7 +1538,8 @@
 (defun case-frob-misc (stream op &optional arg1 arg2)
   (declare (type case-frob-stream stream))
   (case op
-    (:close)
+    (:close
+     (set-closed-flame stream))
     (t
      (let ((target (case-frob-stream-target stream)))
        (if (ansi-stream-p target)
@@ -1513,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)
@@ -1522,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))
@@ -1538,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)
@@ -1547,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))
@@ -1563,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)))
@@ -1580,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))
@@ -1607,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)))
@@ -1625,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))
@@ -1652,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)))
@@ -1670,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))
@@ -1724,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)))))
@@ -1739,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)))))))))))
@@ -1790,28 +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.
-
-;;; (These were inline throughout this file, but that's not appropriate
-;;; globally.)
-(declaim (maybe-inline read-char unread-char read-byte listen))