- (if (= errno sb!unix:ewouldblock)
- (error "Write would have blocked, but SERVER told us to go.")
- (simple-stream-perror "couldn't write to ~S" stream errno)))
- ((eql count length) ; Hot damn, it worked.
- (when reuse-sap
- (push base *available-buffers*)))
- ((not (null count)) ; sorta worked..
- (push (list base
- (the index (+ start count))
- end)
- (fd-stream-output-later stream))))))
+ (if (= errno sb!unix:ewouldblock)
+ (error "Write would have blocked, but SERVER told us to go.")
+ (simple-stream-perror "couldn't write to ~S" stream errno)))
+ ((eql count length) ; Hot damn, it worked.
+ (when reuse-sap
+ (with-available-buffers-lock ()
+ (push base *available-buffers*))))
+ ((not (null count)) ; sorta worked..
+ (push (list base
+ (the index (+ start count))
+ end)
+ (fd-stream-output-later stream))))))
- (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))))
- (if (and (typep thing 'base-string)
- (eq (fd-stream-external-format stream) :latin-1))
- (ecase (fd-stream-buffering stream)
- (:full
- (output-raw-bytes stream thing start end))
- (:line
- (output-raw-bytes stream thing start end)
- (when last-newline
- (flush-output-buffer stream)))
- (:none
- (frob-output stream thing start end nil)))
- (ecase (fd-stream-buffering stream)
- (:full (funcall (fd-stream-output-bytes stream)
- stream thing nil start end))
- (:line (funcall (fd-stream-output-bytes stream)
- stream thing last-newline start end))
- (:none (funcall (fd-stream-output-bytes stream)
- stream thing t start end))))
- (if last-newline
- (setf (fd-stream-char-pos stream)
- (- end last-newline 1))
- (incf (fd-stream-char-pos stream)
- (- end start))))
- (ecase (fd-stream-buffering stream)
- ((:line :full)
- (output-raw-bytes stream thing start end))
- (:none
- (frob-output stream thing start end nil))))))
+ (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))))
+ (if (and (typep thing 'base-string)
+ (eq (fd-stream-external-format stream) :latin-1))
+ (ecase (fd-stream-buffering stream)
+ (:full
+ (output-raw-bytes stream thing start end))
+ (:line
+ (output-raw-bytes stream thing start end)
+ (when last-newline
+ (flush-output-buffer stream)))
+ (:none
+ (frob-output stream thing start end nil)))
+ (ecase (fd-stream-buffering stream)
+ (:full (funcall (fd-stream-output-bytes stream)
+ stream thing nil start end))
+ (:line (funcall (fd-stream-output-bytes stream)
+ stream thing last-newline start end))
+ (:none (funcall (fd-stream-output-bytes stream)
+ stream thing t start end))))
+ (if last-newline
+ (setf (fd-stream-char-pos stream)
+ (- end last-newline 1))
+ (incf (fd-stream-char-pos stream)
+ (- end start))))
+ (ecase (fd-stream-buffering stream)
+ ((:line :full)
+ (output-raw-bytes stream thing start end))
+ (:none
+ (frob-output stream thing start end nil))))))
- if (subtypep type `(unsigned-byte ,i))
- do (return-from pick-output-routine
- (values
- (ecase buffering
- (:none
- (lambda (stream byte)
- (output-wrapper (stream (/ i 8) (:none) nil)
- (loop for j from 0 below (/ i 8)
- do (setf (sap-ref-8
- (fd-stream-obuf-sap stream)
- (+ j (fd-stream-obuf-tail stream)))
- (ldb (byte 8 (- i 8 (* j 8))) byte))))))
- (:full
- (lambda (stream byte)
- (output-wrapper (stream (/ i 8) (:full) nil)
- (loop for j from 0 below (/ i 8)
- do (setf (sap-ref-8
- (fd-stream-obuf-sap stream)
- (+ j (fd-stream-obuf-tail stream)))
- (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
- `(unsigned-byte ,i)
- (/ i 8))))
+ if (subtypep type `(unsigned-byte ,i))
+ do (return-from pick-output-routine
+ (values
+ (ecase buffering
+ (:none
+ (lambda (stream byte)
+ (output-wrapper (stream (/ i 8) (:none) nil)
+ (loop for j from 0 below (/ i 8)
+ do (setf (sap-ref-8
+ (fd-stream-obuf-sap stream)
+ (+ j (fd-stream-obuf-tail stream)))
+ (ldb (byte 8 (- i 8 (* j 8))) byte))))))
+ (:full
+ (lambda (stream byte)
+ (output-wrapper (stream (/ i 8) (:full) nil)
+ (loop for j from 0 below (/ i 8)
+ do (setf (sap-ref-8
+ (fd-stream-obuf-sap stream)
+ (+ j (fd-stream-obuf-tail stream)))
+ (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
+ `(unsigned-byte ,i)
+ (/ i 8))))
- if (subtypep type `(signed-byte ,i))
- do (return-from pick-output-routine
- (values
- (ecase buffering
- (:none
- (lambda (stream byte)
- (output-wrapper (stream (/ i 8) (:none) nil)
- (loop for j from 0 below (/ i 8)
- do (setf (sap-ref-8
- (fd-stream-obuf-sap stream)
- (+ j (fd-stream-obuf-tail stream)))
- (ldb (byte 8 (- i 8 (* j 8))) byte))))))
- (:full
- (lambda (stream byte)
- (output-wrapper (stream (/ i 8) (:full) nil)
- (loop for j from 0 below (/ i 8)
- do (setf (sap-ref-8
- (fd-stream-obuf-sap stream)
- (+ j (fd-stream-obuf-tail stream)))
- (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
- `(signed-byte ,i)
- (/ i 8)))))
+ if (subtypep type `(signed-byte ,i))
+ do (return-from pick-output-routine
+ (values
+ (ecase buffering
+ (:none
+ (lambda (stream byte)
+ (output-wrapper (stream (/ i 8) (:none) nil)
+ (loop for j from 0 below (/ i 8)
+ do (setf (sap-ref-8
+ (fd-stream-obuf-sap stream)
+ (+ j (fd-stream-obuf-tail stream)))
+ (ldb (byte 8 (- i 8 (* j 8))) byte))))))
+ (:full
+ (lambda (stream byte)
+ (output-wrapper (stream (/ i 8) (:full) nil)
+ (loop for j from 0 below (/ i 8)
+ do (setf (sap-ref-8
+ (fd-stream-obuf-sap stream)
+ (+ j (fd-stream-obuf-tail stream)))
+ (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
+ `(signed-byte ,i)
+ (/ i 8)))))
- (multiple-value-bind (count errno)
- ;; FIXME: Judging from compiler warnings, this WITH-ALIEN form expands
- ;; into something which uses the not-yet-defined type
- ;; (SB!ALIEN-INTERNALS:ALIEN (* (SB!ALIEN:STRUCT SB!UNIX:FD-SET))).
- ;; This is probably inefficient and unsafe and generally bad, so
- ;; try to find some way to make that type known before
- ;; this is compiled.
- (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set)))
- (sb!unix:fd-zero read-fds)
- (sb!unix:fd-set fd read-fds)
- (sb!unix:unix-fast-select (1+ fd)
- (sb!alien:addr read-fds)
- nil
- nil
- 0
- 0))
+ (sb!unix:with-restarted-syscall (count errno)
+ ;; FIXME: Judging from compiler warnings, this WITH-ALIEN form expands
+ ;; into something which uses the not-yet-defined type
+ ;; (SB!ALIEN-INTERNALS:ALIEN (* (SB!ALIEN:STRUCT SB!UNIX:FD-SET))).
+ ;; This is probably inefficient and unsafe and generally bad, so
+ ;; try to find some way to make that type known before
+ ;; this is compiled.
+ (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set)))
+ (sb!unix:fd-zero read-fds)
+ (sb!unix:fd-set fd read-fds)
+ (sb!unix:unix-fast-select (1+ fd)
+ (sb!alien:addr read-fds)
+ nil nil 0 0))
- (if (eql errno sb!unix:ewouldblock)
- (progn
- (unless (sb!sys:wait-until-fd-usable
- fd :input (fd-stream-timeout stream))
- (error 'io-timeout :stream stream :direction :read))
- (frob-input stream))
- (simple-stream-perror "couldn't read from ~S" stream errno)))
- ((zerop count)
- (setf (fd-stream-listen stream) :eof)
- (/show0 "THROWing EOF-INPUT-CATCHER")
- (throw 'eof-input-catcher nil))
- (t
- (incf (fd-stream-ibuf-tail stream) count))))))
-
+ (if (eql errno sb!unix:ewouldblock)
+ (progn
+ (unless (sb!sys:wait-until-fd-usable
+ fd :input (fd-stream-timeout stream))
+ (error 'io-timeout :stream stream :direction :read))
+ (refill-buffer/fd stream))
+ (simple-stream-perror "couldn't read from ~S" stream errno)))
+ ((zerop count)
+ (setf (fd-stream-listen stream) :eof)
+ (/show0 "THROWing EOF-INPUT-CATCHER")
+ (throw 'eof-input-catcher nil))
+ (t
+ (incf (fd-stream-ibuf-tail stream) count)
+ count)))))
+
- (prog1
- (fd-stream-unread ,stream-var)
- (setf (fd-stream-unread ,stream-var) nil)
- (setf (fd-stream-listen ,stream-var) nil))
- (let ((,element-var nil)
- (decode-break-reason nil))
- (do ((,retry-var t))
- ((not ,retry-var))
- (unless
- (catch 'eof-input-catcher
- (setf decode-break-reason
- (block decode-break-reason
- (input-at-least ,stream-var 1)
- (let* ((byte (sap-ref-8 (fd-stream-ibuf-sap
- ,stream-var)
- (fd-stream-ibuf-head
- ,stream-var))))
- (setq size ,bytes)
- (input-at-least ,stream-var size)
- (setq ,element-var (locally ,@read-forms))
- (setq ,retry-var nil))
- nil))
- (when decode-break-reason
- (stream-decoding-error-and-handle stream
- decode-break-reason))
- t)
- (let ((octet-count (- (fd-stream-ibuf-tail ,stream-var)
- (fd-stream-ibuf-head ,stream-var))))
- (when (or (zerop octet-count)
- (and (not ,element-var)
- (not decode-break-reason)
- (stream-decoding-error-and-handle
- stream octet-count)))
- (setq ,retry-var nil)))))
- (cond (,element-var
- (incf (fd-stream-ibuf-head ,stream-var) size)
- ,element-var)
- (t
- (eof-or-lose ,stream-var ,eof-error ,eof-value))))))))
+ (prog1
+ (fd-stream-unread ,stream-var)
+ (setf (fd-stream-unread ,stream-var) nil)
+ (setf (fd-stream-listen ,stream-var) nil))
+ (let ((,element-var nil)
+ (decode-break-reason nil))
+ (do ((,retry-var t))
+ ((not ,retry-var))
+ (unless
+ (catch 'eof-input-catcher
+ (setf decode-break-reason
+ (block decode-break-reason
+ (input-at-least ,stream-var 1)
+ (let* ((byte (sap-ref-8 (fd-stream-ibuf-sap
+ ,stream-var)
+ (fd-stream-ibuf-head
+ ,stream-var))))
+ (setq size ,bytes)
+ (input-at-least ,stream-var size)
+ (setq ,element-var (locally ,@read-forms))
+ (setq ,retry-var nil))
+ nil))
+ (when decode-break-reason
+ (stream-decoding-error-and-handle stream
+ decode-break-reason))
+ t)
+ (let ((octet-count (- (fd-stream-ibuf-tail ,stream-var)
+ (fd-stream-ibuf-head ,stream-var))))
+ (when (or (zerop octet-count)
+ (and (not ,element-var)
+ (not decode-break-reason)
+ (stream-decoding-error-and-handle
+ stream octet-count)))
+ (setq ,retry-var nil)))))
+ (cond (,element-var
+ (incf (fd-stream-ibuf-head ,stream-var) size)
+ ,element-var)
+ (t
+ (eof-or-lose ,stream-var ,eof-error ,eof-value))))))))
- (prog1
- (fd-stream-unread ,stream-var)
- (setf (fd-stream-unread ,stream-var) nil)
- (setf (fd-stream-listen ,stream-var) nil))
- (let ((,element-var
- (catch 'eof-input-catcher
- (input-at-least ,stream-var ,bytes)
- (locally ,@read-forms))))
- (cond (,element-var
- (incf (fd-stream-ibuf-head ,stream-var) ,bytes)
- ,element-var)
- (t
- (eof-or-lose ,stream-var ,eof-error ,eof-value))))))))
+ (prog1
+ (fd-stream-unread ,stream-var)
+ (setf (fd-stream-unread ,stream-var) nil)
+ (setf (fd-stream-listen ,stream-var) nil))
+ (let ((,element-var
+ (catch 'eof-input-catcher
+ (input-at-least ,stream-var ,bytes)
+ (locally ,@read-forms))))
+ (cond (,element-var
+ (incf (fd-stream-ibuf-head ,stream-var) ,bytes)
+ ,element-var)
+ (t
+ (eof-or-lose ,stream-var ,eof-error ,eof-value))))))))
- if (subtypep type `(unsigned-byte ,i))
- do (return-from pick-input-routine
- (values
- (lambda (stream eof-error eof-value)
- (input-wrapper (stream (/ i 8) eof-error eof-value)
- (let ((sap (fd-stream-ibuf-sap stream))
- (head (fd-stream-ibuf-head stream)))
- (loop for j from 0 below (/ i 8)
- with result = 0
- do (setf result
- (+ (* 256 result)
- (sap-ref-8 sap (+ head j))))
- finally (return result)))))
- `(unsigned-byte ,i)
- (/ i 8))))
+ if (subtypep type `(unsigned-byte ,i))
+ do (return-from pick-input-routine
+ (values
+ (lambda (stream eof-error eof-value)
+ (input-wrapper (stream (/ i 8) eof-error eof-value)
+ (let ((sap (fd-stream-ibuf-sap stream))
+ (head (fd-stream-ibuf-head stream)))
+ (loop for j from 0 below (/ i 8)
+ with result = 0
+ do (setf result
+ (+ (* 256 result)
+ (sap-ref-8 sap (+ head j))))
+ finally (return result)))))
+ `(unsigned-byte ,i)
+ (/ i 8))))
- if (subtypep type `(signed-byte ,i))
- do (return-from pick-input-routine
- (values
- (lambda (stream eof-error eof-value)
- (input-wrapper (stream (/ i 8) eof-error eof-value)
- (let ((sap (fd-stream-ibuf-sap stream))
- (head (fd-stream-ibuf-head stream)))
- (loop for j from 0 below (/ i 8)
- with result = 0
- do (setf result
- (+ (* 256 result)
- (sap-ref-8 sap (+ head j))))
- finally (return (if (logbitp (1- i) result)
+ if (subtypep type `(signed-byte ,i))
+ do (return-from pick-input-routine
+ (values
+ (lambda (stream eof-error eof-value)
+ (input-wrapper (stream (/ i 8) eof-error eof-value)
+ (let ((sap (fd-stream-ibuf-sap stream))
+ (head (fd-stream-ibuf-head stream)))
+ (loop for j from 0 below (/ i 8)
+ with result = 0
+ do (setf result
+ (+ (* 256 result)
+ (sap-ref-8 sap (+ head j))))
+ finally (return (if (logbitp (1- i) result)
- (= total-copied requested)
- (return total-copied))
- (;; If EOF, we're done in another way.
- (zerop (refill-fd-stream-buffer stream))
- (if eof-error-p
- (error 'end-of-file :stream stream)
- (return total-copied)))
- ;; Otherwise we refilled the stream buffer, so fall
- ;; through into another pass of the loop.
- ))))
-
-;;; Try to refill the stream buffer. Return the number of bytes read.
-;;; (For EOF, the return value will be zero, otherwise positive.)
-(defun refill-fd-stream-buffer (stream)
- ;; We don't have any logic to preserve leftover bytes in the buffer,
- ;; so we should only be called when the buffer is empty.
- ;; FIXME: can have three bytes in buffer because of UTF-8
- (let ((new-head 0)
- (sap (fd-stream-ibuf-sap stream)))
- (do ((head (fd-stream-ibuf-head stream) (1+ head))
- (tail (fd-stream-ibuf-tail stream)))
- ((= head tail))
- (setf (sap-ref-8 sap new-head) (sap-ref-8 sap head))
- (incf new-head))
- (multiple-value-bind (count err)
- (sb!unix:unix-read (fd-stream-fd stream)
- (sap+ sap new-head)
- (- (fd-stream-ibuf-length stream) new-head))
- (declare (type (or index null) count))
- (when (null count)
- (simple-stream-perror "couldn't read from ~S" stream err))
- (setf (fd-stream-listen stream) nil
- (fd-stream-ibuf-head stream) 0
- (fd-stream-ibuf-tail stream) (+ count new-head))
- count)))
+ (= total-copied requested)
+ (return total-copied))
+ (;; 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)))
+ ;; Otherwise we refilled the stream buffer, so fall
+ ;; through into another pass of the loop.
+ ))))
- (let ((start (or start 0))
- (end (or end (length string))))
- (declare (type index start end))
- (when (> (fd-stream-ibuf-tail stream)
- (fd-stream-ibuf-head stream))
- (file-position stream (file-position stream)))
- (when (< end start)
- (error ":END before :START!"))
- (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)
+ (let ((start (or start 0))
+ (end (or end (length string))))
+ (declare (type index start end))
+ (when (and (not (fd-stream-dual-channel-p stream))
+ (> (fd-stream-ibuf-tail stream)
+ (fd-stream-ibuf-head stream)))
+ (file-position stream (file-position stream)))
+ (when (< end start)
+ (error ":END before :START!"))
+ (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)
- &aux (total-copied 0))
- (declare (type fd-stream stream))
- (declare (type index start requested total-copied))
- (let ((unread (fd-stream-unread stream)))
- (when unread
- (setf (aref buffer start) unread)
- (setf (fd-stream-unread stream) nil)
- (setf (fd-stream-listen stream) nil)
- (incf total-copied)))
- (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))
- ;; Copy data from stream buffer into user's buffer.
- (do ()
- ((or (= tail head) (= requested total-copied)))
- (let* ((byte (sap-ref-8 sap head)))
- (when (> ,size (- tail head))
- (return))
- (setf (aref buffer (+ start total-copied)) ,in-expr)
- (incf total-copied)
- (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))
- ( ;; If EOF, we're done in another way.
- (zerop (refill-fd-stream-buffer stream))
- (if eof-error-p
- (error 'end-of-file :stream stream)
- (return total-copied)))
- ;; Otherwise we refilled the stream buffer, so fall
- ;; through into another pass of the loop.
- ))))
+ &aux (total-copied 0))
+ (declare (type fd-stream stream))
+ (declare (type index start requested total-copied))
+ (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 (fd-stream-unread stream) nil)
+ (setf (fd-stream-listen stream) nil)
+ (incf total-copied)))
+ (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))
+ ;; Copy data from stream buffer into user's buffer.
+ (do ()
+ ((or (= tail head) (= requested total-copied)))
+ (let* ((byte (sap-ref-8 sap head)))
+ (when (> ,size (- tail head))
+ (return))
+ (setf (aref buffer (+ start total-copied)) ,in-expr)
+ (incf total-copied)
+ (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))
+ ( ;; 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)))
+ ;; Otherwise we refilled the stream buffer, so fall
+ ;; through into another pass of the loop.
+ ))))
- (defun ,out-function (fd-stream string flush-p start end)
- (let ((start (or start 0))
- (end (or end (length string))))
- (declare (type index start end))
- (when (> (fd-stream-ibuf-tail fd-stream)
- (fd-stream-ibuf-head fd-stream))
- (file-position fd-stream (file-position fd-stream)))
- (when (< end start)
- (error ":END before :START!"))
- (do ()
- ((= end start))
- (setf (fd-stream-obuf-tail fd-stream)
- (do* ((len (fd-stream-obuf-length fd-stream))
- (sap (fd-stream-obuf-sap fd-stream))
- (tail (fd-stream-obuf-tail fd-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)
- (incf start)))
- `(let* ((byte (aref string start))
- (bits (char-code byte))
- (size ,out-size-expr))
- ,out-expr
- (incf tail size)))
- (incf start)))
- (when (< start end)
- (flush-output-buffer fd-stream)))
- (when flush-p
- (flush-output-buffer fd-stream))))
+ (defun ,out-function (stream string flush-p start end)
+ (let ((start (or start 0))
+ (end (or end (length string))))
+ (declare (type index start end))
+ (when (and (not (fd-stream-dual-channel-p stream))
+ (> (fd-stream-ibuf-tail stream)
+ (fd-stream-ibuf-head stream)))
+ (file-position stream (file-position stream)))
+ (when (< end start)
+ (error ":END before :START!"))
+ (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)))
+ (when (< start end)
+ (flush-output-buffer stream)))
+ (when flush-p
+ (flush-output-buffer stream))))
- &aux (total-copied 0))
- (declare (type fd-stream stream))
- (declare (type index start requested total-copied))
- (let ((unread (fd-stream-unread stream)))
- (when unread
- (setf (aref buffer start) unread)
- (setf (fd-stream-unread stream) nil)
- (setf (fd-stream-listen stream) nil)
- (incf total-copied)))
- (do ()
- (nil)
- (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.
- (do ((size nil nil))
- ((or (= tail head) (= requested total-copied)))
- (setf decode-break-reason
- (block decode-break-reason
- (let ((byte (sap-ref-8 sap head)))
- (setq size ,in-size-expr)
- (when (> size (- tail head))
- (return))
- (setf (aref buffer (+ start total-copied)) ,in-expr)
- (incf total-copied)
- (incf head size))
- nil))
- (setf (fd-stream-ibuf-head stream) head)
- (when (and decode-break-reason
- (= head head-start))
- (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 (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))
- ( ;; If EOF, we're done in another way.
- (or (eq decode-break-reason 'eof)
- (zerop (refill-fd-stream-buffer stream)))
- (if eof-error-p
- (error 'end-of-file :stream stream)
- (return total-copied)))
- ;; Otherwise we refilled the stream buffer, so fall
- ;; through into another pass of the loop.
- ))))
+ &aux (total-copied 0))
+ (declare (type fd-stream stream))
+ (declare (type index start requested total-copied))
+ (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 (fd-stream-unread stream) nil)
+ (setf (fd-stream-listen stream) nil)
+ (incf total-copied)))
+ (do ()
+ (nil)
+ (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.
+ (do ((size nil nil))
+ ((or (= tail head) (= requested total-copied)))
+ (setf decode-break-reason
+ (block decode-break-reason
+ (let ((byte (sap-ref-8 sap head)))
+ (setq size ,in-size-expr)
+ (when (> size (- tail head))
+ (return))
+ (setf (aref buffer (+ start total-copied)) ,in-expr)
+ (incf total-copied)
+ (incf head size))
+ nil))
+ (setf (fd-stream-ibuf-head stream) head)
+ (when (and decode-break-reason
+ (= head head-start))
+ (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 (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))
+ ( ;; If EOF, we're done in another way.
+ (or (eq decode-break-reason 'eof)
+ (null (catch 'eof-input-catcher
+ (refill-buffer/fd stream))))
+ (if eof-error-p
+ (error 'end-of-file :stream stream)
+ (return total-copied)))
+ ;; Otherwise we refilled the stream buffer, so fall
+ ;; through into another pass of the loop.
+ ))))
- (map-into s #'code-char
- '(#x00 #x01 #x02 #x03 #x9c #x09 #x86 #x7f #x97 #x8d #x8e #x0b #x0c #x0d #x0e #x0f
- #x10 #x11 #x12 #x13 #x9d #x85 #x08 #x87 #x18 #x19 #x92 #x8f #x1c #x1d #x1e #x1f
- #x80 #x81 #x82 #x83 #x84 #x0a #x17 #x1b #x88 #x89 #x8a #x8b #x8c #x05 #x06 #x07
- #x90 #x91 #x16 #x93 #x94 #x95 #x96 #x04 #x98 #x99 #x9a #x9b #x14 #x15 #x9e #x1a
- #x20 #xa0 #xe2 #xe4 #xe0 #xe1 #xe3 #xe5 #xe7 #xf1 #xa2 #x2e #x3c #x28 #x2b #x7c
- #x26 #xe9 #xea #xeb #xe8 #xed #xee #xef #xec #xdf #x21 #x24 #x2a #x29 #x3b #xac
- #x2d #x2f #xc2 #xc4 #xc0 #xc1 #xc3 #xc5 #xc7 #xd1 #xa6 #x2c #x25 #x5f #x3e #x3f
- #xf8 #xc9 #xca #xcb #xc8 #xcd #xce #xcf #xcc #x60 #x3a #x23 #x40 #x27 #x3d #x22
- #xd8 #x61 #x62 #x63 #x64 #x65 #x66 #x67 #x68 #x69 #xab #xbb #xf0 #xfd #xfe #xb1
- #xb0 #x6a #x6b #x6c #x6d #x6e #x6f #x70 #x71 #x72 #xaa #xba #xe6 #xb8 #xc6 #xa4
- #xb5 #x7e #x73 #x74 #x75 #x76 #x77 #x78 #x79 #x7a #xa1 #xbf #xd0 #xdd #xde #xae
- #x5e #xa3 #xa5 #xb7 #xa9 #xa7 #xb6 #xbc #xbd #xbe #x5b #x5d #xaf #xa8 #xb4 #xd7
- #x7b #x41 #x42 #x43 #x44 #x45 #x46 #x47 #x48 #x49 #xad #xf4 #xf6 #xf2 #xf3 #xf5
- #x7d #x4a #x4b #x4c #x4d #x4e #x4f #x50 #x51 #x52 #xb9 #xfb #xfc #xf9 #xfa #xff
- #x5c #xf7 #x53 #x54 #x55 #x56 #x57 #x58 #x59 #x5a #xb2 #xd4 #xd6 #xd2 #xd3 #xd5
- #x30 #x31 #x32 #x33 #x34 #x35 #x36 #x37 #x38 #x39 #xb3 #xdb #xdc #xd9 #xda #x9f))
- s))
+ (map-into s #'code-char
+ '(#x00 #x01 #x02 #x03 #x9c #x09 #x86 #x7f #x97 #x8d #x8e #x0b #x0c #x0d #x0e #x0f
+ #x10 #x11 #x12 #x13 #x9d #x85 #x08 #x87 #x18 #x19 #x92 #x8f #x1c #x1d #x1e #x1f
+ #x80 #x81 #x82 #x83 #x84 #x0a #x17 #x1b #x88 #x89 #x8a #x8b #x8c #x05 #x06 #x07
+ #x90 #x91 #x16 #x93 #x94 #x95 #x96 #x04 #x98 #x99 #x9a #x9b #x14 #x15 #x9e #x1a
+ #x20 #xa0 #xe2 #xe4 #xe0 #xe1 #xe3 #xe5 #xe7 #xf1 #xa2 #x2e #x3c #x28 #x2b #x7c
+ #x26 #xe9 #xea #xeb #xe8 #xed #xee #xef #xec #xdf #x21 #x24 #x2a #x29 #x3b #xac
+ #x2d #x2f #xc2 #xc4 #xc0 #xc1 #xc3 #xc5 #xc7 #xd1 #xa6 #x2c #x25 #x5f #x3e #x3f
+ #xf8 #xc9 #xca #xcb #xc8 #xcd #xce #xcf #xcc #x60 #x3a #x23 #x40 #x27 #x3d #x22
+ #xd8 #x61 #x62 #x63 #x64 #x65 #x66 #x67 #x68 #x69 #xab #xbb #xf0 #xfd #xfe #xb1
+ #xb0 #x6a #x6b #x6c #x6d #x6e #x6f #x70 #x71 #x72 #xaa #xba #xe6 #xb8 #xc6 #xa4
+ #xb5 #x7e #x73 #x74 #x75 #x76 #x77 #x78 #x79 #x7a #xa1 #xbf #xd0 #xdd #xde #xae
+ #x5e #xa3 #xa5 #xb7 #xa9 #xa7 #xb6 #xbc #xbd #xbe #x5b #x5d #xaf #xa8 #xb4 #xd7
+ #x7b #x41 #x42 #x43 #x44 #x45 #x46 #x47 #x48 #x49 #xad #xf4 #xf6 #xf2 #xf3 #xf5
+ #x7d #x4a #x4b #x4c #x4d #x4e #x4f #x50 #x51 #x52 #xb9 #xfb #xfc #xf9 #xfa #xff
+ #x5c #xf7 #x53 #x54 #x55 #x56 #x57 #x58 #x59 #x5a #xb2 #xd4 #xd6 #xd2 #xd3 #xd5
+ #x30 #x31 #x32 #x33 #x34 #x35 #x36 #x37 #x38 #x39 #xb3 #xdb #xdc #xd9 #xda #x9f))
+ s))
- (1 byte)
- (2 (let ((byte2 (sap-ref-8 sap (1+ head))))
- (unless (<= #x80 byte2 #xbf)
- (return-from decode-break-reason 2))
- (dpb byte (byte 5 6) byte2)))
- (3 (let ((byte2 (sap-ref-8 sap (1+ head)))
- (byte3 (sap-ref-8 sap (+ 2 head))))
- (unless (and (<= #x80 byte2 #xbf)
- (<= #x80 byte3 #xbf))
- (return-from decode-break-reason 3))
- (dpb byte (byte 4 12) (dpb byte2 (byte 6 6) byte3))))
- (4 (let ((byte2 (sap-ref-8 sap (1+ head)))
- (byte3 (sap-ref-8 sap (+ 2 head)))
- (byte4 (sap-ref-8 sap (+ 3 head))))
- (unless (and (<= #x80 byte2 #xbf)
- (<= #x80 byte3 #xbf)
- (<= #x80 byte4 #xbf))
- (return-from decode-break-reason 4))
- (dpb byte (byte 3 18)
- (dpb byte2 (byte 6 12)
- (dpb byte3 (byte 6 6) byte4))))))))
+ (1 byte)
+ (2 (let ((byte2 (sap-ref-8 sap (1+ head))))
+ (unless (<= #x80 byte2 #xbf)
+ (return-from decode-break-reason 2))
+ (dpb byte (byte 5 6) byte2)))
+ (3 (let ((byte2 (sap-ref-8 sap (1+ head)))
+ (byte3 (sap-ref-8 sap (+ 2 head))))
+ (unless (and (<= #x80 byte2 #xbf)
+ (<= #x80 byte3 #xbf))
+ (return-from decode-break-reason 3))
+ (dpb byte (byte 4 12) (dpb byte2 (byte 6 6) byte3))))
+ (4 (let ((byte2 (sap-ref-8 sap (1+ head)))
+ (byte3 (sap-ref-8 sap (+ 2 head)))
+ (byte4 (sap-ref-8 sap (+ 3 head))))
+ (unless (and (<= #x80 byte2 #xbf)
+ (<= #x80 byte3 #xbf)
+ (<= #x80 byte4 #xbf))
+ (return-from decode-break-reason 4))
+ (dpb byte (byte 3 18)
+ (dpb byte2 (byte 6 12)
+ (dpb byte3 (byte 6 6) byte4))))))))
-(defun set-fd-stream-routines (fd-stream type input-p output-p buffer-p)
- (let ((target-type (case type
- ((:default unsigned-byte)
- '(unsigned-byte 8))
- (signed-byte
- '(signed-byte 8))
- (t
- type)))
- (input-type nil)
- (output-type nil)
- (input-size nil)
- (output-size nil)
- (character-stream-p (subtypep type 'character)))
-
- (when (fd-stream-obuf-sap fd-stream)
- (push (fd-stream-obuf-sap fd-stream) *available-buffers*)
- (setf (fd-stream-obuf-sap fd-stream) nil))
- (when (fd-stream-ibuf-sap fd-stream)
- (push (fd-stream-ibuf-sap fd-stream) *available-buffers*)
- (setf (fd-stream-ibuf-sap fd-stream) nil))
+(defun set-fd-stream-routines (fd-stream element-type external-format
+ input-p output-p buffer-p)
+ (let* ((target-type (case element-type
+ (unsigned-byte '(unsigned-byte 8))
+ (signed-byte '(signed-byte 8))
+ (:default 'character)
+ (t element-type)))
+ (character-stream-p (subtypep target-type 'character))
+ (bivalent-stream-p (eq element-type :default))
+ normalized-external-format
+ (bin-routine #'ill-bin)
+ (bin-type nil)
+ (bin-size nil)
+ (cin-routine #'ill-in)
+ (cin-type nil)
+ (cin-size nil)
+ (input-type nil) ;calculated from bin-type/cin-type
+ (input-size nil) ;calculated from bin-size/cin-size
+ (read-n-characters #'ill-in)
+ (bout-routine #'ill-bout)
+ (bout-type nil)
+ (bout-size nil)
+ (cout-routine #'ill-out)
+ (cout-type nil)
+ (cout-size nil)
+ (output-type nil)
+ (output-size nil)
+ (output-bytes #'ill-bout))
+
+ ;; drop buffers when direction changes
+ (when (and (fd-stream-obuf-sap fd-stream) (not output-p))
+ (with-available-buffers-lock ()
+ (push (fd-stream-obuf-sap fd-stream) *available-buffers*)
+ (setf (fd-stream-obuf-sap fd-stream) nil)))
+ (when (and (fd-stream-ibuf-sap fd-stream) (not input-p))
+ (with-available-buffers-lock ()
+ (push (fd-stream-ibuf-sap fd-stream) *available-buffers*)
+ (setf (fd-stream-ibuf-sap fd-stream) nil)))
+ (when input-p
+ (setf (fd-stream-ibuf-sap fd-stream) (next-available-buffer))
+ (setf (fd-stream-ibuf-length fd-stream) bytes-per-buffer)
+ (setf (fd-stream-ibuf-tail fd-stream) 0))
+ (when output-p
+ (setf (fd-stream-obuf-sap fd-stream) (next-available-buffer))
+ (setf (fd-stream-obuf-length fd-stream) bytes-per-buffer)
+ (setf (fd-stream-obuf-tail fd-stream) 0)
+ (setf (fd-stream-char-pos fd-stream) 0))
- (multiple-value-bind (routine type size read-n-characters
- normalized-external-format)
- (pick-input-routine target-type
- (fd-stream-external-format fd-stream))
- (when normalized-external-format
- (setf (fd-stream-external-format fd-stream)
- normalized-external-format))
- (unless routine
- (error "could not find any input routine for ~S" target-type))
- (setf (fd-stream-ibuf-sap fd-stream) (next-available-buffer))
- (setf (fd-stream-ibuf-length fd-stream) bytes-per-buffer)
- (setf (fd-stream-ibuf-tail fd-stream) 0)
- (if character-stream-p
- (setf (fd-stream-in fd-stream) routine
- (fd-stream-bin fd-stream) #'ill-bin)
- (setf (fd-stream-in fd-stream) #'ill-in
- (fd-stream-bin fd-stream) routine))
- (when (eql size 1)
- (setf (fd-stream-n-bin fd-stream)
- (if character-stream-p
- read-n-characters
- #'fd-stream-read-n-bytes))
- (when (and buffer-p
- ;; We only create this buffer for streams of type
- ;; (unsigned-byte 8). Because there's no buffer, the
- ;; other element-types will dispatch to the appropriate
- ;; input (output) routine in fast-read-byte.
- (or character-stream-p
- (equal target-type '(unsigned-byte 8)))
- (not output-p) ; temporary disable on :io streams
- #+(or)
- (or (eq type 'unsigned-byte)
- (eq type :default)))
- (if character-stream-p
- (setf (ansi-stream-cin-buffer fd-stream)
- (make-array +ansi-stream-in-buffer-length+
- :element-type 'character))
- (setf (ansi-stream-in-buffer fd-stream)
- (make-array +ansi-stream-in-buffer-length+
- :element-type '(unsigned-byte 8))))))
- (setf input-size size)
- (setf input-type type)))
+ (when (or (not character-stream-p) bivalent-stream-p)
+ (multiple-value-setq (bin-routine bin-type bin-size read-n-characters
+ normalized-external-format)
+ (pick-input-routine (if bivalent-stream-p '(unsigned-byte 8)
+ target-type)
+ external-format))
+ (unless bin-routine
+ (error "could not find any input routine for ~S" target-type)))
+ (when character-stream-p
+ (multiple-value-setq (cin-routine cin-type cin-size read-n-characters
+ normalized-external-format)
+ (pick-input-routine target-type external-format))
+ (unless cin-routine
+ (error "could not find any input routine for ~S" target-type)))
+ (setf (fd-stream-in fd-stream) cin-routine
+ (fd-stream-bin fd-stream) bin-routine)
+ ;; character type gets preferential treatment
+ (setf input-size (or cin-size bin-size))
+ (setf input-type (or cin-type bin-type))
+ (when normalized-external-format
+ (setf (fd-stream-external-format fd-stream)
+ normalized-external-format))
+ (when (= (or cin-size 1) (or bin-size 1) 1)
+ (setf (fd-stream-n-bin fd-stream) ;XXX
+ (if (and character-stream-p (not bivalent-stream-p))
+ read-n-characters
+ #'fd-stream-read-n-bytes))
+ ;; Sometimes turn on fast-read-char/fast-read-byte. Switch on
+ ;; for character and (unsigned-byte 8) streams. In these
+ ;; cases, fast-read-* will read from the
+ ;; ansi-stream-(c)in-buffer, saving function calls.
+ ;; Otherwise, the various data-reading functions in the stream
+ ;; structure will be called.
+ (when (and buffer-p
+ (not bivalent-stream-p)
+ ;; temporary disable on :io streams
+ (not output-p))
+ (cond (character-stream-p
+ (setf (ansi-stream-cin-buffer fd-stream)
+ (make-array +ansi-stream-in-buffer-length+
+ :element-type 'character)))
+ ((equal target-type '(unsigned-byte 8))
+ (setf (ansi-stream-in-buffer fd-stream)
+ (make-array +ansi-stream-in-buffer-length+
+ :element-type '(unsigned-byte 8))))))))
- (multiple-value-bind (routine type size output-bytes
- normalized-external-format)
- (pick-output-routine target-type
- (fd-stream-buffering fd-stream)
- (fd-stream-external-format fd-stream))
- (when normalized-external-format
- (setf (fd-stream-external-format fd-stream)
- normalized-external-format))
- (unless routine
- (error "could not find any output routine for ~S buffered ~S"
- (fd-stream-buffering fd-stream)
- target-type))
- (setf (fd-stream-obuf-sap fd-stream) (next-available-buffer))
- (setf (fd-stream-obuf-length fd-stream) bytes-per-buffer)
- (setf (fd-stream-obuf-tail fd-stream) 0)
- (when character-stream-p
- (setf (fd-stream-output-bytes fd-stream) output-bytes))
- (if character-stream-p
- (setf (fd-stream-out fd-stream) routine
- (fd-stream-bout fd-stream) #'ill-bout)
- (setf (fd-stream-out fd-stream)
- (or (if (eql size 1)
- (pick-output-routine
- 'base-char (fd-stream-buffering fd-stream)))
- #'ill-out)
- (fd-stream-bout fd-stream) routine))
- (setf (fd-stream-sout fd-stream)
- (if (eql size 1) #'fd-sout #'ill-out))
- (setf (fd-stream-char-pos fd-stream) 0)
- (setf output-size size)
- (setf output-type type)))
+ (when (or (not character-stream-p) bivalent-stream-p)
+ (multiple-value-setq (bout-routine bout-type bout-size output-bytes
+ normalized-external-format)
+ (pick-output-routine (if bivalent-stream-p
+ '(unsigned-byte 8)
+ target-type)
+ (fd-stream-buffering fd-stream)
+ external-format))
+ (unless bout-routine
+ (error "could not find any output routine for ~S buffered ~S"
+ (fd-stream-buffering fd-stream)
+ target-type)))
+ (when character-stream-p
+ (multiple-value-setq (cout-routine cout-type cout-size output-bytes
+ normalized-external-format)
+ (pick-output-routine target-type
+ (fd-stream-buffering fd-stream)
+ external-format))
+ (unless cout-routine
+ (error "could not find any output routine for ~S buffered ~S"
+ (fd-stream-buffering fd-stream)
+ target-type)))
+ (when normalized-external-format
+ (setf (fd-stream-external-format fd-stream)
+ normalized-external-format))
+ (when character-stream-p
+ (setf (fd-stream-output-bytes fd-stream) output-bytes))
+ (setf (fd-stream-out fd-stream) cout-routine
+ (fd-stream-bout fd-stream) bout-routine
+ (fd-stream-sout fd-stream) (if (eql cout-size 1)
+ #'fd-sout #'ill-out))
+ (setf output-size (or cout-size bout-size))
+ (setf output-type (or cout-type bout-type)))
- (fd-stream-ibuf-tail fd-stream)))
- (fd-stream-listen fd-stream)
- (setf (fd-stream-listen fd-stream)
- (eql (sb!alien:with-alien ((read-fds (sb!alien:struct
- sb!unix:fd-set)))
- (sb!unix:fd-zero read-fds)
- (sb!unix:fd-set (fd-stream-fd fd-stream) read-fds)
- (sb!unix:unix-fast-select (1+ (fd-stream-fd fd-stream))
- (sb!alien:addr read-fds)
- nil nil 0 0))
- 1))))
+ (fd-stream-ibuf-tail fd-stream)))
+ (fd-stream-listen fd-stream)
+ (setf (fd-stream-listen fd-stream)
+ (eql (sb!unix:with-restarted-syscall ()
+ (sb!alien:with-alien ((read-fds (sb!alien:struct
+ sb!unix:fd-set)))
+ (sb!unix:fd-zero read-fds)
+ (sb!unix:fd-set (fd-stream-fd fd-stream) read-fds)
+ (sb!unix:unix-fast-select (1+ (fd-stream-fd fd-stream))
+ (sb!alien:addr read-fds)
+ nil nil 0 0)))
+ 1))))
- (when (fd-stream-handler fd-stream)
- (sb!sys:remove-fd-handler (fd-stream-handler fd-stream))
- (setf (fd-stream-handler fd-stream) nil))
- ;; We can't do anything unless we know what file were
- ;; dealing with, and we don't want to do anything
- ;; strange unless we were writing to the file.
- (when (and (fd-stream-file fd-stream)
- (fd-stream-obuf-sap fd-stream))
- (if (fd-stream-original fd-stream)
- ;; If the original is EQ to file we are appending
- ;; and can just close the file without renaming.
- (unless (eq (fd-stream-original fd-stream)
- (fd-stream-file fd-stream))
- ;; We have a handle on the original, just revert.
- (multiple-value-bind (okay err)
- (sb!unix:unix-rename (fd-stream-original fd-stream)
- (fd-stream-file fd-stream))
- (unless okay
- (simple-stream-perror
- "couldn't restore ~S to its original contents"
- fd-stream
- err))))
- ;; We can't restore the original, and aren't
- ;; appending, so nuke that puppy.
- ;;
- ;; FIXME: This is currently the fate of superseded
- ;; files, and according to the CLOSE spec this is
- ;; wrong. However, there seems to be no clean way to
- ;; do that that doesn't involve either copying the
- ;; data (bad if the :abort resulted from a full
- ;; disk), or renaming the old file temporarily
- ;; (probably bad because stream opening becomes more
- ;; racy).
- (multiple-value-bind (okay err)
- (sb!unix:unix-unlink (fd-stream-file fd-stream))
- (unless okay
- (error 'simple-file-error
- :pathname (fd-stream-file fd-stream)
- :format-control
- "~@<couldn't remove ~S: ~2I~_~A~:>"
- :format-arguments (list (fd-stream-file fd-stream)
- (strerror err))))))))
- (t
- (fd-stream-misc-routine fd-stream :finish-output)
- (when (and (fd-stream-original fd-stream)
- (fd-stream-delete-original fd-stream))
- (multiple-value-bind (okay err)
- (sb!unix:unix-unlink (fd-stream-original fd-stream))
- (unless okay
- (error 'simple-file-error
- :pathname (fd-stream-original fd-stream)
- :format-control
- "~@<couldn't delete ~S during close of ~S: ~
+ (when (fd-stream-handler fd-stream)
+ (sb!sys:remove-fd-handler (fd-stream-handler fd-stream))
+ (setf (fd-stream-handler fd-stream) nil))
+ ;; We can't do anything unless we know what file were
+ ;; dealing with, and we don't want to do anything
+ ;; strange unless we were writing to the file.
+ (when (and (fd-stream-file fd-stream)
+ (fd-stream-obuf-sap fd-stream))
+ (if (fd-stream-original fd-stream)
+ ;; If the original is EQ to file we are appending
+ ;; and can just close the file without renaming.
+ (unless (eq (fd-stream-original fd-stream)
+ (fd-stream-file fd-stream))
+ ;; We have a handle on the original, just revert.
+ (multiple-value-bind (okay err)
+ (sb!unix:unix-rename (fd-stream-original fd-stream)
+ (fd-stream-file fd-stream))
+ (unless okay
+ (simple-stream-perror
+ "couldn't restore ~S to its original contents"
+ fd-stream
+ err))))
+ ;; We can't restore the original, and aren't
+ ;; appending, so nuke that puppy.
+ ;;
+ ;; FIXME: This is currently the fate of superseded
+ ;; files, and according to the CLOSE spec this is
+ ;; wrong. However, there seems to be no clean way to
+ ;; do that that doesn't involve either copying the
+ ;; data (bad if the :abort resulted from a full
+ ;; disk), or renaming the old file temporarily
+ ;; (probably bad because stream opening becomes more
+ ;; racy).
+ (multiple-value-bind (okay err)
+ (sb!unix:unix-unlink (fd-stream-file fd-stream))
+ (unless okay
+ (error 'simple-file-error
+ :pathname (fd-stream-file fd-stream)
+ :format-control
+ "~@<couldn't remove ~S: ~2I~_~A~:>"
+ :format-arguments (list (fd-stream-file fd-stream)
+ (strerror err))))))))
+ (t
+ (fd-stream-misc-routine fd-stream :finish-output)
+ (when (and (fd-stream-original fd-stream)
+ (fd-stream-delete-original fd-stream))
+ (multiple-value-bind (okay err)
+ (sb!unix:unix-unlink (fd-stream-original fd-stream))
+ (unless okay
+ (error 'simple-file-error
+ :pathname (fd-stream-original fd-stream)
+ :format-control
+ "~@<couldn't delete ~S during close of ~S: ~
- ;; First, find the position of the UNIX file descriptor in the file.
- (multiple-value-bind (posn errno)
- (sb!unix:unix-lseek (fd-stream-fd stream) 0 sb!unix:l_incr)
- (declare (type (or (alien sb!unix:off-t) null) posn))
- (cond ((integerp posn)
- ;; Adjust for buffered output: If there is any output
- ;; buffered, the *real* file position will be larger
- ;; than reported by lseek() because lseek() obviously
- ;; cannot take into account output we have not sent
- ;; yet.
- (dolist (later (fd-stream-output-later stream))
- (incf posn (- (caddr later)
- (cadr later))))
- (incf posn (fd-stream-obuf-tail stream))
- ;; Adjust for unread input: If there is any input
- ;; read from UNIX but not supplied to the user of the
- ;; stream, the *real* file position will smaller than
- ;; reported, because we want to look like the unread
- ;; stuff is still available.
- (decf posn (- (fd-stream-ibuf-tail stream)
- (fd-stream-ibuf-head stream)))
- (when (fd-stream-unread stream)
- (decf posn))
- ;; Divide bytes by element size.
- (truncate posn (fd-stream-element-size stream)))
- ((eq errno sb!unix:espipe)
- nil)
- (t
- (sb!sys:with-interrupts
- (simple-stream-perror "failure in Unix lseek() on ~S"
- stream
- errno))))))
+ ;; First, find the position of the UNIX file descriptor in the file.
+ (multiple-value-bind (posn errno)
+ (sb!unix:unix-lseek (fd-stream-fd stream) 0 sb!unix:l_incr)
+ (declare (type (or (alien sb!unix:off-t) null) posn))
+ (cond ((integerp posn)
+ ;; Adjust for buffered output: If there is any output
+ ;; buffered, the *real* file position will be larger
+ ;; than reported by lseek() because lseek() obviously
+ ;; cannot take into account output we have not sent
+ ;; yet.
+ (dolist (later (fd-stream-output-later stream))
+ (incf posn (- (caddr later)
+ (cadr later))))
+ (incf posn (fd-stream-obuf-tail stream))
+ ;; Adjust for unread input: If there is any input
+ ;; read from UNIX but not supplied to the user of the
+ ;; stream, the *real* file position will smaller than
+ ;; reported, because we want to look like the unread
+ ;; stuff is still available.
+ (decf posn (- (fd-stream-ibuf-tail stream)
+ (fd-stream-ibuf-head stream)))
+ (when (fd-stream-unread stream)
+ (decf posn))
+ ;; Divide bytes by element size.
+ (truncate posn (fd-stream-element-size stream)))
+ ((eq errno sb!unix:espipe)
+ nil)
+ (t
+ (sb!sys:with-interrupts
+ (simple-stream-perror "failure in Unix lseek() on ~S"
+ stream
+ errno))))))
- (declare (type (alien sb!unix:off-t) offset))
- ;; Make sure we don't have any output pending, because if we
- ;; move the file pointer before writing this stuff, it will be
- ;; written in the wrong location.
- (flush-output-buffer stream)
- (do ()
- ((null (fd-stream-output-later stream)))
- (sb!sys:serve-all-events))
- ;; Clear out any pending input to force the next read to go to
- ;; the disk.
- (setf (fd-stream-unread stream) nil)
- (setf (fd-stream-ibuf-head stream) 0)
- (setf (fd-stream-ibuf-tail stream) 0)
- ;; Trash cached value for listen, so that we check next time.
- (setf (fd-stream-listen stream) nil)
- ;; Now move it.
- (cond ((eq newpos :start)
- (setf offset 0 origin sb!unix:l_set))
- ((eq newpos :end)
- (setf offset 0 origin sb!unix:l_xtnd))
- ((typep newpos '(alien sb!unix:off-t))
- (setf offset (* newpos (fd-stream-element-size stream))
- origin sb!unix:l_set))
- (t
- (error "invalid position given to FILE-POSITION: ~S" newpos)))
- (multiple-value-bind (posn errno)
- (sb!unix:unix-lseek (fd-stream-fd stream) offset origin)
- (cond ((typep posn '(alien sb!unix:off-t))
- t)
- ((eq errno sb!unix:espipe)
- nil)
- (t
- (simple-stream-perror "error in Unix lseek() on ~S"
- stream
- errno)))))))
+ (declare (type (alien sb!unix:off-t) offset))
+ ;; Make sure we don't have any output pending, because if we
+ ;; move the file pointer before writing this stuff, it will be
+ ;; written in the wrong location.
+ (flush-output-buffer stream)
+ (do ()
+ ((null (fd-stream-output-later stream)))
+ (sb!sys:serve-all-events))
+ ;; Clear out any pending input to force the next read to go to
+ ;; the disk.
+ (setf (fd-stream-unread stream) nil)
+ (setf (fd-stream-ibuf-head stream) 0)
+ (setf (fd-stream-ibuf-tail stream) 0)
+ ;; Trash cached value for listen, so that we check next time.
+ (setf (fd-stream-listen stream) nil)
+ ;; Now move it.
+ (cond ((eq newpos :start)
+ (setf offset 0 origin sb!unix:l_set))
+ ((eq newpos :end)
+ (setf offset 0 origin sb!unix:l_xtnd))
+ ((typep newpos '(alien sb!unix:off-t))
+ (setf offset (* newpos (fd-stream-element-size stream))
+ origin sb!unix:l_set))
+ (t
+ (error "invalid position given to FILE-POSITION: ~S" newpos)))
+ (multiple-value-bind (posn errno)
+ (sb!unix:unix-lseek (fd-stream-fd stream) offset origin)
+ (cond ((typep posn '(alien sb!unix:off-t))
+ t)
+ ((eq errno sb!unix:espipe)
+ nil)
+ (t
+ (simple-stream-perror "error in Unix lseek() on ~S"
+ stream
+ errno)))))))
- (unless if-exists-given
- (setf if-exists
- (if (eq (pathname-version pathname) :newest)
- :new-version
- :error)))
- (ensure-one-of if-exists
- '(:error :new-version :rename
- :rename-and-delete :overwrite
- :append :supersede nil)
- :if-exists)
- (case if-exists
- ((:new-version :error nil)
- (setf mask (logior mask sb!unix:o_excl)))
- ((:rename :rename-and-delete)
- (setf mask (logior mask sb!unix:o_creat)))
- ((:supersede)
- (setf mask (logior mask sb!unix:o_trunc)))
- (:append
- (setf mask (logior mask sb!unix:o_append)))))
- (t
- (setf if-exists :ignore-this-arg)))
+ (unless if-exists-given
+ (setf if-exists
+ (if (eq (pathname-version pathname) :newest)
+ :new-version
+ :error)))
+ (ensure-one-of if-exists
+ '(:error :new-version :rename
+ :rename-and-delete :overwrite
+ :append :supersede nil)
+ :if-exists)
+ (case if-exists
+ ((:new-version :error nil)
+ (setf mask (logior mask sb!unix:o_excl)))
+ ((:rename :rename-and-delete)
+ (setf mask (logior mask sb!unix:o_creat)))
+ ((:supersede)
+ (setf mask (logior mask sb!unix:o_trunc)))
+ (:append
+ (setf mask (logior mask sb!unix:o_append)))))
+ (t
+ (setf if-exists :ignore-this-arg)))
- ((:rename :rename-and-delete)
- (pick-backup-name namestring))
- ((:append)
- ;; KLUDGE: Provent CLOSE from deleting
- ;; appending streams when called with :ABORT T
- namestring)))
- (delete-original (eq if-exists :rename-and-delete))
- (mode #o666))
- (when (and original (not (eq original namestring)))
- ;; We are doing a :RENAME or :RENAME-AND-DELETE. Determine
- ;; whether the file already exists, make sure the original
- ;; file is not a directory, and keep the mode.
- (let ((exists
- (and namestring
- (multiple-value-bind (okay err/dev inode orig-mode)
- (sb!unix:unix-stat namestring)
- (declare (ignore inode)
- (type (or index null) orig-mode))
- (cond
- (okay
- (when (and output (= (logand orig-mode #o170000)
- #o40000))
- (error 'simple-file-error
- :pathname namestring
- :format-control
- "can't open ~S for output: is a directory"
- :format-arguments (list namestring)))
- (setf mode (logand orig-mode #o777))
- t)
- ((eql err/dev sb!unix:enoent)
- nil)
- (t
- (simple-file-perror "can't find ~S"
- namestring
- err/dev)))))))
- (unless (and exists
- (rename-the-old-one namestring original))
- (setf original nil)
- (setf delete-original nil)
- ;; In order to use :SUPERSEDE instead, we have to make
- ;; sure SB!UNIX:O_CREAT corresponds to
- ;; IF-DOES-NOT-EXIST. SB!UNIX:O_CREAT was set before
- ;; because of IF-EXISTS being :RENAME.
- (unless (eq if-does-not-exist :create)
- (setf mask
- (logior (logandc2 mask sb!unix:o_creat)
- sb!unix:o_trunc)))
- (setf if-exists :supersede))))
-
- ;; Now we can try the actual Unix open(2).
- (multiple-value-bind (fd errno)
- (if namestring
- (sb!unix:unix-open namestring mask mode)
- (values nil sb!unix:enoent))
- (labels ((open-error (format-control &rest format-arguments)
- (error 'simple-file-error
- :pathname pathname
- :format-control format-control
- :format-arguments format-arguments))
- (vanilla-open-error ()
- (simple-file-perror "error opening ~S" pathname errno)))
- (cond ((numberp fd)
- (case direction
- ((:input :output :io)
- (make-fd-stream fd
- :input input
- :output output
- :element-type element-type
- :external-format external-format
- :file namestring
- :original original
- :delete-original delete-original
- :pathname pathname
- :input-buffer-p t
- :auto-close t))
- (:probe
- (let ((stream
- (%make-fd-stream :name namestring
- :fd fd
- :pathname pathname
- :element-type element-type)))
- (close stream)
- stream))))
- ((eql errno sb!unix:enoent)
- (case if-does-not-exist
- (:error (vanilla-open-error))
- (:create
- (open-error "~@<The path ~2I~_~S ~I~_does not exist.~:>"
- pathname))
- (t nil)))
- ((and (eql errno sb!unix:eexist) (null if-exists))
- nil)
- (t
- (vanilla-open-error)))))))))
+ ((:rename :rename-and-delete)
+ (pick-backup-name namestring))
+ ((:append :overwrite)
+ ;; KLUDGE: Provent CLOSE from deleting
+ ;; appending streams when called with :ABORT T
+ namestring)))
+ (delete-original (eq if-exists :rename-and-delete))
+ (mode #o666))
+ (when (and original (not (eq original namestring)))
+ ;; We are doing a :RENAME or :RENAME-AND-DELETE. Determine
+ ;; whether the file already exists, make sure the original
+ ;; file is not a directory, and keep the mode.
+ (let ((exists
+ (and namestring
+ (multiple-value-bind (okay err/dev inode orig-mode)
+ (sb!unix:unix-stat namestring)
+ (declare (ignore inode)
+ (type (or index null) orig-mode))
+ (cond
+ (okay
+ (when (and output (= (logand orig-mode #o170000)
+ #o40000))
+ (error 'simple-file-error
+ :pathname namestring
+ :format-control
+ "can't open ~S for output: is a directory"
+ :format-arguments (list namestring)))
+ (setf mode (logand orig-mode #o777))
+ t)
+ ((eql err/dev sb!unix:enoent)
+ nil)
+ (t
+ (simple-file-perror "can't find ~S"
+ namestring
+ err/dev)))))))
+ (unless (and exists
+ (rename-the-old-one namestring original))
+ (setf original nil)
+ (setf delete-original nil)
+ ;; In order to use :SUPERSEDE instead, we have to make
+ ;; sure SB!UNIX:O_CREAT corresponds to
+ ;; IF-DOES-NOT-EXIST. SB!UNIX:O_CREAT was set before
+ ;; because of IF-EXISTS being :RENAME.
+ (unless (eq if-does-not-exist :create)
+ (setf mask
+ (logior (logandc2 mask sb!unix:o_creat)
+ sb!unix:o_trunc)))
+ (setf if-exists :supersede))))
+
+ ;; Now we can try the actual Unix open(2).
+ (multiple-value-bind (fd errno)
+ (if namestring
+ (sb!unix:unix-open namestring mask mode)
+ (values nil sb!unix:enoent))
+ (labels ((open-error (format-control &rest format-arguments)
+ (error 'simple-file-error
+ :pathname pathname
+ :format-control format-control
+ :format-arguments format-arguments))
+ (vanilla-open-error ()
+ (simple-file-perror "error opening ~S" pathname errno)))
+ (cond ((numberp fd)
+ (case direction
+ ((:input :output :io)
+ (make-fd-stream fd
+ :input input
+ :output output
+ :element-type element-type
+ :external-format external-format
+ :file namestring
+ :original original
+ :delete-original delete-original
+ :pathname pathname
+ :dual-channel-p nil
+ :input-buffer-p t
+ :auto-close t))
+ (:probe
+ (let ((stream
+ (%make-fd-stream :name namestring
+ :fd fd
+ :pathname pathname
+ :element-type element-type)))
+ (close stream)
+ stream))))
+ ((eql errno sb!unix:enoent)
+ (case if-does-not-exist
+ (:error (vanilla-open-error))
+ (:create
+ (open-error "~@<The path ~2I~_~S ~I~_does not exist.~:>"
+ pathname))
+ (t nil)))
+ ((and (eql errno sb!unix:eexist) (null if-exists))
+ nil)
+ (t
+ (vanilla-open-error)))))))))
- (setf (fd-stream-pathname stream) new-name)
- (setf (fd-stream-file stream)
- (unix-namestring new-name nil))
- t)
- (t
- (fd-stream-pathname stream)))))
-\f
-;;;; international character support (which is trivial for our simple
-;;;; character sets)
-
-;;;; (Those who do Lisp only in English might not remember that ANSI
-;;;; requires these functions to be exported from package
-;;;; COMMON-LISP.)
-
-(defun file-string-length (stream object)
- (declare (type (or string character) object) (type fd-stream stream))
- #!+sb-doc
- "Return the delta in STREAM's FILE-POSITION that would be caused by writing
- OBJECT to STREAM. Non-trivial only in implementations that support
- international character sets."
- (declare (ignore stream))
- (etypecase object
- (character 1)
- (string (length object))))
-
-(defun stream-external-format (stream)
- (declare (type fd-stream stream))
- #!+sb-doc
- "Return the actual external format for fd-streams, otherwise :DEFAULT."
- (if (typep stream 'fd-stream)
- (fd-stream-external-format stream)
- :default))
+ (setf (fd-stream-pathname stream) new-name)
+ (setf (fd-stream-file stream)
+ (unix-namestring new-name nil))
+ t)
+ (t
+ (fd-stream-pathname stream)))))