: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)))
\f
;;; 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))
(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))
\f
;;;; 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))
(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+)
(- +ansi-stream-in-buffer-length+
(ansi-stream-in-index stream)))
#!+sb-unicode
- (let* ((external-format (stream-external-format stream))
- (ef-entry (find-external-format external-format))
- (variable-width-p (variable-width-external-format-p ef-entry))
- (char-len (bytes-for-char-fun ef-entry)))
+ (let ((char-size (if (fd-stream-p stream)
+ (fd-stream-char-size stream)
+ (external-format-char-size (stream-external-format stream)))))
(- res
- (if variable-width-p
- (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-len (aref buffer i)))
- (* (funcall char-len #\x) ; arbitrary argument
- (- +ansi-stream-in-buffer-length+
- (ansi-stream-in-index stream)))))))))))
-
+ (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".
\f
;;;; 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
- ;; Check whether the FAST-READ-CHAR buffer contains a newline. If it
- ;; does, we can do things quickly by just copying the line from the
- ;; buffer instead of doing repeated calls to FAST-READ-CHAR.
- (when %frc-buffer%
- (locally
- ;; For %FIND-POSITION transform
- (declare (optimize (speed 2)))
- (let ((pos (position #\Newline %frc-buffer%
- :test #'char=
- :start %frc-index%)))
- (when pos
- (let* ((len (- pos %frc-index%))
- (res (make-string len)))
- (replace res %frc-buffer% :start2 %frc-index% :end2 pos)
- (setf %frc-index% (1+ pos))
- (done-with-fast-read-char)
- (return-from ansi-stream-read-line res))))))
- (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)))
- (when (= index len)
- (setq len (* len 2))
- (let ((new (make-string len)))
- (replace new res)
- (setq res new)))
- (setf (schar res index) ch)
- (incf index))
- ((zerop index)
- (done-with-fast-read-char)
- (return (values (eof-or-lose stream
- eof-error-p
- eof-value)
- t)))
- ;; Since FAST-READ-CHAR already hit the eof char, we
- ;; shouldn't do another READ-CHAR.
- (t
- (done-with-fast-read-char)
- (return (values (%shrink-vector res index) t)))))))))
+ (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)))
+ (when (= index len)
+ (setq len (* len 2))
+ (let ((new (make-string len)))
+ (replace new res)
+ (setq res new)))
+ (setf (schar res index) ch)
+ (incf index))
+ ((zerop index)
+ (done-with-fast-read-char)
+ (return (values (eof-or-lose stream
+ eof-error-p
+ eof-value)
+ t)))
+ ;; Since FAST-READ-CHAR already hit the eof char, we
+ ;; shouldn't do another READ-CHAR.
+ (t
+ (done-with-fast-read-char)
+ (return (values (%shrink-vector res index) t))))))))))
(defun read-line (&optional (stream *standard-input*) (eof-error-p t) eof-value
recursive-p)
;;; 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))
;;; 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)
(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
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.
(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)
(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)))
(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
end))))
\f
;;;; 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)
(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))
\f
;;;; fill-pointer streams
(return i))
(setf (first rem) el)))))
(vector
- (with-array-data ((data seq) (offset-start start) (offset-end end))
- (if (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))
- (let ((read-function
- (if (subtypep (array-element-type data) '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))))))
+
\f
;;;; WRITE-SEQUENCE
(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 (array-element-type data) 'character)
- (ansi-stream-out stream)
+ (if (subtypep (stream-element-type stream) 'character)
+ (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))
(funcall write-function stream (aref data i))))))
(if (and (fd-stream-p stream)
(compatible-vector-and-stream-element-types-p data stream))
- (output-raw-bytes stream data offset-start offset-end)
+ (buffer-output stream data offset-start offset-end)
(output-seq-in-loop)))))))
seq)
\f
projects / sbcl.git / blobdiff