X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=244425d297ea0d5637311716fa9785d5813d3b64;hb=416152f084604094445a758ff399871132dff2bd;hp=053f0b2deae42ef98cf5d4fa081532e9e72a0557;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git

diff --git a/src/code/stream.lisp b/src/code/stream.lisp
index 053f0b2..244425d 100644
--- a/src/code/stream.lisp
+++ b/src/code/stream.lisp
@@ -11,9 +11,6 @@
 
 (in-package "SB!IMPL")
 
-(file-comment
-  "$Header$")
-
 (deftype string-stream ()
   '(or string-input-stream string-output-stream
        fill-pointer-output-stream))
@@ -68,7 +65,7 @@
 ;;;
 ;;; Many of the slots of the stream structure contain functions
 ;;; which are called to perform some operation on the stream. Closed
-;;; streams have #'Closed-Flame in all of their function slots. If
+;;; streams have #'CLOSED-FLAME in all of their function slots. If
 ;;; one side of an I/O or echo stream is closed, the whole stream is
 ;;; considered closed. The functions in the operation slots take
 ;;; arguments as follows:
@@ -82,7 +79,7 @@
 ;;; Misc:		Stream, Operation, &Optional Arg1, Arg2
 ;;;
 ;;; In order to save space, some of the less common stream operations
-;;; are handled by just one function, the Misc method. This function
+;;; are handled by just one function, the MISC method. This function
 ;;; is passed a keyword which indicates the operation to perform.
 ;;; The following keywords are used:
 ;;;  :listen 		- Return the following values:
@@ -98,11 +95,12 @@
 ;;;  :finish-output,
 ;;;  :force-output	- Cause output to happen
 ;;;  :clear-output	- Clear any undone output
-;;;  :element-type 	- Return the type of element the stream deals wit<h.
+;;;  :element-type 	- Return the type of element the stream deals with.
 ;;;  :line-length	- Return the length of a line of output.
 ;;;  :charpos		- Return current output position on the line.
 ;;;  :file-length	- Return the file length of a file stream.
-;;;  :file-position	- Return or change the current position of a file stream.
+;;;  :file-position	- Return or change the current position of a
+;;;                       file stream.
 ;;;  :file-name		- Return the name of an associated file.
 ;;;  :interactive-p     - Is this an interactive device?
 ;;;
@@ -112,29 +110,29 @@
 ;;;
 ;;; THE STREAM IN-BUFFER:
 ;;;
-;;; The In-Buffer in the stream holds characters or bytes that
+;;; The IN-BUFFER in the stream holds characters or bytes that
 ;;; are ready to be read by some input function. If there is any
-;;; stuff in the In-Buffer, then the reading function can use it
+;;; stuff in the IN-BUFFER, then the reading function can use it
 ;;; without calling any stream method. Any stream may put stuff in
-;;; the In-Buffer, and may also assume that any input in the In-Buffer
+;;; the IN-BUFFER, and may also assume that any input in the IN-BUFFER
 ;;; has been consumed before any in-method is called. If a text
-;;; stream has in In-Buffer, then the first character should not be
+;;; stream has in IN-BUFFER, then the first character should not be
 ;;; used to buffer normal input so that it is free for unreading into.
 ;;;
-;;; The In-Buffer slot is a vector In-Buffer-Length long. The
-;;; In-Index is the index in the In-Buffer of the first available
-;;; object. The available objects are thus between In-Index and the
-;;; length of the In-Buffer.
+;;; The IN-BUFFER slot is a vector +IN-BUFFER-LENGTH+ long. The
+;;; IN-INDEX is the index in the IN-BUFFER of the first available
+;;; object. The available objects are thus between IN-INDEX and the
+;;; length of the IN-BUFFER.
 ;;;
 ;;; When this buffer is only accessed by the normal stream
 ;;; functions, the number of function calls is halved, thus
 ;;; potentially doubling the speed of simple operations. If the
-;;; Fast-Read-Char and Fast-Read-Byte macros are used, nearly all
+;;; FAST-READ-CHAR and FAST-READ-BYTE macros are used, nearly all
 ;;; function call overhead is removed, vastly speeding up these
 ;;; important operations.
 ;;;
-;;; If a stream does not have an In-Buffer, then the In-Buffer slot
-;;; must be nil, and the In-Index must be In-Buffer-Length. These are
+;;; If a stream does not have an IN-BUFFER, then the IN-BUFFER slot
+;;; must be nil, and the IN-INDEX must be +IN-BUFFER-LENGTH+. These are
 ;;; the default values for the slots.
 
 ;;; stream manipulation functions
@@ -181,10 +179,6 @@
   (declare (type stream stream))
   (funcall (lisp-stream-misc stream) stream :interactive-p))
 
