X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=aa91999f902618eeffebd680455c0c1bd00e5cf3;hb=02afc3779a467fd354d40db8b891f2d866f3d49a;hp=2daa1af6a5c1bd9aa06166822be0a3e6a1dc9b82;hpb=1ff04b3ba4e6f3a0fc6ceea524e98720ecea7888;p=sbcl.git diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 2daa1af..aa91999 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -11,21 +11,17 @@ (in-package "SB!IMPL") -(deftype string-stream () - '(or string-input-stream string-output-stream - fill-pointer-output-stream)) - ;;;; standard streams ;;; The initialization of these streams is performed by ;;; STREAM-COLD-INIT-OR-RESET. -(defvar *terminal-io* () #!+sb-doc "Terminal I/O stream.") -(defvar *standard-input* () #!+sb-doc "Default input stream.") -(defvar *standard-output* () #!+sb-doc "Default output stream.") -(defvar *error-output* () #!+sb-doc "Error output stream.") -(defvar *query-io* () #!+sb-doc "Query I/O stream.") -(defvar *trace-output* () #!+sb-doc "Trace output stream.") -(defvar *debug-io* () #!+sb-doc "Interactive debugging stream.") +(defvar *terminal-io* () #!+sb-doc "terminal I/O stream") +(defvar *standard-input* () #!+sb-doc "default input stream") +(defvar *standard-output* () #!+sb-doc "default output stream") +(defvar *error-output* () #!+sb-doc "error output stream") +(defvar *query-io* () #!+sb-doc "query I/O stream") +(defvar *trace-output* () #!+sb-doc "trace output stream") +(defvar *debug-io* () #!+sb-doc "interactive debugging stream") (defun ill-in (stream &rest ignore) (declare (ignore ignore)) @@ -58,180 +54,149 @@ (defun closed-flame (stream &rest ignore) (declare (ignore ignore)) (error "~S is closed." stream)) -(defun do-nothing (&rest ignore) +(defun no-op-placeholder (&rest ignore) (declare (ignore ignore))) -;;; HOW THE STREAM STRUCTURE IS USED: -;;; -;;; 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 -;;; 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: -;;; -;;; In: Stream, Eof-Errorp, Eof-Value -;;; Bin: Stream, Eof-Errorp, Eof-Value -;;; N-Bin: Stream, Buffer, Start, Numbytes, Eof-Errorp -;;; Out: Stream, Character -;;; Bout: Stream, Integer -;;; Sout: Stream, String, Start, End -;;; 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 -;;; is passed a keyword which indicates the operation to perform. -;;; The following keywords are used: -;;; :listen - Return the following values: -;;; t if any input waiting. -;;; :eof if at eof. -;;; nil if no input is available and not at eof. -;;; :unread - Unread the character Arg. -;;; :close - Do any stream specific stuff to close the stream. -;;; The methods are set to closed-flame by the close -;;; function, so that need not be done by this -;;; function. -;;; :clear-input - Clear any unread input -;;; :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" + :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") - - (funcall (lisp-stream-misc stream) stream :file-length)) + ;; FIXME: The following declaration uses yet undefined types, which + ;; cause cross-compiler hangup. + ;; + ;; (declare (type (or file-stream synonym-stream) stream)) + (stream-must-be-associated-with-file stream) + (funcall (ansi-stream-misc stream) stream :file-length)) ;;;; input functions @@ -239,7 +204,7 @@ recursive-p) (declare (ignore recursive-p)) (let ((stream (in-synonym-of stream))) - (if (lisp-stream-p stream) + (if (ansi-stream-p stream) (prepare-for-fast-read-char stream (let ((res (make-string 80)) (len 80) @@ -268,7 +233,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) @@ -284,12 +249,12 @@ recursive-p) (declare (ignore recursive-p)) (let ((stream (in-synonym-of stream))) - (if (lisp-stream-p 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))) - ;; 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) @@ -297,75 +262,119 @@ (defun unread-char (character &optional (stream *standard-input*)) (let ((stream (in-synonym-of stream))) - (if (lisp-stream-p stream) - (let ((index (1- (lisp-stream-in-index stream))) - (buffer (lisp-stream-in-buffer 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.")) + (when (minusp index) (error "nothing to unread")) (cond (buffer (setf (aref buffer index) (char-code character)) - (setf (lisp-stream-in-index stream) index)) + (setf (ansi-stream-in-index stream) index)) (t - (funcall (lisp-stream-misc stream) stream + (funcall (ansi-stream-misc stream) stream :unread character)))) - ;; Fundamental-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) - + 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 "~@" + :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))) - (cond ((eq char eof-value) char) - ((characterp peek-type) - (do ((char char (read-char stream eof-error-p eof-value))) - ((or (eq char eof-value) (char= char peek-type)) - (unless (eq char eof-value) - (unread-char char stream)) - char))) - ((eq peek-type t) - (do ((char char (read-char stream eof-error-p eof-value))) - ((or (eq char eof-value) (not (whitespace-char-p char))) - (unless (eq char eof-value) - (unread-char char stream)) - char))) - (t - (unread-char char stream) - char))) - ;; Fundamental-stream. - (cond ((characterp peek-type) - (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)) - (t - (stream-unread-char stream char) - char))))) - ((eq peek-type t) - (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 - (let ((char (stream-peek-char stream))) - (if (eq char :eof) - (eof-or-lose stream eof-error-p eof-value) - char))))))) + (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)))))) (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. - (eq (funcall (lisp-stream-misc stream) stream :listen) t)) - ;; Fundamental-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)) + ;; Fall through to Gray streams FUNDAMENTAL-STREAM case. (stream-listen stream)))) (defun read-char-no-hang (&optional (stream *standard-input*) @@ -374,12 +383,12 @@ recursive-p) (declare (ignore recursive-p)) (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. + (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) - ;; 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) @@ -387,9 +396,9 @@ (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) - (funcall (lisp-stream-misc stream) stream :clear-input)) + (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)))) nil) @@ -397,12 +406,12 @@ (declaim (maybe-inline read-byte)) (defun read-byte (stream &optional (eof-error-p t) eof-value) (let ((stream (in-synonym-of stream))) - (if (lisp-stream-p 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))) - ;; 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) @@ -411,43 +420,40 @@ ;;; 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) + (declare (type ansi-stream stream) (type index numbytes start) (type (or (simple-array * (*)) system-area-pointer) buffer)) - (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))) + (let* ((stream (in-synonym-of stream ansi-stream)) + (in-buffer (ansi-stream-in-buffer stream)) + (index (ansi-stream-in-index stream)) + (num-buffered (- +ansi-stream-in-buffer-length+ index))) (declare (fixnum index num-buffered)) (cond ((not in-buffer) - (funcall (lisp-stream-n-bin stream) + (funcall (ansi-stream-n-bin stream) stream buffer start numbytes eof-error-p)) ((<= numbytes num-buffered) - (%primitive sb!c:byte-blt - in-buffer - index - buffer - start - (+ start numbytes)) - (setf (lisp-stream-in-index stream) (+ index 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))) - (%primitive sb!c:byte-blt in-buffer index buffer start end) - (setf (lisp-stream-in-index stream) in-buffer-length) - (+ (funcall (lisp-stream-n-bin stream) + (%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 buffer end @@ -455,175 +461,154 @@ 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 +ansi-stream-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) + (let* ((ibuf (ansi-stream-in-buffer stream)) + (count (funcall (ansi-stream-n-bin stream) stream ibuf - in-buffer-extra - (- in-buffer-length in-buffer-extra) + +ansi-stream-in-buffer-extra+ + (- +ansi-stream-in-buffer-length+ + +ansi-stream-in-buffer-extra+) nil)) - (start (- in-buffer-length count))) + (start (- +ansi-stream-in-buffer-length+ count))) (declare (type index start count)) (cond ((zerop count) - (setf (lisp-stream-in-index stream) in-buffer-length) - (funcall (lisp-stream-in stream) stream eof-error-p eof-value)) + (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 in-buffer-extra) - (bit-bash-copy ibuf (+ (* in-buffer-extra sb!vm:byte-bits) + (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:word-bits)) - ibuf (+ (the index (* start sb!vm:byte-bits)) + sb!vm:n-word-bits)) + ibuf (+ (the index (* start sb!vm:n-byte-bits)) (* sb!vm:vector-data-offset - sb!vm:word-bits)) - (* count sb!vm:byte-bits))) - (setf (lisp-stream-in-index stream) (1+ start)) + sb!vm:n-word-bits)) + (* count sb!vm:n-byte-bits))) + (setf (ansi-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 + (let* ((ibuf (ansi-stream-in-buffer stream)) + (count (funcall (ansi-stream-n-bin stream) stream + ibuf 0 +ansi-stream-in-buffer-length+ nil)) - (start (- in-buffer-length count))) + (start (- +ansi-stream-in-buffer-length+ count))) (declare (type index start count)) (cond ((zerop count) - (setf (lisp-stream-in-index stream) in-buffer-length) - (funcall (lisp-stream-bin stream) stream eof-error-p eof-value)) + (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+) + (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:word-bits) - ibuf (+ (the index (* start sb!vm:byte-bits)) + (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:word-bits)) - (* count sb!vm:byte-bits))) - (setf (lisp-stream-in-index stream) (1+ start)) + sb!vm:n-word-bits)) + (* count sb!vm:n-byte-bits))) + (setf (ansi-stream-in-index stream) (1+ start)) (aref ibuf start))))) ;;; output functions (defun write-char (character &optional (stream *standard-output*)) - (with-out-stream stream (lisp-stream-out character) + (with-out-stream stream (ansi-stream-out character) (stream-write-char character)) character) (defun terpri (&optional (stream *standard-output*)) - (with-out-stream stream (lisp-stream-out #\newline) (stream-terpri)) + (with-out-stream stream (ansi-stream-out #\newline) (stream-terpri)) nil) (defun fresh-line (&optional (stream *standard-output*)) (let ((stream (out-synonym-of stream))) - (if (lisp-stream-p stream) + (if (ansi-stream-p stream) (when (/= (or (charpos stream) 1) 0) - (funcall (lisp-stream-out stream) stream #\newline) + (funcall (ansi-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)) - - (write-string* string stream start end)) + &key (start 0) end) + (declare (type string string)) + ;; 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]), + ;; (LENGTH STRING) is the required upper bound. A foolish + ;; consistency is the hobgoblin of lesser languages.. + (%write-string string stream start (%check-vector-sequence-bounds + string start end)) + string) -(defun write-string* (string &optional (stream *standard-output*) - (start 0) (end (length (the vector string)))) - (declare (fixnum start end)) +(defun %write-string (string stream start end) + (declare (type string string)) + (declare (type streamlike stream)) + (declare (type index start end)) (let ((stream (out-synonym-of stream))) - (cond ((lisp-stream-p stream) + (cond ((ansi-stream-p stream) (if (array-header-p string) (with-array-data ((data string) (offset-start start) (offset-end end)) - (funcall (lisp-stream-sout stream) + (funcall (ansi-stream-sout stream) stream data offset-start offset-end)) - (funcall (lisp-stream-sout stream) stream string start end)) + (funcall (ansi-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) + (declare (type string string)) + ;; FIXME: Why is there this difference between the treatments of the + ;; STREAM argument in WRITE-STRING and WRITE-LINE? + (let ((defaulted-stream (out-synonym-of stream))) + (%write-string string defaulted-stream start (%check-vector-sequence-bounds + string start end)) + (write-char #\newline defaulted-stream)) + string) (defun charpos (&optional (stream *standard-output*)) - (with-out-stream stream (lisp-stream-misc :charpos) (stream-line-column))) + (with-out-stream stream (ansi-stream-misc :charpos) (stream-line-column))) (defun line-length (&optional (stream *standard-output*)) - (with-out-stream stream (lisp-stream-misc :line-length) + (with-out-stream stream (ansi-stream-misc :line-length) (stream-line-length))) (defun finish-output (&optional (stream *standard-output*)) - (with-out-stream stream (lisp-stream-misc :finish-output) + (with-out-stream stream (ansi-stream-misc :finish-output) (stream-finish-output)) nil) (defun force-output (&optional (stream *standard-output*)) - (with-out-stream stream (lisp-stream-misc :force-output) + (with-out-stream stream (ansi-stream-misc :force-output) (stream-force-output)) nil) (defun clear-output (&optional (stream *standard-output*)) - (with-out-stream stream (lisp-stream-misc :clear-output) + (with-out-stream stream (ansi-stream-misc :clear-output) (stream-force-output)) nil) (defun write-byte (integer stream) - (with-out-stream stream - ;; FIXME: CMU CL had - ;; (stream-write-byte integer) - ;; which was broken unless Gray streams were installed. - ;; In order to make this work again, MNA replaced it with - ;; bare (LISP-STREAM-BOUT). Something more complicated will - ;; probably be required when Gray stream support is restored, - ;; in order to make those work too; but I dunno what it will be. - (lisp-stream-bout integer))) + (with-out-stream stream (ansi-stream-bout integer) + (stream-write-byte integer)) + integer) -;;; This is called from lisp-steam routines that encapsulate CLOS +;;; This is called from ANSI-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) @@ -631,7 +616,7 @@ (ignore arg2)) (case operation (:listen - ;; Return true if input available, :EOF for end-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)) @@ -661,19 +646,17 @@ ;;;; broadcast streams -(defstruct (broadcast-stream (:include lisp-stream +(defstruct (broadcast-stream (:include ansi-stream (out #'broadcast-out) (bout #'broadcast-bout) (sout #'broadcast-sout) (misc #'broadcast-misc)) - (:constructor #!-high-security-support - make-broadcast-stream - #!+high-security-support - %make-broadcast-stream (&rest streams))) + (:constructor %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 (defun make-broadcast-stream (&rest streams) (dolist (stream streams) (unless (or (and (synonym-stream-p stream) @@ -688,12 +671,12 @@ (macrolet ((out-fun (fun method stream-method &rest args) `(defun ,fun (stream ,@args) (dolist (stream (broadcast-stream-streams stream)) - (if (lisp-stream-p stream) + (if (ansi-stream-p stream) (funcall (,method stream) stream ,@args) (,stream-method stream ,@args)))))) - (out-fun broadcast-out lisp-stream-out stream-write-char char) - (out-fun broadcast-bout lisp-stream-bout stream-write-byte byte) - (out-fun broadcast-sout lisp-stream-sout stream-write-string + (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)) (defun broadcast-misc (stream operation &optional arg1 arg2) @@ -717,14 +700,14 @@ (let ((res nil)) (dolist (stream streams res) (setq res - (if (lisp-stream-p stream) - (funcall (lisp-stream-misc stream) stream operation + (if (ansi-stream-p stream) + (funcall (ansi-stream-misc stream) stream operation arg1 arg2) (stream-misc-dispatch stream operation arg1 arg2))))))))) ;;;; synonym streams -(defstruct (synonym-stream (:include lisp-stream +(defstruct (synonym-stream (:include ansi-stream (in #'synonym-in) (bin #'synonym-bin) (n-bin #'synonym-n-bin) @@ -732,7 +715,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) @@ -745,12 +729,12 @@ `(defun ,name (stream ,@args) (declare (optimize (safety 1))) (let ((syn (symbol-value (synonym-stream-symbol stream)))) - (if (lisp-stream-p syn) + (if (ansi-stream-p syn) (funcall (,slot syn) syn ,@args) (,stream-method syn ,@args)))))) - (out-fun synonym-out lisp-stream-out stream-write-char ch) - (out-fun synonym-bout lisp-stream-bout stream-write-byte n) - (out-fun synonym-sout lisp-stream-sout stream-write-string string start end)) + (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)) ;;; For the input methods, we just call the corresponding function on the ;;; synonymed stream. These functions deal with getting input out of @@ -764,24 +748,27 @@ (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 - (:listen (or (/= (the fixnum (lisp-stream-in-index syn)) - in-buffer-length) - (funcall (lisp-stream-misc syn) syn :listen))) + (if (ansi-stream-p syn) + ;; We have to special-case some operations which interact with + ;; the in-buffer of the wrapped stream, since just calling + ;; ANSI-STREAM-MISC on them + (case operation + (:listen (or (/= (the fixnum (ansi-stream-in-index syn)) + +ansi-stream-in-buffer-length+) + (funcall (ansi-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))) + (funcall (ansi-stream-misc syn) syn operation arg1 arg2))) (stream-misc-dispatch syn operation arg1 arg2)))) ;;;; two-way streams (defstruct (two-way-stream - (:include lisp-stream + (:include ansi-stream (in #'two-way-in) (bin #'two-way-bin) (n-bin #'two-way-n-bin) @@ -789,28 +776,16 @@ (bout #'two-way-bout) (sout #'two-way-sout) (misc #'two-way-misc)) - (:constructor #!-high-security-support - make-two-way-stream - #!+high-security-support - %make-two-way-stream (input-stream output-stream))) - (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)))) + (:constructor %make-two-way-stream (input-stream output-stream)) + (:copier nil)) + (input-stream (missing-arg) :type stream :read-only t) + (output-stream (missing-arg) :type stream :read-only t)) +(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 - 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 - sends its output to Output-Stream." + "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 ;; the other places that SYNONYM-STREAM-P appears. @@ -833,12 +808,12 @@ (macrolet ((out-fun (name slot stream-method &rest args) `(defun ,name (stream ,@args) (let ((syn (two-way-stream-output-stream stream))) - (if (lisp-stream-p syn) + (if (ansi-stream-p syn) (funcall (,slot syn) syn ,@args) (,stream-method syn ,@args)))))) - (out-fun two-way-out lisp-stream-out stream-write-char ch) - (out-fun two-way-bout lisp-stream-bout stream-write-byte n) - (out-fun two-way-sout lisp-stream-sout stream-write-string string start end)) + (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)) (macrolet ((in-fun (name fun &rest args) `(defun ,name (stream ,@args) @@ -851,22 +826,21 @@ (defun two-way-misc (stream operation &optional arg1 arg2) (let* ((in (two-way-stream-input-stream stream)) (out (two-way-stream-output-stream stream)) - (in-lisp-stream-p (lisp-stream-p in)) - (out-lisp-stream-p (lisp-stream-p out))) + (in-ansi-stream-p (ansi-stream-p in)) + (out-ansi-stream-p (ansi-stream-p out))) (case operation (:listen - (if in-lisp-stream-p - (or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length) - (funcall (lisp-stream-misc in) in :listen)) + (if in-ansi-stream-p + (or (/= (the fixnum (ansi-stream-in-index in)) + +ansi-stream-in-buffer-length+) + (funcall (ansi-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) + (if out-ansi-stream-p + (funcall (ansi-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))) @@ -875,28 +849,28 @@ (:close (set-closed-flame stream)) (t - (or (if in-lisp-stream-p - (funcall (lisp-stream-misc in) in operation arg1 arg2) + (or (if in-ansi-stream-p + (funcall (ansi-stream-misc in) in operation arg1 arg2) (stream-misc-dispatch in operation arg1 arg2)) - (if out-lisp-stream-p - (funcall (lisp-stream-misc out) out operation arg1 arg2) + (if out-ansi-stream-p + (funcall (ansi-stream-misc out) out operation arg1 arg2) (stream-misc-dispatch out operation arg1 arg2))))))) ;;;; concatenated streams (defstruct (concatenated-stream - (:include lisp-stream + (:include ansi-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. + (:constructor %make-concatenated-stream + (&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 @@ -910,15 +884,9 @@ ":STREAMS ~S" (concatenated-stream-streams x)))) -#!-high-security-support -(setf (fdocumentation 'make-concatenated-stream 'function) - "Returns a stream which takes its input from each of the Streams in turn, - going on to the next at EOF.") - -#!+high-security-support (defun make-concatenated-stream (&rest streams) #!+sb-doc - "Returns a stream which takes its input from each of the Streams in turn, + "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) @@ -932,16 +900,33 @@ (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)) (result (,fun stream nil nil))) (when result (return result))) - (setf (concatenated-stream-current stream) current))))) + (pop (concatenated-stream-current 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)) + (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 @@ -949,8 +934,8 @@ (case operation (:listen (loop - (let ((stuff (if (lisp-stream-p current) - (funcall (lisp-stream-misc current) current + (let ((stuff (if (ansi-stream-p current) + (funcall (ansi-stream-misc current) current :listen) (stream-misc-dispatch current :listen)))) (cond ((eq stuff :eof) @@ -967,11 +952,13 @@ (t ;; 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) - (funcall (lisp-stream-misc current) current operation arg1 arg2) + (if (ansi-stream-p current) + (funcall (ansi-stream-misc current) current operation arg1 arg2) (stream-misc-dispatch current operation arg1 arg2)))))))) ;;;; echo streams @@ -982,7 +969,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) @@ -991,19 +979,40 @@ (two-way-stream-input-stream x) (two-way-stream-output-stream x)))) +(defun make-echo-stream (input-stream output-stream) + #!+sb-doc + "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)) + (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)) + (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) `(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 (lisp-stream-p out) + (if (ansi-stream-p out) (funcall (,out-slot out) out result) (,stream-method out result)) result))))) - (in-fun echo-in read-char lisp-stream-out stream-write-char + (in-fun echo-in read-char ansi-stream-out stream-write-char eof-error-p eof-value) - (in-fun echo-bin read-byte lisp-stream-bout stream-write-byte + (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) @@ -1012,9 +1021,10 @@ (case operation (: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) - (funcall (lisp-stream-misc in) in :listen)) + (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 @@ -1024,31 +1034,69 @@ 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 (lisp-stream-p in) - (funcall (lisp-stream-misc in) in operation arg1 arg2) + (or (if (ansi-stream-p in) + (funcall (ansi-stream-misc in) in operation arg1 arg2) (stream-misc-dispatch in operation arg1 arg2)) - (if (lisp-stream-p out) - (funcall (lisp-stream-misc out) out 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 -#!+sb-doc -(setf (fdocumentation 'make-echo-stream 'function) - "Returns 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") +(defstruct (string-stream + (:include ansi-stream) + (:constructor nil) + (:copier nil)) + (string nil :type string)) -;;;; string input streams +;;;; STRING-INPUT-STREAM stuff (defstruct (string-input-stream - (:include lisp-stream + (:include string-stream (in #'string-inch) (bin #'string-binch) (n-bin #'string-stream-read-n-bytes) - (misc #'string-in-misc)) + (misc #'string-in-misc) + (string nil :type simple-string)) (:constructor internal-make-string-input-stream - (string current end))) - (string nil :type simple-string) + (string current end)) + (:copier nil)) (current nil :type index) (end nil :type index)) @@ -1087,12 +1135,12 @@ (truly-the index (+ index copy))) (sb!sys:without-gcing (system-area-copy (vector-sap string) - (* index sb!vm:byte-bits) + (* index sb!vm:n-byte-bits) (if (typep buffer 'system-area-pointer) buffer (vector-sap buffer)) - (* start sb!vm:byte-bits) - (* copy sb!vm:byte-bits)))) + (* start sb!vm:n-byte-bits) + (* copy sb!vm:n-byte-bits)))) (if (and (> requested copy) eof-error-p) (error 'end-of-file :stream stream) copy))) @@ -1112,40 +1160,37 @@ (:element-type 'base-char))) (defun make-string-input-stream (string &optional - (start 0) (end (length string))) + (start 0) end) #!+sb-doc - "Returns an input stream which will supply the characters of String between - Start and End in order." + "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)) - - #!+high-security - (when (> end (length string)) - (cerror "Continue with end changed from ~S to ~S" - "Write-string: end (~S) is larger then the length of the string (~S)" - end (1- (length string)))) - - (internal-make-string-input-stream (coerce string 'simple-string) - start end)) + + (internal-make-string-input-stream + (coerce string 'simple-string) + start + (%check-vector-sequence-bounds string start end))) -;;;; string output streams +;;;; STRING-OUTPUT-STREAM stuff (defstruct (string-output-stream - (:include lisp-stream + (:include string-stream (out #'string-ouch) (sout #'string-sout) - (misc #'string-out-misc)) - (:constructor make-string-output-stream ())) - ;; The string we throw stuff in. - (string (make-string 40) :type simple-string) + (misc #'string-out-misc) + ;; The string we throw stuff in. + (string (make-string 40) :type simple-string)) + (:constructor make-string-output-stream ()) + (:copier nil)) ;; Index of the next location to use. (index 0 :type fixnum)) #!+sb-doc (setf (fdocumentation 'make-string-output-stream 'function) - "Returns an Output stream which will accumulate all output given it for - the benefit of the function Get-Output-Stream-String.") + "Return an output stream which will accumulate all output given it for + the benefit of the function GET-OUTPUT-STREAM-STRING.") (defun string-ouch (stream character) (let ((current (string-output-stream-index stream)) @@ -1197,10 +1242,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))) @@ -1208,27 +1252,37 @@ (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. + +(deftype string-with-fill-pointer () + '(and string + (satisfies array-has-fill-pointer-p))) (defstruct (fill-pointer-output-stream - (:include lisp-stream + (:include string-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. - string) + (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)) + (:constructor make-fill-pointer-output-stream (string)) + (:copier nil))) (defun fill-pointer-ouch (stream character) (let* ((buffer (fill-pointer-output-stream-string stream)) @@ -1240,15 +1294,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 @@ -1273,12 +1323,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) @@ -1290,12 +1336,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) @@ -1315,11 +1357,12 @@ ;;;; indenting streams -(defstruct (indenting-stream (:include lisp-stream +(defstruct (indenting-stream (:include ansi-stream (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,28 +1370,29 @@ #!+sb-doc (setf (fdocumentation 'make-indenting-stream 'function) - "Returns an output stream which indents its output by some amount.") + "Return 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) @@ -1356,21 +1400,20 @@ ((= 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) - (let ((method (lisp-stream-misc sub-stream))) + (if (ansi-stream-p sub-stream) + (let ((method (ansi-stream-misc sub-stream))) (case operation (:line-length (let ((line-length (funcall method sub-stream operation))) @@ -1382,7 +1425,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))) @@ -1397,17 +1440,18 @@ (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))) - (target (required-argument) :type stream)) + (:include ansi-stream + (misc #'case-frob-misc)) + (:constructor %make-case-frob-stream (target out sout)) + (:copier nil)) + (target (missing-arg) :type stream)) (defun make-case-frob-stream (target kind) #!+sb-doc - "Returns a stream that sends all output to the stream TARGET, but modifies + "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. @@ -1420,9 +1464,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 @@ -1446,8 +1490,8 @@ (:close) (t (let ((target (case-frob-stream-target stream))) - (if (lisp-stream-p target) - (funcall (lisp-stream-misc target) target op arg1 arg2) + (if (ansi-stream-p target) + (funcall (ansi-stream-misc target) target op arg1 arg2) (stream-misc-dispatch target op arg1 arg2)))))) (defun case-frob-upcase-out (stream char) @@ -1455,8 +1499,8 @@ (type base-char char)) (let ((target (case-frob-stream-target stream)) (char (char-upcase char))) - (if (lisp-stream-p target) - (funcall (lisp-stream-out target) target char) + (if (ansi-stream-p target) + (funcall (ansi-stream-out target) target char) (stream-write-char target char)))) (defun case-frob-upcase-sout (stream str start end) @@ -1471,8 +1515,8 @@ (string-upcase str) (nstring-upcase (subseq str start end)))) (string-len (- end start))) - (if (lisp-stream-p target) - (funcall (lisp-stream-sout target) target string 0 string-len) + (if (ansi-stream-p target) + (funcall (ansi-stream-sout target) target string 0 string-len) (stream-write-string target string 0 string-len)))) (defun case-frob-downcase-out (stream char) @@ -1480,8 +1524,8 @@ (type base-char char)) (let ((target (case-frob-stream-target stream)) (char (char-downcase char))) - (if (lisp-stream-p target) - (funcall (lisp-stream-out target) target char) + (if (ansi-stream-p target) + (funcall (ansi-stream-out target) target char) (stream-write-char target char)))) (defun case-frob-downcase-sout (stream str start end) @@ -1496,8 +1540,8 @@ (string-downcase str) (nstring-downcase (subseq str start end)))) (string-len (- end start))) - (if (lisp-stream-p target) - (funcall (lisp-stream-sout target) target string 0 string-len) + (if (ansi-stream-p target) + (funcall (ansi-stream-sout target) target string 0 string-len) (stream-write-string target string 0 string-len)))) (defun case-frob-capitalize-out (stream char) @@ -1506,15 +1550,15 @@ (let ((target (case-frob-stream-target stream))) (cond ((alphanumericp char) (let ((char (char-upcase char))) - (if (lisp-stream-p target) - (funcall (lisp-stream-out target) target char) + (if (ansi-stream-p target) + (funcall (ansi-stream-out target) target char) (stream-write-char target char))) (setf (case-frob-stream-out stream) #'case-frob-capitalize-aux-out) (setf (case-frob-stream-sout stream) #'case-frob-capitalize-aux-sout)) (t - (if (lisp-stream-p target) - (funcall (lisp-stream-out target) target char) + (if (ansi-stream-p target) + (funcall (ansi-stream-out target) target char) (stream-write-char target char)))))) (defun case-frob-capitalize-sout (stream str start end) @@ -1540,8 +1584,8 @@ #'case-frob-capitalize-aux-out) (setf (case-frob-stream-sout stream) #'case-frob-capitalize-aux-sout)) - (if (lisp-stream-p target) - (funcall (lisp-stream-sout target) target str 0 len) + (if (ansi-stream-p target) + (funcall (ansi-stream-sout target) target str 0 len) (stream-write-string target str 0 len)))) (defun case-frob-capitalize-aux-out (stream char) @@ -1550,12 +1594,12 @@ (let ((target (case-frob-stream-target stream))) (cond ((alphanumericp char) (let ((char (char-downcase char))) - (if (lisp-stream-p target) - (funcall (lisp-stream-out target) target char) + (if (ansi-stream-p target) + (funcall (ansi-stream-out target) target char) (stream-write-char target char)))) (t - (if (lisp-stream-p target) - (funcall (lisp-stream-out target) target char) + (if (ansi-stream-p target) + (funcall (ansi-stream-out target) target char) (stream-write-char target char)) (setf (case-frob-stream-out stream) #'case-frob-capitalize-out) @@ -1585,8 +1629,8 @@ #'case-frob-capitalize-out) (setf (case-frob-stream-sout stream) #'case-frob-capitalize-sout)) - (if (lisp-stream-p target) - (funcall (lisp-stream-sout target) target str 0 len) + (if (ansi-stream-p target) + (funcall (ansi-stream-sout target) target str 0 len) (stream-write-string target str 0 len)))) (defun case-frob-capitalize-first-out (stream char) @@ -1595,16 +1639,16 @@ (let ((target (case-frob-stream-target stream))) (cond ((alphanumericp char) (let ((char (char-upcase char))) - (if (lisp-stream-p target) - (funcall (lisp-stream-out target) target char) + (if (ansi-stream-p target) + (funcall (ansi-stream-out target) target char) (stream-write-char target char))) (setf (case-frob-stream-out stream) #'case-frob-downcase-out) (setf (case-frob-stream-sout stream) #'case-frob-downcase-sout)) (t - (if (lisp-stream-p target) - (funcall (lisp-stream-out target) target char) + (if (ansi-stream-p target) + (funcall (ansi-stream-out target) target char) (stream-write-char target char)))))) (defun case-frob-capitalize-first-sout (stream str start end) @@ -1627,40 +1671,13 @@ (setf (case-frob-stream-sout stream) #'case-frob-downcase-sout) (return)))) - (if (lisp-stream-p target) - (funcall (lisp-stream-sout target) target str 0 len) + (if (ansi-stream-p target) + (funcall (ansi-stream-sout target) target str 0 len) (stream-write-string target str 0 len)))) -;;;; public interface from "EXTENSIONS" package - -(defstruct (stream-command (:constructor make-stream-command - (name &optional args))) - (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))) - -;;; 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. -(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. - (unread-char (read-char stream) stream))))) - -(defun read-sequence (seq stream &key (start 0) (end nil)) +;;;; READ-SEQUENCE + +(defun read-sequence (seq stream &key (start 0) end) #!+sb-doc "Destructively modify SEQ by reading elements from STREAM. That part of SEQ bounded by START and END is destructively modified by @@ -1673,7 +1690,18 @@ (type index start) (type sequence-end end) (values index)) - (let ((end (or end (length seq)))) + (if (ansi-stream-p stream) + (ansi-stream-read-sequence seq stream start end) + ;; must be Gray streams FUNDAMENTAL-STREAM + (stream-read-sequence stream seq start end))) + +(defun ansi-stream-read-sequence (seq stream start %end) + (declare (type sequence seq) + (type ansi-stream stream) + (type index start) + (type sequence-end %end) + (values index)) + (let ((end (or %end (length seq)))) (declare (type index end)) (etypecase seq (list @@ -1692,7 +1720,7 @@ (setf (first rem) el))))) (vector (with-array-data ((data seq) (offset-start start) (offset-end end)) - (typecase data + (typecase data ((or (simple-array (unsigned-byte 8) (*)) (simple-array (signed-byte 8) (*)) simple-string) @@ -1717,6 +1745,8 @@ (when (eq el :eof) (return (+ start (- i offset-start)))) (setf (aref data i) el))))))))))) + +;;;; WRITE-SEQUENCE (defun write-sequence (seq stream &key (start 0) (end nil)) #!+sb-doc @@ -1726,8 +1756,19 @@ (type index start) (type sequence-end end) (values sequence)) - (let ((end (or end (length seq)))) - (declare (type index start end)) + (if (ansi-stream-p stream) + (ansi-stream-write-sequence seq stream start end) + ;; must be Gray-streams FUNDAMENTAL-STREAM + (stream-write-sequence stream seq start end))) + +(defun ansi-stream-write-sequence (seq stream start %end) + (declare (type sequence seq) + (type ansi-stream stream) + (type index start) + (type sequence-end %end) + (values sequence)) + (let ((end (or %end (length seq)))) + (declare (type index end)) (etypecase seq (list (let ((write-function @@ -1741,7 +1782,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) @@ -1751,6 +1792,8 @@ ((>= i end) seq) (declare (type index i)) (funcall write-function (aref seq i) stream))))))) + +;;;; etc. ;;; (These were inline throughout this file, but that's not appropriate ;;; globally.)