(defvar *available-buffers* ()
#!+sb-doc
"List of available buffers. Each buffer is an sap pointing to
- bytes-per-buffer of memory.")
+bytes-per-buffer of memory.")
-#!+sb-thread
(defvar *available-buffers-mutex* (sb!thread:make-mutex
:name "lock for *AVAILABLE-BUFFERS*")
#!+sb-doc
"Mutex for access to *AVAILABLE-BUFFERS*.")
(defmacro with-available-buffers-lock ((&optional) &body body)
- ;; WITHOUT-INTERRUPTS because streams are low-level enough to be
+ ;; CALL-WITH-SYSTEM-MUTEX because streams are low-level enough to be
;; async signal safe, and in particular a C-c that brings up the
;; debugger while holding the mutex would lose badly
- `(without-interrupts
- (sb!thread:with-mutex (*available-buffers-mutex*)
- ,@body)))
+ `(sb!thread::call-with-system-mutex (lambda () ,@body)
+ *available-buffers-mutex*))
(defconstant bytes-per-buffer (* 4 1024)
#!+sb-doc
;; sources where input and output aren't related). non-NIL means
;; don't clear input buffer.
(dual-channel-p nil)
- ;; character position (if known)
- (char-pos nil :type (or index null))
+ ;; character position if known -- this may run into bignums, but
+ ;; we probably should flip it into null then for efficiency's sake...
+ (char-pos nil :type (or unsigned-byte null))
;; T if input is waiting on FD. :EOF if we hit EOF.
(listen nil :type (member nil t :eof))
;; output flushed, but not written due to non-blocking io?
(output-later nil)
(handler nil)
- ;; timeout specified for this stream, or NIL if none
- (timeout nil :type (or index null))
+ ;; timeout specified for this stream as seconds or NIL if none
+ (timeout nil :type (or single-float null))
;; pathname of the file this stream is opened to (returned by PATHNAME)
(pathname nil :type (or pathname null))
(external-format :default)
(defun external-format-encoding-error (stream code)
(if (streamp stream)
- (stream-encoding-error-and-handle stream code)
- (c-string-encoding-error stream code)))
+ (stream-encoding-error-and-handle stream code)
+ (c-string-encoding-error stream code)))
(defun external-format-decoding-error (stream octet-count)
(if (streamp stream)
- (stream-decoding-error stream octet-count)
- (c-string-decoding-error stream octet-count)))
+ (stream-decoding-error stream octet-count)
+ (c-string-decoding-error stream octet-count)))
;;; This is called by the server when we can write to the given file
;;; descriptor. Attempt to write the data again. If it worked, remove
start
length)
(cond ((not count)
- (if #!-win32 (= errno sb!unix:ewouldblock) #!+win32 t #!-win32
+ #!+win32
+ (simple-stream-perror "couldn't write to ~S" stream errno)
+ #!-win32
+ (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.
((not (null count)) ; sorta worked..
(push (list base
(the index (+ start count))
- end)
+ end
+ reuse-sap)
(fd-stream-output-later stream))))))
(unless (fd-stream-output-later stream)
- (sb!sys:remove-fd-handler (fd-stream-handler stream))
+ (remove-fd-handler (fd-stream-handler stream))
(setf (fd-stream-handler stream) nil)))
;;; Arange to output the string when we can write on the file descriptor.
(setf (fd-stream-output-later stream)
(list (list base start end reuse-sap)))
(setf (fd-stream-handler stream)
- (sb!sys:add-fd-handler (fd-stream-fd stream)
+ (add-fd-handler (fd-stream-fd stream)
:output
(lambda (fd)
(declare (ignore fd))
(type (or system-area-pointer (simple-array * (*))) base)
(type index start end))
(if (not (null (fd-stream-output-later stream))) ; something buffered.
- (progn
- (output-later stream base start end reuse-sap)
- ;; ### check to see whether any of this noise can be output
- )
+ (output-later stream base start end reuse-sap)
+ ;; ### check to see whether any of this noise can be output
(let ((length (- end start)))
(multiple-value-bind (count errno)
(sb!unix:unix-write (fd-stream-fd stream) base start length)
(cond ((not count)
- (if #!-win32 (= errno sb!unix:ewouldblock) #!+win32 t #!-win32
+ #!+win32
+ (simple-stream-perror "Couldn't write to ~S" stream errno)
+ #!-win32
+ (if (= errno sb!unix:ewouldblock)
(output-later stream base start end reuse-sap)
- (simple-stream-perror "couldn't write to ~S"
- stream
- errno)))
+ (simple-stream-perror "Couldn't write to ~S"
+ stream errno)))
((not (eql count length))
(output-later stream base (the index (+ start count))
end reuse-sap)))))))
(frob-output stream (fd-stream-obuf-sap stream) 0 length t)
(setf (fd-stream-obuf-tail stream) 0))))
+(defun fd-stream-output-finished-p (stream)
+ (and (zerop (fd-stream-obuf-tail stream))
+ (not (fd-stream-output-later stream))))
+
(defmacro output-wrapper/variable-width ((stream size buffering restart)
&body body)
(let ((stream-var (gensym)))
;;; unbuffered, slam the string down the file descriptor, otherwise
;;; use OUTPUT-RAW-BYTES to buffer the string. Update charpos by
;;; checking to see where the last newline was.
-;;;
-;;; Note: some bozos (the FASL dumper) call write-string with things
-;;; other than strings. Therefore, we must make sure we have a string
-;;; before calling POSITION on it.
-;;; KLUDGE: It would be better to fix the bozos instead of trying to
-;;; cover for them here. -- WHN 20000203
(defun fd-sout (stream thing start end)
+ (declare (type fd-stream stream) (type string thing))
(let ((start (or start 0))
(end (or end (length (the vector thing)))))
(declare (fixnum start end))
- (if (stringp thing)
- (let ((last-newline
- (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)
- (: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
+ (string-dispatch (simple-base-string
+ #!+sb-unicode
+ (simple-array character (*))
+ string)
+ thing
+ (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)
+ (: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))))))
(defvar *external-formats* ()
#!+sb-doc
stream
errno)))))
-;;; Fill the input buffer, and return the number of bytes read. Throw
-;;; to EOF-INPUT-CATCHER if the eof was reached. Drop into
-;;; SYSTEM:SERVER if necessary.
+;;; If the read would block wait (using SERVE-EVENT) till input is available,
+;;; then fill the input buffer, and return the number of bytes read. Throws
+;;; to EOF-INPUT-CATCHER if the eof was reached.
(defun refill-buffer/fd (stream)
(let ((fd (fd-stream-fd stream))
- (ibuf-sap (fd-stream-ibuf-sap stream))
- (buflen (fd-stream-ibuf-length stream))
- (head (fd-stream-ibuf-head stream))
- (tail (fd-stream-ibuf-tail stream)))
- (declare (type index head tail))
- (unless (zerop head)
- (cond ((eql head tail)
- (setf head 0)
- (setf tail 0)
- (setf (fd-stream-ibuf-head stream) 0)
- (setf (fd-stream-ibuf-tail stream) 0))
- (t
- (decf tail head)
- (system-area-ub8-copy ibuf-sap head
- ibuf-sap 0 tail)
- (setf head 0)
- (setf (fd-stream-ibuf-head stream) 0)
- (setf (fd-stream-ibuf-tail stream) tail))))
- (setf (fd-stream-listen stream) nil)
- ;;This isn't quite the same on win32. Then again, neither was
- ;;(not (sb!win32:fd-listen fd)), as was originally here. See
- ;;comment in `sysread-may-block-p'.
- (when (sysread-may-block-p stream)
- (unless (sb!sys:wait-until-fd-usable
- fd :input (fd-stream-timeout stream))
- (error 'io-timeout :stream stream :direction :read)))
- (multiple-value-bind (count errno)
- (sb!unix:unix-read fd
- (sb!sys:int-sap (+ (sb!sys:sap-int ibuf-sap) tail))
- (- buflen tail))
- (cond ((null count)
- (if #!-win32 (eql errno sb!unix:ewouldblock) #!+win32 t #!-win32
- (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)))))
+ (errno 0)
+ (count 0))
+ (tagbody
+ ;; Check for blocking input before touching the stream, as if
+ ;; we happen to wait we are liable to be interrupted, and the
+ ;; interrupt handler may use the same stream.
+ (if (sysread-may-block-p stream)
+ (go :wait-for-input)
+ (go :main))
+ ;; These (:CLOSED-FLAME and :READ-ERROR) tags are here so what
+ ;; we can signal errors outside the WITHOUT-INTERRUPTS.
+ :closed-flame
+ (closed-flame stream)
+ :read-error
+ (simple-stream-perror "couldn't read from ~S" stream errno)
+ :wait-for-input
+ ;; This tag is here so we can unwind outside the WITHOUT-INTERRUPTS
+ ;; to wait for input if read tells us EWOULDBLOCK.
+ (unless (wait-until-fd-usable fd :input (fd-stream-timeout stream))
+ (signal-timeout 'io-timeout :stream stream :direction :read
+ :seconds (fd-stream-timeout stream)))
+ :main
+ ;; Since the read should not block, we'll disable the
+ ;; interrupts here, so that we don't accidentally unwind and
+ ;; leave the stream in an inconsistent state.
+ (without-interrupts
+ (let ((ibuf-sap (fd-stream-ibuf-sap stream))
+ (buflen (fd-stream-ibuf-length stream))
+ (head (fd-stream-ibuf-head stream))
+ (tail (fd-stream-ibuf-tail stream)))
+ (declare (type index head tail))
+ ;; Check the SAP: if it is null, then someone has closed
+ ;; the stream from underneath us. This is not ment to fix
+ ;; multithreaded races, but to deal with interrupt handlers
+ ;; closing the stream.
+ (unless ibuf-sap
+ (go :closed-flame))
+ (unless (zerop head)
+ (cond ((eql head tail)
+ (setf head 0
+ tail 0
+ (fd-stream-ibuf-head stream) 0
+ (fd-stream-ibuf-tail stream) 0))
+ (t
+ (decf tail head)
+ (system-area-ub8-copy ibuf-sap head
+ ibuf-sap 0 tail)
+ (setf head 0
+ (fd-stream-ibuf-head stream) 0
+ (fd-stream-ibuf-tail stream) tail))))
+ (setf (fd-stream-listen stream) nil)
+ (setf (values count errno)
+ (sb!unix:unix-read fd (int-sap (+ (sap-int ibuf-sap) tail))
+ (- buflen tail)))
+ (cond ((null count)
+ #!+win32
+ (go :read-error)
+ #!-win32
+ (if (eql errno sb!unix:ewouldblock)
+ (go :wait-for-input)
+ (go :read-error)))
+ ((zerop count)
+ (setf (fd-stream-listen stream) :eof)
+ (/show0 "THROWing EOF-INPUT-CATCHER")
+ (throw 'eof-input-catcher nil))
+ (t
+ ;; Success!
+ (incf (fd-stream-ibuf-tail stream) count))))))
+ count))
;;; Make sure there are at least BYTES number of bytes in the input
;;; buffer. Keep calling REFILL-BUFFER/FD until that condition is met.
(in-char-function (symbolicate "INPUT-CHAR/" name))
(size-function (symbolicate "BYTES-FOR-CHAR/" name))
(read-c-string-function (symbolicate "READ-FROM-C-STRING/" name))
- (output-c-string-function (symbolicate "OUTPUT-TO-C-STRING/" name)))
+ (output-c-string-function (symbolicate "OUTPUT-TO-C-STRING/" name))
+ (n-buffer (gensym "BUFFER")))
`(progn
(defun ,size-function (byte)
(declare (ignore byte))
(setf (fd-stream-obuf-tail stream)
(string-dispatch (simple-base-string
#!+sb-unicode
- (simple-array character)
+ (simple-array character (*))
string)
string
(let ((len (fd-stream-obuf-length stream))
,out-expr))
(defun ,in-function (stream buffer start requested eof-error-p
&aux (index start) (end (+ start requested)))
- (declare (type fd-stream stream))
- (declare (type index start requested index end))
- (declare (type (simple-array character (#.+ansi-stream-in-buffer-length+)) buffer))
+ (declare (type fd-stream stream)
+ (type index start requested index end)
+ (type
+ (simple-array character (#.+ansi-stream-in-buffer-length+))
+ buffer))
(let ((unread (fd-stream-unread stream)))
(when unread
(setf (aref buffer index) unread)
(locally
(declare (optimize (speed 3) (safety 0)))
(let* ((stream ,name)
- (length (loop for head of-type index upfrom 0 by ,size
- for count of-type index upto (1- ARRAY-DIMENSION-LIMIT)
- for byte = (sap-ref-8 sap head)
- for char of-type character = ,in-expr
- until (zerop (char-code char))
- finally (return count)))
+ (length
+ (loop for head of-type index upfrom 0 by ,size
+ for count of-type index upto (1- array-dimension-limit)
+ for byte = (sap-ref-8 sap head)
+ for char of-type character = ,in-expr
+ until (zerop (char-code char))
+ finally (return count)))
+ ;; Inline the common cases
(string (make-string length :element-type element-type)))
(declare (ignorable stream)
(type index length)
- (type string string))
+ (type simple-string string))
(/show0 before-copy-loop)
(loop for head of-type index upfrom 0 by ,size
for index of-type index below length
(locally
(declare (optimize (speed 3) (safety 0)))
(let* ((length (length string))
- (buffer (make-array (* (1+ length) ,size) :element-type '(unsigned-byte 8)))
- (sap (sb!sys:vector-sap buffer))
+ (,n-buffer (make-array (* (1+ length) ,size)
+ :element-type '(unsigned-byte 8)))
(tail 0)
(stream ,name))
- (declare (type index length tail)
- (type system-area-pointer sap))
- (dotimes (i length)
- (let* ((byte (aref string i))
- (bits (char-code byte)))
- (declare (ignorable byte bits))
- ,out-expr)
- (incf tail ,size))
- (let* ((bits 0)
- (byte (code-char bits)))
- (declare (ignorable bits byte))
- ,out-expr)
- buffer)))
+ (declare (type index length tail))
+ (with-pinned-objects (,n-buffer)
+ (let ((sap (vector-sap ,n-buffer)))
+ (declare (system-area-pointer sap))
+ (dotimes (i length)
+ (let* ((byte (aref string i))
+ (bits (char-code byte)))
+ (declare (ignorable byte bits))
+ ,out-expr)
+ (incf tail ,size))
+ (let* ((bits 0)
+ (byte (code-char bits)))
+ (declare (ignorable bits byte))
+ ,out-expr)))
+ ,n-buffer)))
(setf *external-formats*
(cons '(,external-format ,in-function ,in-char-function ,out-function
,@(mapcar #'(lambda (buffering)
(resync-function (symbolicate "RESYNC/" name))
(size-function (symbolicate "BYTES-FOR-CHAR/" name))
(read-c-string-function (symbolicate "READ-FROM-C-STRING/" name))
- (output-c-string-function (symbolicate "OUTPUT-TO-C-STRING/" name)))
+ (output-c-string-function (symbolicate "OUTPUT-TO-C-STRING/" name))
+ (n-buffer (gensym "BUFFER")))
`(progn
(defun ,size-function (byte)
(declare (ignorable byte))
(setf (fd-stream-obuf-tail stream)
(string-dispatch (simple-base-string
#!+sb-unicode
- (simple-array character)
+ (simple-array character (*))
string)
string
(let ((len (fd-stream-obuf-length stream))
,out-expr))
(defun ,in-function (stream buffer start requested eof-error-p
&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))
+ (declare (type fd-stream stream)
+ (type index start requested total-copied)
+ (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 char-length length)
(the index ,out-size-expr)))))
(tail 0)
- (buffer (make-array buffer-length :element-type '(unsigned-byte 8)))
- (sap (sb!sys:vector-sap buffer))
+ (,n-buffer (make-array buffer-length
+ :element-type '(unsigned-byte 8)))
stream)
(declare (type index length buffer-length tail)
- (type system-area-pointer sap)
(type null stream)
(ignorable stream))
- (loop for i of-type index below length
- for byte of-type character = (aref string i)
- for bits = (char-code byte)
- for size of-type index = (aref char-length i)
- do (prog1
- ,out-expr
- (incf tail size)))
- (let* ((bits 0)
- (byte (code-char bits))
- (size (aref char-length length)))
- (declare (ignorable bits byte size))
- ,out-expr)
- buffer)))
+ (with-pinned-objects (,n-buffer)
+ (let ((sap (vector-sap ,n-buffer)))
+ (declare (system-area-pointer sap))
+ (loop for i of-type index below length
+ for byte of-type character = (aref string i)
+ for bits = (char-code byte)
+ for size of-type index = (aref char-length i)
+ do (prog1
+ ,out-expr
+ (incf tail size)))
+ (let* ((bits 0)
+ (byte (code-char bits))
+ (size (aref char-length length)))
+ (declare (ignorable bits byte size))
+ ,out-expr)))
+ ,n-buffer)))
(setf *external-formats*
(cons '(,external-format ,in-function ,in-char-function ,out-function
(:close
(cond (arg1 ; We got us an abort on our hands.
(when (fd-stream-handler fd-stream)
- (sb!sys:remove-fd-handler (fd-stream-handler fd-stream))
+ (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
(:force-output
(flush-output-buffer fd-stream))
(:finish-output
- (flush-output-buffer fd-stream)
- (do ()
- ((null (fd-stream-output-later fd-stream)))
- (sb!sys:serve-all-events)))
+ (finish-fd-stream-output fd-stream))
(:element-type
(fd-stream-element-type fd-stream))
(:external-format
(character (fd-stream-character-size fd-stream arg1))
(string (fd-stream-string-size fd-stream arg1))))
(:file-position
- (fd-stream-file-position fd-stream arg1))))
+ (if arg1
+ (fd-stream-set-file-position fd-stream arg1)
+ (fd-stream-get-file-position fd-stream)))))
+
+;; FIXME: Think about this.
+;;
+;; (defun finish-fd-stream-output (fd-stream)
+;; (let ((timeout (fd-stream-timeout fd-stream)))
+;; (loop while (fd-stream-output-later fd-stream)
+;; ;; FIXME: SIGINT while waiting for a timeout will
+;; ;; cause a timeout here.
+;; do (when (and (not (serve-event timeout)) timeout)
+;; (signal-timeout 'io-timeout
+;; :stream fd-stream
+;; :direction :write
+;; :seconds timeout)))))
+
+(defun finish-fd-stream-output (stream)
+ (flush-output-buffer stream)
+ (do ()
+ ((null (fd-stream-output-later stream)))
+ (serve-all-events)))
+
+(defun fd-stream-get-file-position (stream)
+ (declare (fd-stream stream))
+ (without-interrupts
+ (let ((posn (sb!unix:unix-lseek (fd-stream-fd stream) 0 sb!unix:l_incr)))
+ (declare (type (or (alien sb!unix:off-t) null) posn))
+ ;; We used to return NIL for errno==ESPIPE, and signal an error
+ ;; in other failure cases. However, CLHS says to return NIL if
+ ;; the position cannot be determined -- so that's what we do.
+ (when (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))))))
+
+(defun fd-stream-set-file-position (stream position-spec)
+ (declare (fd-stream stream))
+ (check-type position-spec
+ (or (alien sb!unix:off-t) (member nil :start :end))
+ "valid file position designator")
+ (tagbody
+ :again
+ ;; 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.
+ (finish-fd-stream-output stream)
+ ;; Disable interrupts so that interrupt handlers doing output
+ ;; won't screw us.
+ (without-interrupts
+ (unless (fd-stream-output-finished-p stream)
+ ;; We got interrupted and more output came our way during
+ ;; the interrupt. Wrapping the FINISH-FD-STREAM-OUTPUT in
+ ;; WITHOUT-INTERRUPTS gets nasty as it can signal errors,
+ ;; so we prefer to do things like this...
+ (go :again))
+ ;; Clear out any pending input to force the next read to go to
+ ;; the disk.
+ (setf (fd-stream-unread stream) nil
+ (fd-stream-ibuf-head stream) 0
+ (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.
+ (multiple-value-bind (offset origin)
+ (case position-spec
+ (:start
+ (values 0 sb!unix:l_set))
+ (:end
+ (values 0 sb!unix:l_xtnd))
+ (t
+ (values (* position-spec (fd-stream-element-size stream))
+ sb!unix:l_set)))
+ (declare (type (alien sb!unix:off-t) offset))
+ (let ((posn (sb!unix:unix-lseek (fd-stream-fd stream)
+ offset origin)))
+ ;; CLHS says to return true if the file-position was set
+ ;; succesfully, and NIL otherwise. We are to signal an error
+ ;; only if the given position was out of bounds, and that is
+ ;; dealt with above. In times past we used to return NIL for
+ ;; errno==ESPIPE, and signal an error in other cases.
+ ;;
+ ;; FIXME: We are still liable to signal an error if flushing
+ ;; output fails.
+ (return-from fd-stream-set-file-position
+ (typep posn '(alien sb!unix:off-t))))))))
-(defun fd-stream-file-position (stream &optional newpos)
- (declare (type fd-stream stream)
- (type (or (alien sb!unix:off-t) (member nil :start :end)) newpos))
- (if (null newpos)
- (sb!sys:without-interrupts
- ;; 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))))))
- (let ((offset 0) origin)
- (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)))))))
\f
;;;; creation routines (MAKE-FD-STREAM and OPEN)
(format nil "file ~A" file)
(format nil "descriptor ~W" fd)))
auto-close)
- (declare (type index fd) (type (or index null) timeout)
+ (declare (type index fd) (type (or real null) timeout)
(type (member :none :line :full) buffering))
(cond ((not (or input-p output-p))
(setf input t))
:buffering buffering
:dual-channel-p dual-channel-p
:external-format external-format
- :timeout timeout)))
+ :timeout
+ (if timeout
+ (coerce timeout 'single-float)
+ nil))))
(set-fd-stream-routines stream element-type external-format
input output input-buffer-p)
(when (and auto-close (fboundp 'finalize))