-(defun open-stream-p (stream)
-  (declare (type stream stream))
-  (not (eq (lisp-stream-in stream) #'closed-flame)))
-
 (defun close (stream &key abort)
   (declare (type stream stream))
   (when (open-stream-p stream)
@@ -203,37 +197,55 @@
 
 ;;;; file position and file length
 
-;;; Call the misc method with the :file-position operation.
+;;; Call the MISC method with the :FILE-POSITION operation.
 (defun file-position (stream &optional position)
   (declare (type stream stream))
   (declare (type (or index (member nil :start :end)) position))
   (cond
    (position
-    (setf (lisp-stream-in-index stream) in-buffer-length)
+    (setf (lisp-stream-in-index stream) +in-buffer-length+)
     (funcall (lisp-stream-misc stream) stream :file-position position))
    (t
     (let ((res (funcall (lisp-stream-misc stream) stream :file-position nil)))
-      (when res (- res (- in-buffer-length (lisp-stream-in-index stream))))))))
-
-;;; declaration test functions
+      (when res
+	(- res (- +in-buffer-length+ (lisp-stream-in-index stream))))))))
 
-#!+high-security
-(defun stream-associated-with-file (stream)
-  #!+sb-doc
-  "Tests if the stream is associated with a file"
-  (or (typep stream 'file-stream)
-      (and (synonym-stream-p stream)
-	   (typep (symbol-value (synonym-stream-symbol stream))
-		  'file-stream))))
-
-;;; Like File-Position, only use :file-length.
+;;; This is a literal translation of the ANSI glossary entry "stream
+;;; associated with a file".
+;;;
+;;; KLUDGE: Note that since Unix famously thinks "everything is a
+;;; file", and in particular stdin, stdout, and stderr are files, we
+;;; end up with this test being satisfied for weird things like
+;;; *STANDARD-OUTPUT* (to a tty). That seems unlikely to be what the
+;;; ANSI spec really had in mind, especially since this is used as a
+;;; qualification for operations like FILE-LENGTH (so that ANSI was
+;;; probably thinking of something like what Unix calls block devices)
+;;; but I can't see any better way to do it. -- WHN 2001-04-14
+(defun stream-associated-with-file-p (x)
+  "Test for the ANSI concept \"stream associated with a file\"."
+  (or (typep x 'file-stream)
+      (and (synonym-stream-p x)
+	   (stream-associated-with-file-p (symbol-value
+					   (synonym-stream-symbol x))))))
+
+(defun stream-must-be-associated-with-file (stream)
+  (declare (type stream stream))
+  (unless (stream-associated-with-file-p stream)
+    (error 'simple-type-error
+	   ;; KLUDGE: The ANSI spec for FILE-LENGTH specifically says
+	   ;; this should be TYPE-ERROR. But what then can we use for
+	   ;; 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
+	   :expected-type '(satisfies stream-associated-with-file-p)
+	   :format-string
+	   "~@<The stream ~2I~_~S ~I~_isn't associated with a file.~:>"
+	   :format-arguments (list stream))))
+
+;;; like FILE-POSITION, only using :FILE-LENGTH
 (defun file-length (stream)
   (declare (type (or file-stream synonym-stream) stream))
-
-  #!+high-security
-  (check-type-var stream '(satisfies stream-associated-with-file)
-		  "a stream associated with a file")
-
+  (stream-must-be-associated-with-file stream)
   (funcall (lisp-stream-misc stream) stream :file-length))
 
 ;;;; input functions
@@ -271,7 +283,7 @@
 		     (t
 		      (done-with-fast-read-char)
 		      (return (values (shrink-vector res index) t))))))))
-	;; must be FUNDAMENTAL-STREAM
+	;; 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)
@@ -292,7 +304,7 @@
 	  (prog1
 	      (fast-read-char eof-error-p eof-value)
 	    (done-with-fast-read-char)))
-	;; FUNDAMENTAL-STREAM
+	;; 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)
@@ -304,22 +316,34 @@
 	(let ((index (1- (lisp-stream-in-index stream)))
 	      (buffer (lisp-stream-in-buffer stream)))
 	  (declare (fixnum index))
-	  (when (minusp index) (error "Nothing to unread."))
+	  (when (minusp index) (error "nothing to unread"))
 	  (cond (buffer
 		 (setf (aref buffer index) (char-code character))
 		 (setf (lisp-stream-in-index stream) index))
 		(t
 		 (funcall (lisp-stream-misc stream) stream
 			  :unread character))))
-	;; Fundamental-stream
+	;; must be Gray streams FUNDAMENTAL-STREAM
 	(stream-unread-char stream character)))
   nil)
 
 (defun peek-char (&optional (peek-type nil)
 			    (stream *standard-input*)
 			    (eof-error-p t)
-			    eof-value recursive-p)
-
+			    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)))
     (if (lisp-stream-p stream)
 	(let ((char (read-char stream eof-error-p eof-value)))
@@ -336,12 +360,15 @@
 		      (unless (eq char eof-value)
 			(unread-char char stream))
 		      char)))
