X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=eb40f586401d127a418f48c475fbd528c1193c24;hb=5d5894082c39ca44da75d38859d669c7b2108f6a;hp=1f43db72f981b90d01037525ee70f70e8393df53;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 1f43db7..eb40f58 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -53,44 +53,36 @@ :format-arguments (list stream))) (defun closed-flame (stream &rest ignore) (declare (ignore ignore)) - (error "~S is closed." stream)) + (error 'closed-stream-error :stream stream)) (defun no-op-placeholder (&rest ignore) (declare (ignore ignore))) ;;; stream manipulation functions -(declaim (inline ansi-stream-input-stream-p)) (defun ansi-stream-input-stream-p (stream) (declare (type ansi-stream stream)) - - (when (synonym-stream-p stream) - (setf stream - (symbol-value (synonym-stream-symbol stream)))) - - (and (not (eq (ansi-stream-in stream) #'closed-flame)) + (if (synonym-stream-p stream) + (input-stream-p (symbol-value (synonym-stream-symbol stream))) + (and (not (eq (ansi-stream-in stream) #'closed-flame)) ;;; KLUDGE: It's probably not good to have EQ tests on function ;;; values like this. What if someone's redefined the function? ;;; Is there a better way? (Perhaps just VALID-FOR-INPUT and ;;; VALID-FOR-OUTPUT flags? -- WHN 19990902 - (or (not (eq (ansi-stream-in stream) #'ill-in)) - (not (eq (ansi-stream-bin stream) #'ill-bin))))) + (or (not (eq (ansi-stream-in stream) #'ill-in)) + (not (eq (ansi-stream-bin stream) #'ill-bin)))))) (defun input-stream-p (stream) (declare (type stream stream)) (and (ansi-stream-p stream) (ansi-stream-input-stream-p stream))) -(declaim (inline ansi-stream-output-stream-p)) (defun ansi-stream-output-stream-p (stream) (declare (type ansi-stream stream)) - - (when (synonym-stream-p stream) - (setf stream (symbol-value - (synonym-stream-symbol stream)))) - - (and (not (eq (ansi-stream-in stream) #'closed-flame)) - (or (not (eq (ansi-stream-out stream) #'ill-out)) - (not (eq (ansi-stream-bout stream) #'ill-bout))))) + (if (synonym-stream-p stream) + (output-stream-p (symbol-value (synonym-stream-symbol stream))) + (and (not (eq (ansi-stream-in stream) #'closed-flame)) + (or (not (eq (ansi-stream-out stream) #'ill-out)) + (not (eq (ansi-stream-bout stream) #'ill-bout)))))) (defun output-stream-p (stream) (declare (type stream stream)) @@ -136,13 +128,17 @@ (setf (ansi-stream-in stream) #'closed-flame) (setf (ansi-stream-bin stream) #'closed-flame) (setf (ansi-stream-n-bin stream) #'closed-flame) - (setf (ansi-stream-in stream) #'closed-flame) (setf (ansi-stream-out stream) #'closed-flame) (setf (ansi-stream-bout stream) #'closed-flame) (setf (ansi-stream-sout stream) #'closed-flame) (setf (ansi-stream-misc stream) #'closed-flame)) ;;;; file position and file length +(defun external-format-char-size (external-format) + (let ((ef-entry (find-external-format external-format))) + (if (variable-width-external-format-p ef-entry) + (bytes-for-char-fun ef-entry) + (funcall (bytes-for-char-fun ef-entry) #\x)))) ;;; Call the MISC method with the :FILE-POSITION operation. #!-sb-fluid (declaim (inline ansi-stream-file-position)) @@ -150,6 +146,8 @@ (declare (type stream stream)) (declare (type (or index (alien sb!unix:off-t) (member nil :start :end)) position)) + ;; FIXME: It woud be good to comment on the stuff that is done here... + ;; FIXME: This doesn't look interrupt safe. (cond (position (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+) @@ -157,13 +155,30 @@ (t (let ((res (funcall (ansi-stream-misc stream) stream :file-position nil))) (when res + #!-sb-unicode (- res (- +ansi-stream-in-buffer-length+ - (ansi-stream-in-index stream)))))))) - + (ansi-stream-in-index stream))) + #!+sb-unicode + (let ((char-size (if (fd-stream-p stream) + (fd-stream-char-size stream) + (external-format-char-size (stream-external-format stream))))) + (- res + (etypecase char-size + (function + (loop with buffer = (ansi-stream-cin-buffer stream) + with start = (ansi-stream-in-index stream) + for i from start below +ansi-stream-in-buffer-length+ + sum (funcall char-size (aref buffer i)))) + (fixnum + (* char-size + (- +ansi-stream-in-buffer-length+ + (ansi-stream-in-index stream)))))))))))) (defun file-position (stream &optional position) - (ansi-stream-file-position stream position)) + (if (ansi-stream-p stream) + (ansi-stream-file-position stream position) + (stream-file-position stream position))) ;;; This is a literal translation of the ANSI glossary entry "stream ;;; associated with a file". @@ -219,19 +234,83 @@ ;;;; input functions +(defun ansi-stream-read-line-from-frc-buffer (stream eof-error-p eof-value) + (prepare-for-fast-read-char stream + (declare (ignore %frc-method%)) + (let ((chunks-total-length 0) + (chunks nil)) + (declare (type index chunks-total-length) + (list chunks)) + (labels ((refill-buffer () + (prog1 + (fast-read-char-refill stream nil nil) + (setf %frc-index% (ansi-stream-in-index %frc-stream%)))) + (newline-position () + (position #\Newline (the (simple-array character (*)) + %frc-buffer%) + :test #'char= + :start %frc-index%)) + (make-and-return-result-string (pos) + (let* ((len (+ (- (or pos %frc-index%) + %frc-index%) + chunks-total-length)) + (res (make-string len)) + (start 0)) + (declare (type index start)) + (when chunks + (dolist (chunk (nreverse chunks)) + (declare (type (simple-array character) chunk)) + (replace res chunk :start1 start) + (incf start (length chunk)))) + (unless (null pos) + (replace res %frc-buffer% + :start1 start + :start2 %frc-index% :end2 pos) + (setf %frc-index% (1+ pos))) + (done-with-fast-read-char) + (return-from ansi-stream-read-line-from-frc-buffer (values res (null pos))))) + (add-chunk () + (let* ((end (length %frc-buffer%)) + (len (- end %frc-index%)) + (chunk (make-string len))) + (replace chunk %frc-buffer% :start2 %frc-index% :end2 end) + (push chunk chunks) + (incf chunks-total-length len) + (when (refill-buffer) + (make-and-return-result-string nil))))) + (declare (inline make-and-return-result-string + refill-buffer)) + (when (and (= %frc-index% +ansi-stream-in-buffer-length+) + (refill-buffer)) + ;; EOF had been reached before we read anything + ;; at all. Return the EOF value or signal the error. + (done-with-fast-read-char) + (return-from ansi-stream-read-line-from-frc-buffer + (values (eof-or-lose stream eof-error-p eof-value) t))) + (loop + (let ((pos (newline-position))) + (if pos + (make-and-return-result-string pos) + (add-chunk)))))))) + #!-sb-fluid (declaim (inline ansi-stream-read-line)) (defun ansi-stream-read-line (stream eof-error-p eof-value recursive-p) (declare (ignore recursive-p)) - (prepare-for-fast-read-char stream - (let ((res (make-string 80)) - (len 80) - (index 0)) - (loop + (if (ansi-stream-cin-buffer stream) + ;; Stream has a fast-read-char buffer. Copy large chunks directly + ;; out of the buffer. + (ansi-stream-read-line-from-frc-buffer stream eof-error-p eof-value) + ;; Slow path, character by character. + (prepare-for-fast-read-char stream + (let ((res (make-string 80)) + (len 80) + (index 0)) + (loop (let ((ch (fast-read-char nil nil))) (cond (ch (when (char= ch #\newline) (done-with-fast-read-char) - (return (values (shrink-vector res index) nil))) + (return (values (%shrink-vector res index) nil))) (when (= index len) (setq len (* len 2)) (let ((new (make-string len))) @@ -249,7 +328,7 @@ ;; shouldn't do another READ-CHAR. (t (done-with-fast-read-char) - (return (values (shrink-vector res index) t))))))))) + (return (values (%shrink-vector res index) t)))))))))) (defun read-line (&optional (stream *standard-input*) (eof-error-p t) eof-value recursive-p) @@ -371,14 +450,13 @@ (done-with-fast-read-byte)))) (defun read-byte (stream &optional (eof-error-p t) eof-value) - (let ((stream (in-synonym-of stream))) - (if (ansi-stream-p stream) - (ansi-stream-read-byte stream eof-error-p eof-value nil) - ;; must be Gray streams FUNDAMENTAL-STREAM - (let ((char (stream-read-byte stream))) - (if (eq char :eof) - (eof-or-lose stream eof-error-p eof-value) - char))))) + (if (ansi-stream-p stream) + (ansi-stream-read-byte stream eof-error-p eof-value nil) + ;; must be Gray streams FUNDAMENTAL-STREAM + (let ((char (stream-read-byte stream))) + (if (eq char :eof) + (eof-or-lose stream eof-error-p eof-value) + char)))) ;;; Read NUMBYTES bytes into BUFFER beginning at START, and return the ;;; number of bytes read. @@ -390,7 +468,17 @@ ;;; 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. +#!-sb-fluid (declaim (inline read-n-bytes)) (defun read-n-bytes (stream buffer start numbytes &optional (eof-error-p t)) + (if (ansi-stream-p stream) + (ansi-stream-read-n-bytes stream buffer start numbytes eof-error-p) + ;; We don't need to worry about element-type size here is that + ;; callers are supposed to have checked everything is kosher. + (let* ((end (+ start numbytes)) + (read-end (stream-read-sequence stream buffer start end))) + (eof-or-lose stream (and eof-error-p (< read-end end)) (- read-end start))))) + +(defun ansi-stream-read-n-bytes (stream buffer start numbytes eof-error-p) (declare (type ansi-stream stream) (type index numbytes start) (type (or (simple-array * (*)) system-area-pointer) buffer)) @@ -443,7 +531,8 @@ ;;; 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. +;;; and hence must be an N-BIN method. It's also called by other stream +;;; functions which directly peek into the frc buffer. (defun fast-read-char-refill (stream eof-error-p eof-value) (let* ((ibuf (ansi-stream-cin-buffer stream)) (count (funcall (ansi-stream-n-bin stream) @@ -456,9 +545,27 @@ (start (- +ansi-stream-in-buffer-length+ count))) (declare (type index start count)) (cond ((zerop count) - (setf (ansi-stream-in-index stream) - +ansi-stream-in-buffer-length+) - (funcall (ansi-stream-in stream) stream eof-error-p eof-value)) + ;; An empty count does not necessarily mean that we reached + ;; the EOF, it's also possible that it's e.g. due to a + ;; invalid octet sequence in a multibyte stream. To handle + ;; the resyncing case correctly we need to call the + ;; single-character reading function and check whether an + ;; EOF was really reached. If not, we can just fill the + ;; buffer by one character, and hope that the next refill + ;; will not need to resync. + (let* ((value (funcall (ansi-stream-in stream) stream nil :eof)) + (index (1- +ansi-stream-in-buffer-length+))) + (case value + ((:eof) + ;; Mark buffer as empty. + (setf (ansi-stream-in-index stream) + +ansi-stream-in-buffer-length+) + ;; EOF. Redo the read, this time with the real eof parameters. + (values t (funcall (ansi-stream-in stream) + stream eof-error-p eof-value))) + (otherwise + (setf (aref ibuf index) value) + (values nil (setf (ansi-stream-in-index stream) index)))))) (t (when (/= start +ansi-stream-in-buffer-extra+) (#.(let* ((n-character-array-bits @@ -472,8 +579,8 @@ ibuf +ansi-stream-in-buffer-extra+ ibuf start count)) - (setf (ansi-stream-in-index stream) (1+ start)) - (aref ibuf start))))) + (values nil + (setf (ansi-stream-in-index stream) start)))))) ;;; This is similar to FAST-READ-CHAR-REFILL, but we don't have to ;;; leave room for unreading. @@ -538,12 +645,11 @@ (declare (type string string)) (declare (type ansi-stream stream)) (declare (type index start end)) - (if (array-header-p string) - (with-array-data ((data string) (offset-start start) - (offset-end end)) - (funcall (ansi-stream-sout stream) - stream data offset-start offset-end)) - (funcall (ansi-stream-sout stream) stream string start end)) + (with-array-data ((data string) (offset-start start) + (offset-end end) + :check-fill-pointer t) + (funcall (ansi-stream-sout stream) + stream data offset-start offset-end)) string) (defun %write-string (string stream start end) @@ -596,8 +702,8 @@ nil) (defun write-byte (integer stream) - (with-out-stream stream (ansi-stream-bout integer) - (stream-write-byte integer)) + (with-out-stream/no-synonym stream (ansi-stream-bout integer) + (stream-write-byte integer)) integer) @@ -1102,14 +1208,14 @@ (truly-the index (+ index copy))) ;; FIXME: why are we VECTOR-SAP'ing things here? what's the point? ;; and are there SB-UNICODE issues here as well? --njf, 2005-03-24 - (sb!sys:without-gcing - (system-area-ub8-copy (vector-sap string) - index - (if (typep buffer 'system-area-pointer) - buffer - (vector-sap buffer)) - start - copy))) + (with-pinned-objects (string buffer) + (system-area-ub8-copy (vector-sap string) + index + (if (typep buffer 'system-area-pointer) + buffer + (vector-sap buffer)) + start + copy))) (if (and (> requested copy) eof-error-p) (error 'end-of-file :stream stream) copy))) @@ -1147,8 +1253,8 @@ (declare (type string string) (type index start) (type (or index null) end)) - (let* ((string (coerce string '(simple-array character (*)))) - (end (%check-vector-sequence-bounds string start end))) + (let* ((string (coerce string '(simple-array character (*))))) + ;; FIXME: Why WITH-ARRAY-DATA, since the array is already simple? (with-array-data ((string string) (start start) (end end)) (internal-make-string-input-stream string ;; now simple @@ -1156,7 +1262,22 @@ end)))) ;;;; STRING-OUTPUT-STREAM stuff +;;;; +;;;; FIXME: This, like almost none of the stream code is particularly +;;;; interrupt or thread-safe. While it should not be possible to +;;;; corrupt the heap here, it certainly is possible to end up with +;;;; a string-output-stream whose internal state is messed up. +;;;; +;;;; FIXME: It would be nice to support space-efficient +;;;; string-output-streams with element-type base-char. This would +;;;; mean either a separate subclass, or typecases in functions. + +(defparameter *string-output-stream-buffer-initial-size* 64) +#!-sb-fluid +(declaim (inline string-output-string-stream-buffer + string-output-string-stream-pointer + string-output-string-stream-index)) (defstruct (string-output-stream (:include ansi-stream (out #'string-ouch) @@ -1164,136 +1285,282 @@ (misc #'string-out-misc)) (:constructor make-string-output-stream (&key (element-type 'character) - &aux (string (make-string 40)))) + &aux (buffer + (make-string + *string-output-stream-buffer-initial-size*)))) (:copier nil)) ;; The string we throw stuff in. - (string (missing-arg) :type (simple-array character (*))) - ;; Index of the next location to use. - (index 0 :type fixnum) - ;; Index cache for string-output-stream-last-index - (index-cache 0 :type fixnum) + (buffer (missing-arg) :type (simple-array character (*))) + ;; Chains of buffers to use + (prev nil) + (next nil) + ;; Index of the next location to use in the current string. + (pointer 0 :type index) + ;; Global location in the stream + (index 0 :type index) + ;; Index cache: when we move backwards we save the greater of this + ;; and index here, so the greater of index and this is always the + ;; end of the stream. + (index-cache 0 :type index) ;; Requested element type (element-type 'character)) #!+sb-doc (setf (fdocumentation 'make-string-output-stream 'function) - "Return an output stream which will accumulate all output given it for - the benefit of the function GET-OUTPUT-STREAM-STRING.") - -(defun string-output-stream-last-index (stream) - (max (string-output-stream-index stream) - (string-output-stream-index-cache stream))) + "Return an output stream which will accumulate all output given it for the +benefit of the function GET-OUTPUT-STREAM-STRING.") + +;;; Pushes the current segment onto the prev-list, and either pops +;;; or allocates a new one. +(defun string-output-stream-new-buffer (stream size) + (declare (index size)) + (/show0 "/string-output-stream-new-buffer") + (push (string-output-stream-buffer stream) + (string-output-stream-prev stream)) + (setf (string-output-stream-buffer stream) + (or (pop (string-output-stream-next stream)) + ;; FIXME: This would be the correct place to detect that + ;; more then FIXNUM characters are being written to the + ;; stream, and do something about it. + (make-string size)))) + +;;; Moves to the end of the next segment or the current one if there are +;;; no more segments. Returns true as long as there are next segments. +(defun string-output-stream-next-buffer (stream) + (/show0 "/string-output-stream-next-buffer") + (let* ((old (string-output-stream-buffer stream)) + (new (pop (string-output-stream-next stream))) + (old-size (length old)) + (skipped (- old-size (string-output-stream-pointer stream)))) + (cond (new + (let ((new-size (length new))) + (push old (string-output-stream-prev stream)) + (setf (string-output-stream-buffer stream) new + (string-output-stream-pointer stream) new-size) + (incf (string-output-stream-index stream) (+ skipped new-size))) + t) + (t + (setf (string-output-stream-pointer stream) old-size) + (incf (string-output-stream-index stream) skipped) + nil)))) + +;;; Moves to the start of the previous segment or the current one if there +;;; are no more segments. Returns true as long as there are prev segments. +(defun string-output-stream-prev-buffer (stream) + (/show0 "/string-output-stream-prev-buffer") + (let ((old (string-output-stream-buffer stream)) + (new (pop (string-output-stream-prev stream))) + (skipped (string-output-stream-pointer stream))) + (cond (new + (push old (string-output-stream-next stream)) + (setf (string-output-stream-buffer stream) new + (string-output-stream-pointer stream) 0) + (decf (string-output-stream-index stream) (+ skipped (length new))) + t) + (t + (setf (string-output-stream-pointer stream) 0) + (decf (string-output-stream-index stream) skipped) + nil)))) (defun string-ouch (stream character) - (let ((current (string-output-stream-index stream)) - (workspace (string-output-stream-string stream))) - (declare (type (simple-array character (*)) workspace) - (type fixnum current)) - (if (= current (the fixnum (length workspace))) - (let ((new-workspace (make-string (* current 2)))) - (replace new-workspace workspace) - (setf (aref new-workspace current) character - (string-output-stream-string stream) new-workspace)) - (setf (aref workspace current) character)) - (setf (string-output-stream-index stream) (1+ current)))) + (/show0 "/string-ouch") + (let ((pointer (string-output-stream-pointer stream)) + (buffer (string-output-stream-buffer stream)) + (index (string-output-stream-index stream))) + (cond ((= pointer (length buffer)) + (setf buffer (string-output-stream-new-buffer stream index) + (aref buffer 0) character + (string-output-stream-pointer stream) 1)) + (t + (setf (aref buffer pointer) character + (string-output-stream-pointer stream) (1+ pointer)))) + (setf (string-output-stream-index stream) (1+ index)))) (defun string-sout (stream string start end) (declare (type simple-string string) - (type fixnum start end)) - (let* ((string (if (typep string '(simple-array character (*))) - string - (coerce string '(simple-array character (*))))) - (current (string-output-stream-index stream)) - (length (- end start)) - (dst-end (+ length current)) - (workspace (string-output-stream-string stream))) - (declare (type (simple-array character (*)) workspace string) - (type fixnum current length dst-end)) - (if (> dst-end (the fixnum (length workspace))) - (let ((new-workspace (make-string (+ (* current 2) length)))) - (replace new-workspace workspace :end2 current) - (replace new-workspace string - :start1 current :end1 dst-end - :start2 start :end2 end) - (setf (string-output-stream-string stream) new-workspace)) - (replace workspace string - :start1 current :end1 dst-end - :start2 start :end2 end)) - (setf (string-output-stream-index stream) dst-end))) + (type index start end)) + (let* ((full-length (- end start)) + (length full-length) + (buffer (string-output-stream-buffer stream)) + (pointer (string-output-stream-pointer stream)) + (space (- (length buffer) pointer)) + (here (min space length)) + (stop (+ start here)) + (overflow (- length space))) + (declare (index length space here stop full-length) + (fixnum overflow) + (type (simple-array character (*)) buffer)) + (tagbody + :more + (when (plusp here) + (etypecase string + ((simple-array character (*)) + (replace buffer string :start1 pointer :start2 start :end2 stop)) + (simple-base-string + (replace buffer string :start1 pointer :start2 start :end2 stop)) + ((simple-array nil (*)) + (replace buffer string :start1 pointer :start2 start :end2 stop))) + (setf (string-output-stream-pointer stream) (+ here pointer))) + (when (plusp overflow) + (setf start stop + length (- end start) + buffer (string-output-stream-new-buffer + stream (max overflow (string-output-stream-index stream))) + pointer 0 + space (length buffer) + here (min space length) + stop (+ start here) + ;; there may be more overflow if we used a buffer + ;; already allocated to the stream + overflow (- length space)) + (go :more))) + (incf (string-output-stream-index stream) full-length))) + +;;; Factored out of the -misc method due to size. +(defun set-string-output-stream-file-position (stream pos) + (let* ((index (string-output-stream-index stream)) + (end (max index (string-output-stream-index-cache stream)))) + (declare (index index end)) + (setf (string-output-stream-index-cache stream) end) + (cond ((eq :start pos) + (loop while (string-output-stream-prev-buffer stream))) + ((eq :end pos) + (loop while (string-output-stream-next-buffer stream)) + (let ((over (- (string-output-stream-index stream) end))) + (decf (string-output-stream-pointer stream) over)) + (setf (string-output-stream-index stream) end)) + ((< pos index) + (loop while (< pos index) + do (string-output-stream-prev-buffer stream) + (setf index (string-output-stream-index stream))) + (let ((step (- pos index))) + (incf (string-output-stream-pointer stream) step) + (setf (string-output-stream-index stream) pos))) + ((> pos index) + ;; We allow moving beyond the end of stream, implicitly + ;; extending the output stream. + (let ((next (string-output-stream-next-buffer stream))) + ;; Update after -next-buffer, INDEX is kept pointing at + ;; the end of the current buffer. + (setf index (string-output-stream-index stream)) + (loop while (and next (> pos index)) + do (setf next (string-output-stream-next-buffer stream) + index (string-output-stream-index stream)))) + ;; Allocate new buffer if needed, or step back to + ;; the desired index and set pointer and index + ;; correctly. + (let ((diff (- pos index))) + (if (plusp diff) + (let* ((new (string-output-stream-new-buffer stream diff)) + (size (length new))) + (aver (= pos (+ index size))) + (setf (string-output-stream-pointer stream) size + (string-output-stream-index stream) pos)) + (let ((size (length (string-output-stream-buffer stream)))) + (setf (string-output-stream-pointer stream) (+ size diff) + (string-output-stream-index stream) pos)))))))) (defun string-out-misc (stream operation &optional arg1 arg2) (declare (ignore arg2)) (case operation - (:file-position - (if arg1 - (let ((end (string-output-stream-last-index stream))) - (setf (string-output-stream-index-cache stream) end - (string-output-stream-index stream) - (case arg1 - (:start 0) - (:end end) - (t - ;; We allow moving beyond the end of stream, - ;; implicitly extending the output stream. - (let ((buffer (string-output-stream-string stream))) - (when (> arg1 (length buffer)) - (setf (string-output-stream-string stream) - (make-string - arg1 :element-type (array-element-type buffer)) - (subseq (string-output-stream-string stream) - 0 end) - (subseq buffer 0 end)))) - arg1)))) - (string-output-stream-index stream))) - (:close (set-closed-flame stream)) (:charpos - (do ((index (1- (the fixnum (string-output-stream-index stream))) - (1- index)) - (count 0 (1+ count)) - (string (string-output-stream-string stream))) - ((< index 0) count) - (declare (type (simple-array character (*)) string) - (type fixnum index count)) - (if (char= (schar string index) #\newline) - (return count)))) - (:element-type (array-element-type (string-output-stream-string stream))))) + ;; Keeping this first is a silly micro-optimization: FRESH-LINE + ;; makes this the most common one. + (/show0 "/string-out-misc charpos") + (prog ((pointer (string-output-stream-pointer stream)) + (buffer (string-output-stream-buffer stream)) + (prev (string-output-stream-prev stream)) + (base 0)) + :next + (let ((pos (position #\newline buffer :from-end t :end pointer))) + (when (or pos (not buffer)) + ;; If newline is at index I, and pointer at index I+N, charpos + ;; is N-1. If there is no newline, and pointer is at index N, + ;; charpos is N. + (return (+ base (if pos (- pointer pos 1) pointer)))) + (setf base (+ base pointer) + buffer (pop prev) + pointer (length buffer)) + (/show0 "/string-out-misc charpos next") + (go :next)))) + (:file-position + (/show0 "/string-out-misc file-position") + (when arg1 + (set-string-output-stream-file-position stream arg1)) + (string-output-stream-index stream)) + (:close + (/show0 "/string-out-misc close") + (set-closed-flame stream)) + (:element-type (string-output-stream-element-type stream)))) ;;; Return a string of all the characters sent to a stream made by ;;; MAKE-STRING-OUTPUT-STREAM since the last call to this function. (defun get-output-stream-string (stream) (declare (type string-output-stream stream)) - (let* ((length (string-output-stream-last-index stream)) + (let* ((length (max (string-output-stream-index stream) + (string-output-stream-index-cache stream))) (element-type (string-output-stream-element-type stream)) + (prev (string-output-stream-prev stream)) + (this (string-output-stream-buffer stream)) + (next (string-output-stream-next stream)) (result (case element-type ;; overwhelmingly common case: can be inlined + ;; + ;; FIXME: If we were willing to use %SHRINK-VECTOR here, + ;; and allocate new strings the size of 2 * index in + ;; STRING-SOUT, we would not need to allocate one here in + ;; the common case, but could just use the last one + ;; allocated, and chop it down to size.. + ;; ((character) (make-string length)) ;; slightly less common cases: inline it anyway ((base-char standard-char) (make-string length :element-type 'base-char)) - (t (make-string length :element-type element-type))))) - ;; For the benefit of the REPLACE transform, let's do this, so - ;; that the common case isn't ludicrously expensive. - (etypecase result - ((simple-array character (*)) - (replace result (string-output-stream-string stream))) - (simple-base-string - (replace result (string-output-stream-string stream))) - ((simple-array nil (*)) - (replace result (string-output-stream-string stream)))) + (t + (make-string length :element-type element-type))))) + (setf (string-output-stream-index stream) 0 - (string-output-stream-index-cache stream) 0) - result)) + (string-output-stream-index-cache stream) 0 + (string-output-stream-pointer stream) 0 + ;; throw them away for simplicity's sake: this way the rest of the + ;; implementation can assume that the greater of INDEX and INDEX-CACHE + ;; is always within the last buffer. + (string-output-stream-prev stream) nil + (string-output-stream-next stream) nil) + + (flet ((replace-all (fun) + (let ((start 0)) + (declare (index start)) + (setf prev (nreverse prev)) + (dolist (buffer prev) + (funcall fun buffer start) + (incf start (length buffer))) + (funcall fun this start) + (incf start (length this)) + (dolist (buffer next) + (funcall fun buffer start) + (incf start (length buffer))) + ;; Hack: erase the pointers to strings, to make it less + ;; likely that the conservative GC will accidentally + ;; retain the buffers. + (fill prev nil) + (fill next nil)))) + (macrolet ((frob (type) + `(replace-all (lambda (buffer from) + (declare (type ,type result) + (type (simple-array character (*)) + buffer)) + (replace result buffer :start1 from))))) + (etypecase result + ((simple-array character (*)) + (frob (simple-array character (*)))) + (simple-base-string + (frob simple-base-string)) + ((simple-array nil (*)) + (frob (simple-array nil (*))))))) -;;; 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) - (%write-string (string-output-stream-string in-stream) - out-stream - 0 - (string-output-stream-last-index in-stream)) - (setf (string-output-stream-index in-stream) 0 - (string-output-stream-index-cache in-stream) 0)) + result)) ;;;; fill-pointer streams @@ -1747,6 +2014,15 @@ ;; must be Gray streams FUNDAMENTAL-STREAM (stream-read-sequence stream seq start end))) +(declaim (inline compatible-vector-and-stream-element-types-p)) +(defun compatible-vector-and-stream-element-types-p (vector stream) + (declare (type vector vector) + (type ansi-stream stream)) + (or (and (typep vector '(simple-array (unsigned-byte 8) (*))) + (subtypep (stream-element-type stream) '(unsigned-byte 8))) + (and (typep vector '(simple-array (signed-byte 8) (*))) + (subtypep (stream-element-type stream) '(signed-byte 8))))) + (defun ansi-stream-read-sequence (seq stream start %end) (declare (type sequence seq) (type ansi-stream stream) @@ -1771,28 +2047,86 @@ (return i)) (setf (first rem) el))))) (vector - (with-array-data ((data seq) (offset-start start) (offset-end end)) - (typecase data - ((or (simple-array (unsigned-byte 8) (*)) - (simple-array (signed-byte 8) (*))) - (let* ((numbytes (- end start)) - (bytes-read (read-n-bytes stream data offset-start - numbytes nil))) - (if (< bytes-read numbytes) - (+ start bytes-read) - end))) - (t - (let ((read-function - (if (subtypep (stream-element-type stream) 'character) - #'ansi-stream-read-char - #'ansi-stream-read-byte))) - (do ((i offset-start (1+ i))) - ((>= i offset-end) end) - (declare (type index i)) - (let ((el (funcall read-function stream nil :eof nil))) - (when (eq el :eof) - (return (+ start (- i offset-start)))) - (setf (aref data i) el))))))))))) + (with-array-data ((data seq) (offset-start start) (offset-end end) + :check-fill-pointer t) + (cond ((compatible-vector-and-stream-element-types-p data stream) + (let* ((numbytes (- end start)) + (bytes-read (read-n-bytes stream data offset-start + numbytes nil))) + (if (< bytes-read numbytes) + (+ start bytes-read) + end))) + ((and (ansi-stream-cin-buffer stream) + (typep seq 'simple-string)) + (ansi-stream-read-string-from-frc-buffer seq stream + start %end)) + (t + (let ((read-function + (if (subtypep (stream-element-type stream) 'character) + ;; If the stream-element-type is CHARACTER, + ;; this might be a bivalent stream. If the + ;; sequence is a specialized unsigned-byte + ;; vector, try to read use binary IO. It'll + ;; signal an error if stream is an pure + ;; character stream. + (if (subtypep (array-element-type data) + 'unsigned-byte) + #'ansi-stream-read-byte + #'ansi-stream-read-char) + #'ansi-stream-read-byte))) + (do ((i offset-start (1+ i))) + ((>= i offset-end) end) + (declare (type index i)) + (let ((el (funcall read-function stream nil :eof nil))) + (when (eq el :eof) + (return (+ start (- i offset-start)))) + (setf (aref data i) el))))))))))) + +(defun ansi-stream-read-string-from-frc-buffer (seq stream start %end) + (declare (type simple-string seq) + (type ansi-stream stream) + (type index start) + (type (or null index) %end)) + (let ((needed (- (or %end (length seq)) + start)) + (read 0)) + (prepare-for-fast-read-char stream + (declare (ignore %frc-method%)) + (unless %frc-buffer% + (return-from ansi-stream-read-string-from-frc-buffer nil)) + (labels ((refill-buffer () + (prog1 + (fast-read-char-refill stream nil nil) + (setf %frc-index% (ansi-stream-in-index %frc-stream%)))) + (add-chunk () + (let* ((end (length %frc-buffer%)) + (len (min (- end %frc-index%) + (- needed read)))) + (declare (type index end len read needed)) + (string-dispatch (simple-base-string + (simple-array character (*))) + seq + (replace seq %frc-buffer% + :start1 (+ start read) + :end1 (+ start read len) + :start2 %frc-index% + :end2 (+ %frc-index% len))) + (incf read len) + (incf %frc-index% len) + (when (or (eql needed read) + (refill-buffer)) + (done-with-fast-read-char) + (return-from ansi-stream-read-string-from-frc-buffer + read))))) + (declare (inline refill-buffer)) + (when (and (= %frc-index% +ansi-stream-in-buffer-length+) + (refill-buffer)) + ;; EOF had been reached before we read anything + ;; at all. Return the EOF value or signal the error. + (done-with-fast-read-char) + (return-from ansi-stream-read-string-from-frc-buffer 0)) + (loop (add-chunk)))))) + ;;;; WRITE-SEQUENCE @@ -1832,25 +2166,31 @@ (string (%write-string seq stream start end)) (vector - (with-array-data ((data seq) (offset-start start) (offset-end end)) + (with-array-data ((data seq) (offset-start start) (offset-end end) + :check-fill-pointer t) (labels ((output-seq-in-loop () (let ((write-function (if (subtypep (stream-element-type stream) 'character) - (ansi-stream-out stream) + (lambda (stream object) + ;; This might be a bivalent stream, so we need + ;; to dispatch on a per-element basis, rather + ;; than just based on the sequence or stream + ;; element types. + (if (characterp object) + (funcall (ansi-stream-out stream) + stream object) + (funcall (ansi-stream-bout stream) + stream object))) (ansi-stream-bout stream)))) (do ((i offset-start (1+ i))) ((>= i offset-end)) (declare (type index i)) (funcall write-function stream (aref data i)))))) - (typecase data - ((or (simple-array (unsigned-byte 8) (*)) - (simple-array (signed-byte 8) (*))) - (if (fd-stream-p stream) - (output-raw-bytes stream data offset-start offset-end) - (output-seq-in-loop))) - (t - (output-seq-in-loop)))))))) + (if (and (fd-stream-p stream) + (compatible-vector-and-stream-element-types-p data stream)) + (buffer-output stream data offset-start offset-end) + (output-seq-in-loop))))))) seq) ;;;; etc.