(declare (fixnum start end))
(if (stringp thing)
(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))))))
+ (string-dispatch (simple-base-string
+ #!+sb-unicode
+ (simple-array character)
+ string)
+ thing
+ (and (find #\newline thing :start start :end end)
+ ;; FIXME why do we need both calls?
+ ;; Is find faster forwards than
+ ;; position is backwards?
+ (position #\newline thing
+ :from-end t
+ :start start
+ :end end)))))
(if (and (typep thing 'base-string)
(eq (fd-stream-external-format stream) :latin-1))
(ecase (fd-stream-buffering 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)
- (flet ((do-it (string)
- (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))))
- (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)))))
+ (string-dispatch (simple-base-string
+ #!+sb-unicode
+ (simple-array character)
+ string)
+ 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 tail))
+ ;; Exited via CATCH. Skip the current character
+ ;; and try the inner loop again.
+ (incf start)))))
(when (< start end)
(flush-output-buffer stream)))
(when flush-p
(> (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)
- (flet ((do-it (string)
- (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))))
- (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)))))
+ (string-dispatch (simple-base-string
+ #!+sb-unicode
+ (simple-array character)
+ string)
+ 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 tail))
+ ;; Exited via CATCH. Skip the current character
+ ;; and try the inner loop again.
+ (incf start)))))
(when (< start end)
(flush-output-buffer stream)))
(when flush-p
(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.
(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
projects / sbcl.git / blobdiff