X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=6e2b2b4b7720d119cfd5e19e9cf4256407ecf77d;hb=ef793f0d484ac3a527e945a62c93f904d73049a6;hp=0ef85b1ff67a2d209316d788fa15ed764552d603;hpb=bb8e5ebfbc575236a3061f0a2d38ad616d246a87;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 0ef85b1..6e2b2b4 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -502,15 +502,26 @@ (end (or end (length (the vector thing))))) (declare (fixnum start end)) (if (stringp thing) - (let ((last-newline (and (find #\newline (the simple-string thing) - :start start :end end) - ;; FIXME why do we need both calls? - ;; Is find faster forwards than - ;; position is backwards? - (position #\newline (the simple-string thing) - :from-end t - :start start - :end end)))) + (let ((last-newline + (flet ((do-it (string) + (and (find #\newline string :start start :end end) + ;; FIXME why do we need both calls? + ;; Is find faster forwards than + ;; position is backwards? + (position #\newline string + :from-end t + :start start + :end end)))) + (declare (inline do-it)) + ;; Specialize the common cases + (etypecase thing + (simple-base-string + (do-it (the simple-base-string thing))) + #!+sb-unicode + ((simple-array character) + (do-it (the (simple-array character) thing))) + (string + (do-it thing)))))) (if (and (typep thing 'base-string) (eq (fd-stream-external-format stream) :latin-1)) (ecase (fd-stream-buffering stream) @@ -988,26 +999,49 @@ (> (fd-stream-ibuf-tail stream) (fd-stream-ibuf-head stream))) (file-position stream (file-position stream))) - (when (< end start) - (error ":END before :START!")) + (unless (<= 0 start end (length string)) + (signal-bounding-indices-bad-error string start end)) (do () ((= end start)) (setf (fd-stream-obuf-tail stream) - (do* ((len (fd-stream-obuf-length stream)) - (sap (fd-stream-obuf-sap stream)) - (tail (fd-stream-obuf-tail stream))) - ((or (= start end) (< (- len tail) 4)) tail) - ,(if output-restart - `(catch 'output-nothing - (let* ((byte (aref string start)) - (bits (char-code byte))) - ,out-expr - (incf tail ,size))) - `(let* ((byte (aref string start)) - (bits (char-code byte))) - ,out-expr - (incf tail ,size))) - (incf start))) + (flet ((do-it (string) + (let ((len (fd-stream-obuf-length stream)) + (sap (fd-stream-obuf-sap stream)) + (tail (fd-stream-obuf-tail stream))) + (declare (type index tail) + ;; STRING bounds have already been checked. + (optimize (safety 0))) + (loop + (,@(if output-restart + `(catch 'output-nothing) + `(progn)) + (do* () + ((or (= start end) (< (- len tail) 4))) + (let* ((byte (aref string start)) + (bits (char-code byte))) + ,out-expr + (incf tail ,size) + (incf start))) + ;; Exited from the loop normally + (return-from do-it tail)) + ;; Exited via CATCH. Skip the current character + ;; and try the inner loop again. + (incf start))))) + (declare (inline do-it)) + ;; Specialized versions for the common cases of + ;; SIMPLE-BASE-STRING and (SIMPLE-ARRAY CHARACTER) + ;; to avoid doing a generic AREF. + (etypecase string + (simple-base-string + (do-it (the simple-base-string string))) + #!+sb-unicode + ((simple-array character) + ;; For some reason the type information from the + ;; etypecase doesn't propagate through here without + ;; an explicit THE. + (do-it (the (simple-array character) string))) + (string + (do-it string))))) (when (< start end) (flush-output-buffer stream))) (when flush-p @@ -1026,41 +1060,41 @@ (tail (fd-stream-obuf-tail stream))) ,out-expr)) (defun ,in-function (stream buffer start requested eof-error-p - &aux (total-copied 0)) + &aux (index start) (end (+ start requested))) (declare (type fd-stream stream)) - (declare (type index start requested total-copied)) + (declare (type index start requested index end)) (declare (type (simple-array character (#.+ansi-stream-in-buffer-length+)) buffer)) (let ((unread (fd-stream-unread stream))) (when unread - (setf (aref buffer start) unread) + (setf (aref buffer index) unread) (setf (fd-stream-unread stream) nil) (setf (fd-stream-listen stream) nil) - (incf total-copied))) + (incf index))) (do () (nil) (let* ((head (fd-stream-ibuf-head stream)) (tail (fd-stream-ibuf-tail stream)) (sap (fd-stream-ibuf-sap stream))) - (declare (type index head tail)) + (declare (type index head tail) + (type system-area-pointer sap)) ;; Copy data from stream buffer into user's buffer. - (do () - ((or (= tail head) (= requested total-copied))) + (dotimes (i (min (truncate (- tail head) ,size) + (- end index))) + (declare (optimize speed)) (let* ((byte (sap-ref-8 sap head))) - (when (> ,size (- tail head)) - (return)) - (setf (aref buffer (+ start total-copied)) ,in-expr) - (incf total-copied) + (setf (aref buffer index) ,in-expr) + (incf index) (incf head ,size))) (setf (fd-stream-ibuf-head stream) head) ;; Maybe we need to refill the stream buffer. - (cond ( ;; If there were enough data in the stream buffer, we're done. - (= total-copied requested) - (return total-copied)) + (cond ( ;; If there was enough data in the stream buffer, we're done. + (= index end) + (return (- index start))) ( ;; If EOF, we're done in another way. (null (catch 'eof-input-catcher (refill-buffer/fd stream))) (if eof-error-p (error 'end-of-file :stream stream) - (return total-copied))) + (return (- index start)))) ;; Otherwise we refilled the stream buffer, so fall ;; through into another pass of the loop. )))) @@ -1092,28 +1126,50 @@ (> (fd-stream-ibuf-tail stream) (fd-stream-ibuf-head stream))) (file-position stream (file-position stream))) - (when (< end start) - (error ":END before :START!")) + (unless (<= 0 start end (length string)) + (signal-bounding-indices-bad-error string start end)) (do () ((= end start)) (setf (fd-stream-obuf-tail stream) - (do* ((len (fd-stream-obuf-length stream)) - (sap (fd-stream-obuf-sap stream)) - (tail (fd-stream-obuf-tail stream))) - ((or (= start end) (< (- len tail) 4)) tail) - ,(if output-restart - `(catch 'output-nothing - (let* ((byte (aref string start)) - (bits (char-code byte)) - (size ,out-size-expr)) - ,out-expr - (incf tail size))) - `(let* ((byte (aref string start)) - (bits (char-code byte)) - (size ,out-size-expr)) - ,out-expr - (incf tail size))) - (incf start))) + (flet ((do-it (string) + (let ((len (fd-stream-obuf-length stream)) + (sap (fd-stream-obuf-sap stream)) + (tail (fd-stream-obuf-tail stream))) + (declare (type index tail) + ;; STRING bounds have already been checked. + (optimize (safety 0))) + (loop + (,@(if output-restart + `(catch 'output-nothing) + `(progn)) + (do* () + ((or (= start end) (< (- len tail) 4))) + (let* ((byte (aref string start)) + (bits (char-code byte)) + (size ,out-size-expr)) + ,out-expr + (incf tail size) + (incf start))) + ;; Exited from the loop normally + (return-from do-it tail)) + ;; Exited via CATCH. Skip the current character + ;; and try the inner loop again. + (incf start))))) + (declare (inline do-it)) + ;; Specialized versions for the common cases of + ;; SIMPLE-BASE-STRING and (SIMPLE-ARRAY CHARACTER) + ;; to avoid doing a generic AREF. + (etypecase string + (simple-base-string + (do-it (the simple-base-string string))) + #!+sb-unicode + ((simple-array character) + ;; For some reason the type information from the + ;; etypecase doesn't propagate through here without + ;; an explicit THE. + (do-it (the (simple-array character) string))) + (string + (do-it string))))) (when (< start end) (flush-output-buffer stream))) (when flush-p @@ -1148,7 +1204,6 @@ (let* ((head (fd-stream-ibuf-head stream)) (tail (fd-stream-ibuf-tail stream)) (sap (fd-stream-ibuf-sap stream)) - (head-start head) (decode-break-reason nil)) (declare (type index head tail)) ;; Copy data from stream buffer into user's buffer. @@ -1165,17 +1220,22 @@ (incf head size)) nil)) (setf (fd-stream-ibuf-head stream) head) - (when (and decode-break-reason - (= head head-start)) + (when decode-break-reason + ;; If we've already read some characters on when the invalid + ;; code sequence is detected, we return immediately. The + ;; handling of the error is deferred until the next call + ;; (where this check will be false). This allows establishing + ;; high-level handlers for decode errors (for example + ;; automatically resyncing in Lisp comments). + (when (plusp total-copied) + (return-from ,in-function total-copied)) (when (stream-decoding-error-and-handle stream decode-break-reason) (if eof-error-p (error 'end-of-file :stream stream) (return-from ,in-function total-copied))) (setf head (fd-stream-ibuf-head stream)) - (setf tail (fd-stream-ibuf-tail stream))) - (when (plusp total-copied) - (return-from ,in-function total-copied))) + (setf tail (fd-stream-ibuf-tail stream)))) (setf (fd-stream-ibuf-head stream) head) ;; Maybe we need to refill the stream buffer. (cond ( ;; If there were enough data in the stream buffer, we're done.