-		(t
+		((null peek-type)
 		 (unread-char char stream)
-		 char)))
-	;; Fundamental-stream.
+		 char)
+		(t
+		 (error "internal error: impossible case"))))
+	;; by elimination, must be Gray streams FUNDAMENTAL-STREAM
 	(cond ((characterp peek-type)
-	       (do ((char (stream-read-char stream) (stream-read-char stream)))
+	       (do ((char (stream-read-char stream)
+			  (stream-read-char stream)))
 		   ((or (eq char :eof) (char= char peek-type))
 		    (cond ((eq char :eof)
 			   (eof-or-lose stream eof-error-p eof-value))
@@ -349,26 +376,29 @@
 			   (stream-unread-char stream char)
 			   char)))))
 	      ((eq peek-type t)
-	       (do ((char (stream-read-char stream) (stream-read-char stream)))
+	       (do ((char (stream-read-char stream)
+			  (stream-read-char stream)))
 		   ((or (eq char :eof) (not (whitespace-char-p char)))
 		    (cond ((eq char :eof)
 			   (eof-or-lose stream eof-error-p eof-value))
 			  (t
 			   (stream-unread-char stream char)
 			   char)))))
-	      (t
+	      ((null peek-type)
 	       (let ((char (stream-peek-char stream)))
 		 (if (eq char :eof)
 		     (eof-or-lose stream eof-error-p eof-value)
-		     char)))))))
+		     char)))
+	      (t
+	       (error "internal error: impossible case"))))))
 
 (defun listen (&optional (stream *standard-input*))
   (let ((stream (in-synonym-of stream)))
     (if (lisp-stream-p stream)
-	(or (/= (the fixnum (lisp-stream-in-index stream)) in-buffer-length)
-	    ;; Test for t explicitly since misc methods return :eof sometimes.
+	(or (/= (the fixnum (lisp-stream-in-index stream)) +in-buffer-length+)
+	    ;; Test for T explicitly since misc methods return :EOF sometimes.
 	    (eq (funcall (lisp-stream-misc stream) stream :listen) t))
-	;; Fundamental-stream.
+	;; Fall through to Gray streams FUNDAMENTAL-STREAM case.
 	(stream-listen stream))))
 
 (defun read-char-no-hang (&optional (stream *standard-input*)
@@ -379,10 +409,10 @@
   (let ((stream (in-synonym-of stream)))
     (if (lisp-stream-p stream)
 	(if (funcall (lisp-stream-misc stream) stream :listen)
-	    ;; On t or :eof get READ-CHAR to do the work.
+	    ;; On T or :EOF get READ-CHAR to do the work.
 	    (read-char stream eof-error-p eof-value)
 	    nil)
-	;; Fundamental-stream.
+	;; 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)
@@ -391,7 +421,7 @@
 (defun clear-input (&optional (stream *standard-input*))
   (let ((stream (in-synonym-of stream)))
     (cond ((lisp-stream-p stream)
-	   (setf (lisp-stream-in-index stream) in-buffer-length)
+	   (setf (lisp-stream-in-index stream) +in-buffer-length+)
 	   (funcall (lisp-stream-misc stream) stream :clear-input))
 	  (t
 	   (stream-clear-input stream))))
@@ -405,7 +435,7 @@
 	  (prog1
 	      (fast-read-byte eof-error-p eof-value t)
 	    (done-with-fast-read-byte)))
-	;; FUNDAMENTAL-STREAM
+	;; must be Gray streams FUNDAMENTAL-STREAM
 	(let ((char (stream-read-byte stream)))
 	  (if (eq char :eof)
 	      (eof-or-lose stream eof-error-p eof-value)
@@ -414,12 +444,13 @@
 ;;; Read NUMBYTES bytes into BUFFER beginning at START, and return the
 ;;; number of bytes read.
 ;;;
-;;; Note: CMU CL's version of this had a special interpretation of EOF-ERROR-P
-;;; which SBCL does not have. (In the EOF-ERROR-P=NIL case, CMU CL's version
-;;; would return as soon as any data became available.) This could be useful
-;;; behavior for things like pipes in some cases, but it wasn't being used in
-;;; SBCL, so it was dropped. If we ever need it, it could be added later as a
-;;; new variant N-BIN method (perhaps N-BIN-ASAP?) or something.
+;;; Note: CMU CL's version of this had a special interpretation of
+;;; EOF-ERROR-P which SBCL does not have. (In the EOF-ERROR-P=NIL
+;;; case, CMU CL's version would return as soon as any data became
+;;; available.) This could be useful behavior for things like pipes in
+;;; some cases, but it wasn't being used in SBCL, so it was dropped.
+;;; If we ever need it, it could be added later as a new variant N-BIN
+;;; method (perhaps N-BIN-ASAP?) or something.
 (defun read-n-bytes (stream buffer start numbytes &optional (eof-error-p t))
   (declare (type lisp-stream stream)
 	   (type index numbytes start)
@@ -427,7 +458,7 @@
   (let* ((stream (in-synonym-of stream lisp-stream))
 	 (in-buffer (lisp-stream-in-buffer stream))
 	 (index (lisp-stream-in-index stream))
-	 (num-buffered (- in-buffer-length index)))
+	 (num-buffered (- +in-buffer-length+ index)))
     (declare (fixnum index num-buffered))
     (cond
      ((not in-buffer)
@@ -438,18 +469,14 @@
 	       numbytes
 	       eof-error-p))
      ((<= numbytes num-buffered)
-      (%primitive sb!c:byte-blt
-		  in-buffer
-		  index
-		  buffer
-		  start
-		  (+ start numbytes))
+      (%byte-blt in-buffer index
+		 buffer start (+ start numbytes))
       (setf (lisp-stream-in-index stream) (+ index numbytes))
       numbytes)
      (t
       (let ((end (+ start num-buffered)))
-	(%primitive sb!c:byte-blt in-buffer index buffer start end)
-	(setf (lisp-stream-in-index stream) in-buffer-length)
+	(%byte-blt in-buffer index buffer start end)
+	(setf (lisp-stream-in-index stream) +in-buffer-length+)
 	(+ (funcall (lisp-stream-n-bin stream)
 		    stream
 		    buffer
@@ -458,30 +485,31 @@
 		    eof-error-p)
 	   num-buffered))))))
 
-;;; the amount of space we leave at the start of the in-buffer for unreading
+;;; the amount of space we leave at the start of the in-buffer for
+;;; unreading
 ;;;
 ;;; (It's 4 instead of 1 to allow word-aligned copies.)
-(defconstant in-buffer-extra 4) ; FIXME: should be symbolic constant
+(defconstant +in-buffer-extra+ 4) ; FIXME: should be symbolic constant
 
-;;; This function is called by the fast-read-char expansion to refill the
-;;; in-buffer for text streams. There is definitely an in-buffer, and hence
-;;; must be an n-bin method.
+;;; This function is called by the FAST-READ-CHAR expansion to refill
+;;; 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 (lisp-stream-in-buffer stream))
 	 (count (funcall (lisp-stream-n-bin stream)
 			 stream
 			 ibuf
-			 in-buffer-extra
-			 (- in-buffer-length in-buffer-extra)
+			 +in-buffer-extra+
+			 (- +in-buffer-length+ +in-buffer-extra+)
 			 nil))
-	 (start (- in-buffer-length count)))
+	 (start (- +in-buffer-length+ count)))
     (declare (type index start count))
     (cond ((zerop count)
-	   (setf (lisp-stream-in-index stream) in-buffer-length)
+	   (setf (lisp-stream-in-index stream) +in-buffer-length+)
 	   (funcall (lisp-stream-in stream) stream eof-error-p eof-value))
 	  (t
-	   (when (/= start in-buffer-extra)
-	     (bit-bash-copy ibuf (+ (* in-buffer-extra sb!vm:byte-bits)
+	   (when (/= start +in-buffer-extra+)
+	     (bit-bash-copy ibuf (+ (* +in-buffer-extra+ sb!vm:byte-bits)
 				    (* sb!vm:vector-data-offset
 				       sb!vm:word-bits))
 			    ibuf (+ (the index (* start sb!vm:byte-bits))
@@ -491,17 +519,17 @@
 	   (setf (lisp-stream-in-index stream) (1+ start))
 	   (code-char (aref ibuf start))))))
 
-;;; Similar to FAST-READ-CHAR-REFILL, but we don't have to leave room for
-;;; unreading.
+;;; This is similar to FAST-READ-CHAR-REFILL, but we don't have to
+;;; leave room for unreading.
 (defun fast-read-byte-refill (stream eof-error-p eof-value)
   (let* ((ibuf (lisp-stream-in-buffer stream))
 	 (count (funcall (lisp-stream-n-bin stream) stream
-			 ibuf 0 in-buffer-length
+			 ibuf 0 +in-buffer-length+
 			 nil))
-	 (start (- in-buffer-length count)))
+	 (start (- +in-buffer-length+ count)))
     (declare (type index start count))
     (cond ((zerop count)
-	   (setf (lisp-stream-in-index stream) in-buffer-length)
+	   (setf (lisp-stream-in-index stream) +in-buffer-length+)
 	   (funcall (lisp-stream-bin stream) stream eof-error-p eof-value))
 	  (t
 	   (unless (zerop start)
@@ -530,36 +558,33 @@
 	(when (/= (or (charpos stream) 1) 0)
 	  (funcall (lisp-stream-out stream) stream #\newline)
 	  t)
-	;; Fundamental-stream.
+	;; must be Gray streams FUNDAMENTAL-STREAM
 	(stream-fresh-line stream))))
 
 (defun write-string (string &optional (stream *standard-output*)
-			    &key (start 0) (end (length (the vector string))))
-
-  ;; FIXME: These SETFs don't look right to me. Looking at the definition
-  ;; of "bounding indices" in the glossary of the ANSI spec, and extrapolating
-  ;; from the behavior of other operations when their operands are the
-  ;; wrong type, it seems that it would be more correct to essentially
-  ;;    (ASSERT (<= 0 START END (LENGTH STRING)))
-  ;; instead of modifying the incorrect values.
-  #!+high-security
-  (setf end (min end (length (the vector string))))
-  #!+high-security
-  (setf start (max start 0))
-
-  ;; FIXME: And I'd just signal a non-continuable error..
-  #!+high-security
-  (when (< end start)
-      (cerror "Continue with switched start and end ~S <-> ~S"
-	      "Write-string: start (~S) and end (~S) exchanged."
-	      start end string)
-      (rotatef start end))
+			    &key (start 0) (end nil))
+  (%write-string string stream start (or end (length string)))
+  string)
 
-  (write-string* string stream start end))
+(defun %write-string (string stream start end)
+  (declare (type string string))
+  (declare (type streamlike stream))
+  (declare (type index start end))
+
+  ;; Note that even though you might expect, based on the behavior of
+  ;; things like AREF, that the correct upper bound here is
+  ;; (ARRAY-DIMENSION STRING 0), the ANSI glossary definitions for
+  ;; "bounding index" and "length" indicate that in this case (i.e.
+  ;; for the ANSI-specified functions WRITE-STRING and WRITE-LINE
+  ;; which are implemented in terms of this function), (LENGTH STRING)
+  ;; is the required upper bound. A foolish consistency is the
+  ;; hobgoblin of lesser languages..
+  (unless (<= 0 start end (length string))
+    (error "~@<bad bounding indices START=~W END=~W for ~2I~_~S~:>"
+	   start
+	   end
+	   string))
 
-(defun write-string* (string &optional (stream *standard-output*)
-			     (start 0) (end (length (the vector string))))
-  (declare (fixnum start end))
   (let ((stream (out-synonym-of stream)))
     (cond ((lisp-stream-p stream)
 	   (if (array-header-p string)
@@ -569,29 +594,16 @@
 			  stream data offset-start offset-end))
 	       (funcall (lisp-stream-sout stream) stream string start end))
 	   string)
-	  (t	; Fundamental-stream.
+	  (t ; must be Gray streams FUNDAMENTAL-STREAM
 	   (stream-write-string stream string start end)))))
 
 (defun write-line (string &optional (stream *standard-output*)
-			  &key (start 0) (end (length string)))
-  (write-line* string stream start end))
-
-(defun write-line* (string &optional (stream *standard-output*)
-			   (start 0) (end (length string)))
-  (declare (fixnum start end))
-  (let ((stream (out-synonym-of stream)))
-    (cond ((lisp-stream-p stream)
-	   (if (array-header-p string)
-	       (with-array-data ((data string) (offset-start start)
-				 (offset-end end))
-		 (with-out-stream stream (lisp-stream-sout data offset-start
-							   offset-end)))
-	       (with-out-stream stream (lisp-stream-sout string start end)))
-	   (funcall (lisp-stream-out stream) stream #\newline))
-	  (t	; Fundamental-stream.
-	   (stream-write-string stream string start end)
-	   (stream-write-char stream #\Newline)))
-    string))
+			  &key (start 0) (end nil))
+  (let ((defaulted-stream (out-synonym-of stream))
+	(defaulted-end (or end (length string))))
+    (%write-string string defaulted-stream start defaulted-end)
+    (write-char #\newline defaulted-stream))
+  string)
 
 (defun charpos (&optional (stream *standard-output*))
   (with-out-stream stream (lisp-stream-misc :charpos) (stream-line-column)))
@@ -616,20 +628,19 @@
   nil)
 
 (defun write-byte (integer stream)
-  (with-out-stream stream (lisp-stream-bout integer) (stream-write-byte))
+  (with-out-stream stream (lisp-stream-bout integer)
+		   (stream-write-byte integer))
   integer)
 
-;;; Stream-misc-dispatch
-;;;
-;;; Called from lisp-steam routines that encapsulate CLOS streams to
-;;; handle the misc routines and dispatch to the appropriate Gray
-;;; stream functions.
+;;; This is called from LISP-STREAM routines that encapsulate CLOS
+;;; streams to handle the misc routines and dispatch to the
+;;; appropriate Gray stream functions.
 (defun stream-misc-dispatch (stream operation &optional arg1 arg2)
   (declare (type fundamental-stream stream)
 	   (ignore arg2))
   (case operation
     (:listen
-     ;; Return true is input available, :eof for eof-of-file, otherwise Nil.
+     ;; Return T if input available, :EOF for end-of-file, otherwise NIL.
      (let ((char (stream-read-char-no-hang stream)))
        (when (characterp char)
 	 (stream-unread-char stream char))
@@ -667,8 +678,10 @@
 			     (:constructor #!-high-security-support
 					   make-broadcast-stream
 					   #!+high-security-support
-					   %make-broadcast-stream (&rest streams)))
-  ;; This is a list of all the streams we broadcast to.
+					   %make-broadcast-stream (&rest
+								   streams))
+			     (:copier nil))
+  ;; a list of all the streams we broadcast to
   (streams () :type list :read-only t))
 
 #!+high-security-support
@@ -730,7 +743,8 @@
 				     (bout #'synonym-bout)
 				     (sout #'synonym-sout)
 				     (misc #'synonym-misc))
-			   (:constructor make-synonym-stream (symbol)))
+			   (:constructor make-synonym-stream (symbol))
+			   (:copier nil))
   ;; This is the symbol, the value of which is the stream we are synonym to.
   (symbol nil :type symbol :read-only t))
 (def!method print-object ((x synonym-stream) stream)
@@ -762,16 +776,19 @@
   (in-fun synonym-bin read-byte eof-error-p eof-value)
   (in-fun synonym-n-bin read-n-bytes buffer start numbytes eof-error-p))
 
-;;; We have to special-case the operations which could look at stuff in
-;;; the in-buffer.
 (defun synonym-misc (stream operation &optional arg1 arg2)
   (declare (optimize (safety 1)))
   (let ((syn (symbol-value (synonym-stream-symbol stream))))
     (if (lisp-stream-p syn)
-	(case operation
+	;; We have to special-case some operations which interact with
+	;; the in-buffer of the wrapped stream, since just calling
+	;; LISP-STREAM-MISC on them
+ 	(case operation
 	  (:listen (or (/= (the fixnum (lisp-stream-in-index syn))
-			   in-buffer-length)
+			   +in-buffer-length+)
 		       (funcall (lisp-stream-misc syn) syn :listen)))
+          (:clear-input (clear-input syn))
+          (:unread (unread-char arg1 syn))
 	  (t
 	   (funcall (lisp-stream-misc syn) syn operation arg1 arg2)))
 	(stream-misc-dispatch syn operation arg1 arg2))))
@@ -790,24 +807,20 @@
 	    (:constructor #!-high-security-support
 			  make-two-way-stream
 			  #!+high-security-support
-			  %make-two-way-stream (input-stream output-stream)))
+			  %make-two-way-stream (input-stream output-stream))
+	    (:copier nil))
   (input-stream (required-argument) :type stream :read-only t)
   (output-stream (required-argument) :type stream :read-only t))
-(def!method print-object ((x two-way-stream) stream)
-  (print-unreadable-object (x stream :type t :identity t)
-    (format stream
-	    ":INPUT-STREAM ~S :OUTPUT-STREAM ~S"
-	    (two-way-stream-input-stream x)
-	    (two-way-stream-output-stream x))))
+(defprinter (two-way-stream) input-stream output-stream)
 
 #!-high-security-support
 (setf (fdocumentation 'make-two-way-stream 'function)
-  "Returns a bidirectional stream which gets its input from Input-Stream and
+  "Return a bidirectional stream which gets its input from Input-Stream and
    sends its output to Output-Stream.")
 #!+high-security-support
 (defun make-two-way-stream (input-stream output-stream)
   #!+sb-doc
-  "Returns a bidirectional stream which gets its input from Input-Stream and
+  "Return a bidirectional stream which gets its input from Input-Stream and
    sends its output to Output-Stream."
   ;; FIXME: This idiom of the-real-stream-of-a-possibly-synonym-stream
   ;; should be encapsulated in a function, and used here and most of
@@ -854,17 +867,15 @@
     (case operation
       (:listen
        (if in-lisp-stream-p
-	   (or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length)
+	   (or (/= (the fixnum (lisp-stream-in-index in)) +in-buffer-length+)
 	       (funcall (lisp-stream-misc in) in :listen))
 	   (stream-listen in)))
       ((:finish-output :force-output :clear-output)
        (if out-lisp-stream-p
 	   (funcall (lisp-stream-misc out) out operation arg1 arg2)
 	   (stream-misc-dispatch out operation arg1 arg2)))
-      ((:clear-input :unread)
-       (if in-lisp-stream-p
-	   (funcall (lisp-stream-misc in) in operation arg1 arg2)
-	   (stream-misc-dispatch in operation arg1 arg2)))
+      (:clear-input (clear-input in))
+      (:unread (unread-char arg1 in))
       (:element-type
        (let ((in-type (stream-element-type in))
 	     (out-type (stream-element-type out)))
@@ -886,15 +897,17 @@
 	    (:include lisp-stream
 		      (in #'concatenated-in)
 		      (bin #'concatenated-bin)
+		      (n-bin #'concatenated-n-bin)
 		      (misc #'concatenated-misc))
 	    (:constructor
 	     #!-high-security-support make-concatenated-stream
 	     #!+high-security-support %make-concatenated-stream
-		 (&rest streams &aux (current streams))))
-  ;; The car of this is the stream we are reading from now.
+		 (&rest streams &aux (current streams)))
+	    (:copier nil))
+  ;; The car of this is the substream we are reading from now.
   current
-  ;; This is a list of all the streams. We need to remember them so that
-  ;; we can close them.
+  ;; 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
@@ -930,7 +943,8 @@
 
 (macrolet ((in-fun (name fun)
 	     `(defun ,name (stream eof-error-p eof-value)
-		(do ((current (concatenated-stream-current stream) (cdr current)))
+		(do ((current (concatenated-stream-current stream)
+			      (cdr current)))
 		    ((null current)
 		     (eof-or-lose stream eof-error-p eof-value))
 		  (let* ((stream (car current))
@@ -940,6 +954,22 @@
   (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))
+       (current-start start)
+       (remaining-bytes numbytes))
+      ((null current)
+       (if eof-errorp
+	   (error 'end-of-file :stream stream)
+	   (- numbytes remaining-bytes)))
+    (let* ((stream (car current))
+           (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))))
+
 (defun concatenated-misc (stream operation &optional arg1 arg2)
   (let ((left (concatenated-stream-current stream)))
     (when left
@@ -952,7 +982,7 @@
 				       :listen)
 			      (stream-misc-dispatch current :listen))))
 	       (cond ((eq stuff :eof)
-		      ;; Advance current, and try again.
+		      ;; Advance CURRENT, and try again.
 		      (pop (concatenated-stream-current stream))
 		      (setf current
 			    (car (concatenated-stream-current stream)))
@@ -963,9 +993,11 @@
 		      ;; Stuff's available.
 		      (return t))
 		     (t
-		      ;; Nothing available yet.
+		      ;; Nothing is available yet.
 		      (return nil))))))
-	  (:close
+          (:clear-input (clear-input current))
+          (:unread (unread-char arg1 current))
+          (:close
 	   (set-closed-flame stream))
 	  (t
 	   (if (lisp-stream-p current)
@@ -980,7 +1012,8 @@
 		      (bin #'echo-bin)
 		      (misc #'echo-misc)
 		      (n-bin #'ill-bin))
-	    (:constructor make-echo-stream (input-stream output-stream)))
+	    (:constructor make-echo-stream (input-stream output-stream))
+	    (:copier nil))
   unread-stuff)
 (def!method print-object ((x echo-stream) stream)
   (print-unreadable-object (x stream :type t :identity t)
@@ -1011,7 +1044,8 @@
       (:listen
        (or (not (null (echo-stream-unread-stuff stream)))
 	   (if (lisp-stream-p in)
-	       (or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length)
+	       (or (/= (the fixnum (lisp-stream-in-index in))
+		       +in-buffer-length+)
 		   (funcall (lisp-stream-misc in) in :listen))
 	       (stream-misc-dispatch in :listen))))
       (:unread (push arg1 (echo-stream-unread-stuff stream)))
@@ -1045,7 +1079,8 @@
 		       (n-bin #'string-stream-read-n-bytes)
 		       (misc #'string-in-misc))
 	     (:constructor internal-make-string-input-stream
-			   (string current end)))
+			   (string current end))
+	     (:copier nil))
   (string nil :type simple-string)
   (current nil :type index)
   (end nil :type index))
@@ -1134,7 +1169,8 @@
 		      (out #'string-ouch)
 		      (sout #'string-sout)
 		      (misc #'string-out-misc))
-	    (:constructor make-string-output-stream ()))
+	    (:constructor make-string-output-stream ())
+	    (:copier nil))
   ;; The string we throw stuff in.
   (string (make-string 40) :type simple-string)
   ;; Index of the next location to use.
@@ -1195,10 +1231,9 @@
 	   (return count))))
     (:element-type 'base-char)))
 
+;;; 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)
-  #!+sb-doc
-  "Returns a string of all the characters sent to a stream made by
-   Make-String-Output-Stream since the last call to this function."
   (declare (type string-output-stream stream))
   (let* ((length (string-output-stream-index stream))
 	 (result (make-string length)))
@@ -1206,26 +1241,29 @@
     (setf (string-output-stream-index stream) 0)
     result))
 
+;;; Dump the characters buffer up in IN-STREAM to OUT-STREAM as
+;;; GET-OUTPUT-STREAM-STRING would return them.
 (defun dump-output-stream-string (in-stream out-stream)
-  #!+sb-doc
-  "Dumps the characters buffer up in the In-Stream to the Out-Stream as
-  Get-Output-Stream-String would return them."
-  (write-string* (string-output-stream-string in-stream) out-stream
-		 0 (string-output-stream-index in-stream))
+  (%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))
 
 ;;;; fill-pointer streams
 
-;;; Fill pointer string output streams are not explicitly mentioned in the CLM,
-;;; but they are required for the implementation of With-Output-To-String.
+;;; Fill pointer STRING-OUTPUT-STREAMs are not explicitly mentioned in
+;;; the CLM, but they are required for the implementation of
+;;; WITH-OUTPUT-TO-STRING.
 
 (defstruct (fill-pointer-output-stream
  	    (:include lisp-stream
 		      (out #'fill-pointer-ouch)
 		      (sout #'fill-pointer-sout)
 		      (misc #'fill-pointer-misc))
-	    (:constructor make-fill-pointer-output-stream (string)))
-  ;; The string we throw stuff in.
+	    (:constructor make-fill-pointer-output-stream (string))
+	    (:copier nil))
+  ;; the string we throw stuff in
   string)
 
 (defun fill-pointer-ouch (stream character)
@@ -1238,15 +1276,11 @@
       (let ((offset-current (+ start current)))
 	(declare (fixnum offset-current))
 	(if (= offset-current end)
-	    (let* ((new-length (* current 2))
+	    (let* ((new-length (1+ (* current 2)))
 		   (new-workspace (make-string new-length)))
 	      (declare (simple-string new-workspace))
-	      (%primitive sb!c:byte-blt
-			  workspace
-			  start
-			  new-workspace
-			  0
-			  current)
+	      (%byte-blt workspace start
+			 new-workspace 0 current)
 	      (setf workspace new-workspace)
 	      (setf offset-current current)
 	      (set-array-header buffer workspace new-length
@@ -1271,12 +1305,8 @@
 	    (let* ((new-length (+ (the fixnum (* current 2)) string-len))
 		   (new-workspace (make-string new-length)))
 	      (declare (simple-string new-workspace))
-	      (%primitive sb!c:byte-blt
-			  workspace
-			  dst-start
-			  new-workspace
-			  0
-			  current)
+	      (%byte-blt workspace dst-start
+			 new-workspace 0 current)
 	      (setf workspace new-workspace)
 	      (setf offset-current current)
 	      (setf offset-dst-end dst-end)
@@ -1288,12 +1318,8 @@
 				new-length
 				nil))
 	    (setf (fill-pointer buffer) dst-end))
-	(%primitive sb!c:byte-blt
-		    string
-		    start
-		    workspace
-		    offset-current
-		    offset-dst-end)))
+	(%byte-blt string start
+		   workspace offset-current offset-dst-end)))
     dst-end))
 
 (defun fill-pointer-misc (stream operation &optional arg1 arg2)
@@ -1317,7 +1343,8 @@
 				       (out #'indenting-out)
 				       (sout #'indenting-sout)
 				       (misc #'indenting-misc))
-			     (:constructor make-indenting-stream (stream)))
+			     (:constructor make-indenting-stream (stream))
+			     (:copier nil))
   ;; the stream we're based on
   stream
   ;; how much we indent on each line
@@ -1327,26 +1354,27 @@
 (setf (fdocumentation 'make-indenting-stream 'function)
  "Returns an output stream which indents its output by some amount.")
 
-;;; Indenting-Indent writes the correct number of spaces needed to indent
-;;; output on the given Stream based on the specified Sub-Stream.
+;;; INDENTING-INDENT writes the correct number of spaces needed to indent
+;;; output on the given STREAM based on the specified SUB-STREAM.
 (defmacro indenting-indent (stream sub-stream)
   ;; KLUDGE: bare magic number 60
   `(do ((i 0 (+ i 60))
 	(indentation (indenting-stream-indentation ,stream)))
        ((>= i indentation))
-     (write-string*
+     (%write-string
       "							    "
-      ,sub-stream 0 (min 60 (- indentation i)))))
+      ,sub-stream
+      0
+      (min 60 (- indentation i)))))
 
-;;; Indenting-Out writes a character to an indenting stream.
+;;; INDENTING-OUT writes a character to an indenting stream.
 (defun indenting-out (stream char)
   (let ((sub-stream (indenting-stream-stream stream)))
     (write-char char sub-stream)
     (if (char= char #\newline)
 	(indenting-indent stream sub-stream))))
 
-;;; Indenting-Sout writes a string to an indenting stream.
-
+;;; INDENTING-SOUT writes a string to an indenting stream.
 (defun indenting-sout (stream string start end)
   (declare (simple-string string) (fixnum start end))
   (do ((i start)
@@ -1354,17 +1382,16 @@
       ((= i end))
     (let ((newline (position #\newline string :start i :end end)))
       (cond (newline
-	     (write-string* string sub-stream i (1+ newline))
+	     (%write-string string sub-stream i (1+ newline))
 	     (indenting-indent stream sub-stream)
 	     (setq i (+ newline 1)))
 	    (t
-	     (write-string* string sub-stream i end)
+	     (%write-string string sub-stream i end)
 	     (setq i end))))))
 
-;;; Indenting-Misc just treats just the :Line-Length message differently.
-;;; Indenting-Charpos says the charpos is the charpos of the base stream minus
-;;; the stream's indentation.
-
+;;; INDENTING-MISC just treats just the :LINE-LENGTH message
+;;; differently. INDENTING-CHARPOS says the charpos is the charpos of
+;;; the base stream minus the stream's indentation.
 (defun indenting-misc (stream operation &optional arg1 arg2)
   (let ((sub-stream (indenting-stream-stream stream)))
     (if (lisp-stream-p sub-stream)
@@ -1380,7 +1407,7 @@
 		   (- charpos (indenting-stream-indentation stream)))))
 	    (t
 	     (funcall method sub-stream operation arg1 arg2))))
-	;; Fundamental-stream.
+	;; must be Gray streams FUNDAMENTAL-STREAM
 	(case operation
 	  (:line-length
 	   (let ((line-length (stream-line-length sub-stream)))
@@ -1395,12 +1422,13 @@
 
 (declaim (maybe-inline read-char unread-char read-byte listen))
 
-;;;; case frobbing streams, used by format ~(...~)
+;;;; case frobbing streams, used by FORMAT ~(...~)
 
 (defstruct (case-frob-stream
 	    (:include lisp-stream
 		      (:misc #'case-frob-misc))
-	    (:constructor %make-case-frob-stream (target out sout)))
+	    (:constructor %make-case-frob-stream (target out sout))
+	    (:copier nil))
   (target (required-argument) :type stream))
 
 (defun make-case-frob-stream (target kind)
@@ -1418,9 +1446,9 @@
 		 kind)
 	   (values stream))
   (if (case-frob-stream-p target)
-      ;; If we are going to be writing to a stream that already does case
-      ;; frobbing, why bother frobbing the case just so it can frob it
-      ;; again?
+      ;; If we are going to be writing to a stream that already does
+      ;; case frobbing, why bother frobbing the case just so it can
+      ;; frob it again?
       target
       (multiple-value-bind (out sout)
 	  (ecase kind
@@ -1629,33 +1657,35 @@
 	(funcall (lisp-stream-sout target) target str 0 len)
 	(stream-write-string target str 0 len))))
 
-;;;; public interface from "EXTENSIONS" package
+;;;; stream commands
 
 (defstruct (stream-command (:constructor make-stream-command
-					 (name &optional args)))
+					 (name &optional args))
+			   (:copier nil))
   (name nil :type symbol)
   (args nil :type list))
 (def!method print-object ((obj stream-command) str)
   (print-unreadable-object (obj str :type t :identity t)
     (prin1 (stream-command-name obj) str)))
 
+;;; Take a stream and wait for text or a command to appear on it. If
+;;; text appears before a command, return NIL, otherwise return a
+;;; command.
+;;;
 ;;; We can't simply call the stream's misc method because NIL is an
-;;; ambiguous return value: does it mean text arrived, or does it mean the
-;;; stream's misc method had no :GET-COMMAND implementation. We can't return
-;;; NIL until there is text input. We don't need to loop because any stream
-;;; implementing :get-command would wait until it had some input. If the
-;;; LISTEN fails, then we have some stream we must wait on.
+;;; ambiguous return value: does it mean text arrived, or does it mean
+;;; the stream's misc method had no :GET-COMMAND implementation? We
+;;; can't return NIL until there is text input. We don't need to loop
+;;; because any stream implementing :GET-COMMAND would wait until it
+;;; had some input. If the LISTEN fails, then we have some stream we
+;;; must wait on.
 (defun get-stream-command (stream)
-  #!+sb-doc
-  "This takes a stream and waits for text or a command to appear on it. If
-   text appears before a command, this returns nil, and otherwise it returns
-   a command."
   (let ((cmdp (funcall (lisp-stream-misc stream) stream :get-command)))
     (cond (cmdp)
 	  ((listen stream)
 	   nil)
 	  (t
-	   ;; This waits for input and returns nil when it arrives.
+	   ;; This waits for input and returns NIL when it arrives.
 	   (unread-char (read-char stream) stream)))))
 
 (defun read-sequence (seq stream &key (start 0) (end nil))
@@ -1739,7 +1769,7 @@
 		    (type index i))
 	   (funcall write-function (first rem) stream))))
       (string
-       (write-string* seq stream start end))
+       (%write-string seq stream start end))
       (vector
        (let ((write-function
 	      (if (subtypep (stream-element-type stream) 'character)