X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=bd541c69c15fdfb3393581f37a64e84cd8cf2d54;hb=15d6e7c9a2c3234f95dfe278046fa2fee1b0c007;hp=77c29bcd95b0ece7f57df85db18526980d5a0dce;hpb=6fd484302b8bf89803e3246a61412dc13191ffb2;p=sbcl.git

diff --git a/src/code/stream.lisp b/src/code/stream.lisp
index 77c29bc..bd541c6 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)
@@ -143,19 +142,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".
@@ -200,12 +205,10 @@
 
 ;;;; 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,174 +235,128 @@
 		     ;; 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-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)))))
+
 (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))
-  (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+)
+      ;; Test for T explicitly since misc methods return :EOF sometimes.
+      (eq (funcall (ansi-stream-misc stream) stream :listen) t)))
 
 (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)
@@ -520,12 +477,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))))
 
@@ -543,21 +504,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.
@@ -608,7 +576,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
@@ -660,10 +628,7 @@
 
 (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))))
@@ -680,8 +645,20 @@
 (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
@@ -690,10 +667,26 @@
 	   (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)))))))
+      (: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))))))
+      (:close
+       (set-closed-flame stream))
       (t
        (let ((res nil))
 	 (dolist (stream streams res)
@@ -785,17 +778,11 @@
   ;; 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)))
@@ -858,20 +845,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
@@ -883,10 +860,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))))
@@ -894,66 +868,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
 
@@ -962,7 +938,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)
@@ -978,17 +954,11 @@
   "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)))
@@ -999,73 +969,44 @@
 		(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))
 
-(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)))))))
+(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)))))
 
 ;;;; base STRING-STREAM stuff
 
@@ -1159,6 +1100,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))
@@ -1171,7 +1113,8 @@
   (declare (type string string)
 	   (type index start)
 	   (type (or index null) end))
-  (let ((end (%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
@@ -1269,6 +1212,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))
@@ -1396,7 +1340,7 @@
     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)))
@@ -1562,7 +1506,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)
@@ -1782,14 +1727,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)))))
@@ -1800,23 +1745,20 @@
 		(simple-array (signed-byte 8) (*))
 		simple-string)
 	    (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)))))))))))
@@ -1848,6 +1790,9 @@
       (list
        (let ((write-function
 	      (if (subtypep (stream-element-type stream) 'character)
+                  ;; FIXME (rudi 2004-08-09): since we know we're an
+                  ;; ansi stream here, we could replace these
+                  ;; functions with ansi-stream-specific constructs
 		  #'write-char
 		  #'write-byte)))
 	 (do ((rem (nthcdr start seq) (rest rem))
@@ -1861,6 +1806,9 @@
       (vector
        (let ((write-function
 	      (if (subtypep (stream-element-type stream) 'character)
+                  ;; FIXME (rudi 2004-08-09): since we know we're an
+                  ;; ansi stream here, we could replace these
+                  ;; functions with ansi-specific constructs
 		  #'write-char
 		  #'write-byte)))
 	 (do ((i start (1+ i)))