0.9.6.22:

[sbcl.git] / src / code / fd-stream.lisp

diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index 0ef85b1..6e2b2b4 100644 (file)
--- 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)
         (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)
           (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)))
                      (> (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 ()
               ((= 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
             (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
               (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 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
         (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)
             (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)))
         (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.
             ;; 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)))
               (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.
                 (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)
                   ( ;; 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.
                   ))))
                   ;; 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)))
                      (> (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 ()
               ((= 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
             (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))
           (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.
                  (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)
                         (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))
                 (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.
             (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.