X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstream.lisp;h=30f0e68ac7b723cb9ebb0087fd43503a7ed0d607;hb=a3706c5d9d95ebb5a14e7ab7313c5781e5c86713;hp=adec88826d846588073f9fd1df17fb0002aec477;hpb=35871544d182adf1895cf6d99d3f995ac2b425e0;p=sbcl.git diff --git a/src/code/stream.lisp b/src/code/stream.lisp index adec888..30f0e68 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,14 @@ (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 +;;;; for file position and file length +(defun external-format-char-size (external-format) + (ef-char-size (get-external-format external-format))) ;;; Call the MISC method with the :FILE-POSITION operation. #!-sb-fluid (declaim (inline ansi-stream-file-position)) @@ -150,6 +143,8 @@ (declare (type stream stream)) (declare (type (or index (alien sb!unix:off-t) (member nil :start :end)) position)) + ;; FIXME: It would 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+) @@ -162,19 +157,20 @@ (- +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) (if (ansi-stream-p stream) @@ -235,54 +231,101 @@ ;;;; 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) @@ -398,10 +441,8 @@ ;; a-s-read-sequence and needs a lambda list that's congruent with ;; that of a-s-read-char (declare (ignore recursive-p)) - (prepare-for-fast-read-byte stream - (prog1 - (fast-read-byte eof-error-p eof-value t) - (done-with-fast-read-byte)))) + (with-fast-read-byte (t stream eof-error-p eof-value) + (fast-read-byte))) (defun read-byte (stream &optional (eof-error-p t) eof-value) (if (ansi-stream-p stream) @@ -422,7 +463,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)) @@ -475,7 +526,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) @@ -488,9 +540,32 @@ (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 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. + ;; + ;; KLUDGE: we can't use FD-STREAM functions (which are the + ;; only ones which will give us decoding errors) here, + ;; because this code is generic. We can't call the N-BIN + ;; function, because near the end of a real file that can + ;; legitimately bounce us to the IN function. So we have + ;; to call ANSI-STREAM-IN. + (let* ((index (1- +ansi-stream-in-buffer-length+)) + (value (funcall (ansi-stream-in stream) stream nil :eof))) + (cond + ((eql value :eof) + ;; definitely EOF now + (setf (ansi-stream-in-index stream) + +ansi-stream-in-buffer-length+) + (values t (eof-or-lose stream eof-error-p eof-value))) + ;; we resynced or were given something instead + (t + (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 @@ -504,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. @@ -551,58 +626,46 @@ ;; must be Gray streams FUNDAMENTAL-STREAM (stream-fresh-line stream)))) -(defun write-string (string &optional (stream *standard-output*) - &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) - #!-sb-fluid (declaim (inline ansi-stream-write-string)) (defun ansi-stream-write-string (string stream start end) - (declare (type string string)) - (declare (type ansi-stream stream)) - (declare (type index start end)) - (if (array-header-p string) - (with-array-data ((data string) (offset-start start) - (offset-end end)) - (funcall (ansi-stream-sout stream) - stream data offset-start offset-end)) - (funcall (ansi-stream-sout stream) stream string start end)) - string) + (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))) (defun %write-string (string stream start end) + (let ((stream (out-synonym-of stream))) + (if (ansi-stream-p stream) + (ansi-stream-write-string string stream start end) + ;; must be Gray streams FUNDAMENTAL-STREAM + (stream-write-string stream string start end))) + string) + +(defun write-string (string &optional (stream *standard-output*) + &key (start 0) end) (declare (type string string)) (declare (type stream-designator stream)) - (declare (type index start end)) - (let ((stream (out-synonym-of stream))) - (if(ansi-stream-p stream) - (ansi-stream-write-string string stream start end) - ;; must be Gray streams FUNDAMENTAL-STREAM - (stream-write-string stream string start end)))) + (%write-string string stream start end)) ;;; A wrapper function for all those (MACROLET OUT-FUN) definitions, -;;; which cannot deal with keyword arguments. +;;; which cannot deal with keyword arguments. %WRITE-STRING cannot +;;; replace this, as this needs to deal with simple-strings as well. (declaim (inline write-string-no-key)) (defun write-string-no-key (string stream start end) (write-string string stream :start start :end end)) (defun write-line (string &optional (stream *standard-output*) - &key (start 0) end) + &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)) + (declare (type stream-designator stream)) + (let ((stream (out-synonym-of stream))) + (cond ((ansi-stream-p stream) + (ansi-stream-write-string string stream start end) + (funcall (ansi-stream-out stream) stream #\newline)) + (t + (stream-write-string stream string start end) + (stream-write-char stream #\newline)))) string) (defun charpos (&optional (stream *standard-output*)) @@ -876,7 +939,6 @@ (macrolet ((in-fun (name fun &rest args) `(defun ,name (stream ,@args) - (force-output (two-way-stream-output-stream stream)) (,fun (two-way-stream-input-stream stream) ,@args)))) (in-fun two-way-in read-char eof-error-p eof-value) (in-fun two-way-bin read-byte eof-error-p eof-value) @@ -1019,7 +1081,7 @@ (n-bin #'echo-n-bin)) (:constructor %make-echo-stream (input-stream output-stream)) (:copier nil)) - unread-stuff) + (unread-stuff nil :type boolean)) (def!method print-object ((x echo-stream) stream) (print-unreadable-object (x stream :type t :identity t) (format stream @@ -1044,47 +1106,55 @@ (macrolet ((in-fun (name in-fun out-fun &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 (if eof-error-p - (,in-fun in ,@args) - (,in-fun in nil in)))) - (cond - ((eql result in) eof-value) - (t (,out-fun result out) result))))))) + (let* ((unread-stuff-p (echo-stream-unread-stuff stream)) + (in (echo-stream-input-stream stream)) + (out (echo-stream-output-stream stream)) + (result (if eof-error-p + (,in-fun in ,@args) + (,in-fun in nil in)))) + (setf (echo-stream-unread-stuff stream) nil) + (cond + ((eql result in) eof-value) + ;; If unread-stuff was true, the character read + ;; from the input stream was previously echoed. + (t (unless unread-stuff-p (,out-fun result out)) result)))))) (in-fun echo-in read-char write-char eof-error-p eof-value) (in-fun echo-bin read-byte write-byte eof-error-p eof-value)) (defun echo-n-bin (stream buffer start numbytes eof-error-p) - (let ((new-start start) - (read 0)) - (loop - (let ((thing (pop (echo-stream-unread-stuff stream)))) - (cond - (thing - (setf (aref buffer new-start) thing) - (incf new-start) - (incf read) - (when (= read numbytes) - (return-from echo-n-bin numbytes))) - (t (return nil))))) - (let ((bytes-read (read-n-bytes (echo-stream-input-stream stream) buffer - new-start (- numbytes read) nil))) - (cond - ((not eof-error-p) - (write-sequence buffer (echo-stream-output-stream stream) - :start new-start :end (+ new-start bytes-read)) - (+ bytes-read read)) - ((> numbytes (+ read bytes-read)) - (write-sequence buffer (echo-stream-output-stream stream) - :start new-start :end (+ new-start bytes-read)) - (error 'end-of-file :stream stream)) - (t - (write-sequence buffer (echo-stream-output-stream stream) - :start new-start :end (+ new-start bytes-read)) - (aver (= numbytes (+ new-start bytes-read))) - numbytes))))) + (let ((bytes-read 0)) + ;; Note: before ca 1.0.27.18, the logic for handling unread + ;; characters never could have worked, so probably nobody has ever + ;; tried doing bivalent block I/O through an echo stream; this may + ;; not work either. + (when (echo-stream-unread-stuff stream) + (let* ((char (read-char stream)) + (octets (string-to-octets + (string char) + :external-format + (stream-external-format + (echo-stream-input-stream stream)))) + (octet-count (length octets)) + (blt-count (min octet-count numbytes))) + (replace buffer octets :start1 start :end1 (+ start blt-count)) + (incf start blt-count) + (decf numbytes blt-count))) + (incf bytes-read (read-n-bytes (echo-stream-input-stream stream) buffer + start numbytes nil)) + (cond + ((not eof-error-p) + (write-sequence buffer (echo-stream-output-stream stream) + :start start :end (+ start bytes-read)) + bytes-read) + ((> numbytes bytes-read) + (write-sequence buffer (echo-stream-output-stream stream) + :start start :end (+ start bytes-read)) + (error 'end-of-file :stream stream)) + (t + (write-sequence buffer (echo-stream-output-stream stream) + :start start :end (+ start bytes-read)) + (aver (= numbytes (+ start bytes-read))) + numbytes)))) ;;;; STRING-INPUT-STREAM stuff @@ -1134,14 +1204,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 - (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))) @@ -1179,8 +1249,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 @@ -1225,11 +1295,11 @@ ;; 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 the greater of index and this is always - ;; the end of the stream. + ;; 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)) + (element-type 'character :type type-specifier)) #!+sb-doc (setf (fdocumentation 'make-string-output-stream 'function) @@ -1388,6 +1458,7 @@ benefit of the function GET-OUTPUT-STREAM-STRING.") (defun string-out-misc (stream operation &optional arg1 arg2) (declare (ignore arg2)) + (declare (optimize speed)) (case operation (:charpos ;; Keeping this first is a silly micro-optimization: FRESH-LINE @@ -1397,8 +1468,10 @@ benefit of the function GET-OUTPUT-STREAM-STRING.") (buffer (string-output-stream-buffer stream)) (prev (string-output-stream-prev stream)) (base 0)) + (declare (type (or null (simple-array character (*))) buffer)) :next - (let ((pos (position #\newline buffer :from-end t :end pointer))) + (let ((pos (when buffer + (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, @@ -1458,14 +1531,20 @@ benefit of the function GET-OUTPUT-STREAM-STRING.") (flet ((replace-all (fun) (let ((start 0)) (declare (index start)) - (dolist (buffer (nreverse prev)) + (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)))))) + (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) @@ -1488,11 +1567,16 @@ benefit of the function GET-OUTPUT-STREAM-STRING.") ;;; the CLM, but they are required for the implementation of ;;; WITH-OUTPUT-TO-STRING. -;;; FIXME: need to support (VECTOR BASE-CHAR) and (VECTOR NIL), -;;; ideally without destroying all hope of efficiency. +;;; FIXME: need to support (VECTOR NIL), ideally without destroying all hope +;;; of efficiency. +(declaim (inline vector-with-fill-pointer)) +(defun vector-with-fill-pointer-p (x) + (and (vectorp x) + (array-has-fill-pointer-p x))) + (deftype string-with-fill-pointer () - '(and (vector character) - (satisfies array-has-fill-pointer-p))) + `(and (or (vector character) (vector base-char)) + (satisfies vector-with-fill-pointer-p))) (defstruct (fill-pointer-output-stream (:include ansi-stream @@ -1510,53 +1594,63 @@ benefit of the function GET-OUTPUT-STREAM-STRING.") (current+1 (1+ current))) (declare (fixnum current)) (with-array-data ((workspace buffer) (start) (end)) - (declare (type (simple-array character (*)) workspace)) - (let ((offset-current (+ start current))) - (declare (fixnum offset-current)) - (if (= offset-current end) - (let* ((new-length (1+ (* current 2))) - (new-workspace (make-string new-length))) - (declare (type (simple-array character (*)) new-workspace)) - (replace new-workspace workspace - :start2 start :end2 offset-current) - (setf workspace new-workspace - offset-current current) - (set-array-header buffer workspace new-length - current+1 0 new-length nil)) - (setf (fill-pointer buffer) current+1)) - (setf (schar workspace offset-current) character))) + (string-dispatch + ((simple-array character (*)) + (simple-array base-char (*))) + workspace + (let ((offset-current (+ start current))) + (declare (fixnum offset-current)) + (if (= offset-current end) + (let* ((new-length (1+ (* current 2))) + (new-workspace + (ecase (array-element-type workspace) + (character (make-string new-length + :element-type 'character)) + (base-char (make-string new-length + :element-type 'base-char))))) + (replace new-workspace workspace :start2 start :end2 offset-current) + (setf workspace new-workspace + offset-current current) + (set-array-header buffer workspace new-length + current+1 0 new-length nil nil)) + (setf (fill-pointer buffer) current+1)) + (setf (char workspace offset-current) character)))) current+1)) (defun fill-pointer-sout (stream string start end) - (declare (simple-string string) (fixnum start end)) - (let* ((string (if (typep string '(simple-array character (*))) - string - (coerce string '(simple-array character (*))))) - (buffer (fill-pointer-output-stream-string stream)) - (current (fill-pointer buffer)) - (string-len (- end start)) - (dst-end (+ string-len current))) - (declare (fixnum current dst-end string-len)) - (with-array-data ((workspace buffer) (dst-start) (dst-length)) - (declare (type (simple-array character (*)) workspace)) - (let ((offset-dst-end (+ dst-start dst-end)) - (offset-current (+ dst-start current))) - (declare (fixnum offset-dst-end offset-current)) - (if (> offset-dst-end dst-length) - (let* ((new-length (+ (the fixnum (* current 2)) string-len)) - (new-workspace (make-string new-length))) - (declare (type (simple-array character (*)) new-workspace)) - (replace new-workspace workspace - :start2 dst-start :end2 offset-current) - (setf workspace new-workspace - offset-current current - offset-dst-end dst-end) - (set-array-header buffer workspace new-length - dst-end 0 new-length nil)) - (setf (fill-pointer buffer) dst-end)) - (replace workspace string - :start1 offset-current :start2 start :end2 end))) - dst-end)) + (declare (fixnum start end)) + (string-dispatch + ((simple-array character (*)) + (simple-array base-char (*))) + string + (let* ((buffer (fill-pointer-output-stream-string stream)) + (current (fill-pointer buffer)) + (string-len (- end start)) + (dst-end (+ string-len current))) + (declare (fixnum current dst-end string-len)) + (with-array-data ((workspace buffer) (dst-start) (dst-length)) + (let ((offset-dst-end (+ dst-start dst-end)) + (offset-current (+ dst-start current))) + (declare (fixnum offset-dst-end offset-current)) + (if (> offset-dst-end dst-length) + (let* ((new-length (+ (the fixnum (* current 2)) string-len)) + (new-workspace + (ecase (array-element-type workspace) + (character (make-string new-length + :element-type 'character)) + (base-char (make-string new-length + :element-type 'base-char))))) + (replace new-workspace workspace + :start2 dst-start :end2 offset-current) + (setf workspace new-workspace + offset-current current + offset-dst-end dst-end) + (set-array-header buffer workspace new-length + dst-end 0 new-length nil nil)) + (setf (fill-pointer buffer) dst-end)) + (replace workspace string + :start1 offset-current :start2 start :end2 end))) + dst-end))) (defun fill-pointer-misc (stream operation &optional arg1 arg2) (declare (ignore arg2)) @@ -1590,93 +1684,9 @@ benefit of the function GET-OUTPUT-STREAM-STRING.") (if found (- end (the fixnum found)) current))))) - (:element-type (array-element-type - (fill-pointer-output-stream-string stream))))) - -;;;; indenting streams - -(defstruct (indenting-stream (:include ansi-stream - (out #'indenting-out) - (sout #'indenting-sout) - (misc #'indenting-misc)) - (:constructor make-indenting-stream (stream)) - (:copier nil)) - ;; the stream we're based on - stream - ;; how much we indent on each line - (indentation 0)) - -#!+sb-doc -(setf (fdocumentation 'make-indenting-stream 'function) - "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. -(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 - #.(make-string 60 :initial-element #\Space) - ,sub-stream - 0 - (min 60 (- indentation i))))) - -;;; 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. -(defun indenting-sout (stream string start end) - (declare (simple-string string) (fixnum start end)) - (do ((i start) - (sub-stream (indenting-stream-stream stream))) - ((= i end)) - (let ((newline (position #\newline string :start i :end end))) - (cond (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) - (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. -(defun indenting-misc (stream operation &optional arg1 arg2) - (let ((sub-stream (indenting-stream-stream 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))) - (if line-length - (- line-length (indenting-stream-indentation stream))))) - (:charpos - (let ((charpos (funcall method sub-stream operation))) - (if charpos - (- charpos (indenting-stream-indentation stream))))) - (t - (funcall method sub-stream operation arg1 arg2)))) - ;; must be Gray streams FUNDAMENTAL-STREAM - (case operation - (:line-length - (let ((line-length (stream-line-length sub-stream))) - (if line-length - (- line-length (indenting-stream-indentation stream))))) - (:charpos - (let ((charpos (stream-line-column sub-stream))) - (if charpos - (- charpos (indenting-stream-indentation stream))))) - (t - (stream-misc-dispatch sub-stream operation arg1 arg2)))))) - -(declaim (maybe-inline read-char unread-char read-byte listen)) + (:element-type + (array-element-type + (fill-pointer-output-stream-string stream))))) ;;;; case frobbing streams, used by FORMAT ~(...~) @@ -1967,34 +1977,86 @@ benefit of the function GET-OUTPUT-STREAM-STRING.") (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 (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)))))))))) + (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 + (+ start 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 start)) + (loop (add-chunk)))))) + ;;;; WRITE-SEQUENCE @@ -2034,7 +2096,8 @@ benefit of the function GET-OUTPUT-STREAM-STRING.") (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 @@ -2056,7 +2119,7 @@ benefit of the function GET-OUTPUT-STREAM-STRING.") (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)