1.0.6.38: thread and interrupt safe ADD/REMOVE-METHOD

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

diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index 649e530..d87be01 100644 (file)
--- a/src/code/fd-stream.lisp
+++ b/src/code/fd-stream.lisp
@@ -18,21 +18,19 @@
 (defvar *available-buffers* ()
   #!+sb-doc
   "List of available buffers. Each buffer is an sap pointing to
 (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)
 (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
   ;; 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
 
 (defconstant bytes-per-buffer (* 4 1024)
   #!+sb-doc

@@ -98,8 +96,8 @@
   ;; output flushed, but not written due to non-blocking io?
   (output-later nil)
   (handler nil)
   ;; 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)
   ;; pathname of the file this stream is opened to (returned by PATHNAME)
   (pathname nil :type (or pathname null))
   (external-format :default)

@@ -182,13 +180,13 @@
 
 (defun external-format-encoding-error (stream code)
   (if (streamp stream)
 
 (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)
 
 (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
 
 ;;; 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

@@ -208,7 +206,10 @@
                             start
                             length)
       (cond ((not count)
                             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.
                  (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.

@@ -251,19 +252,19 @@
            (type (or system-area-pointer (simple-array * (*))) base)
            (type index start end))
   (if (not (null (fd-stream-output-later stream))) ; something buffered.
            (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)
       (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)
                      (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)))))))
                 ((not (eql count length))
                  (output-later stream base (the index (+ start count))
                                end reuse-sap)))))))

@@ -275,6 +276,10 @@
       (frob-output stream (fd-stream-obuf-sap stream) 0 length t)
       (setf (fd-stream-obuf-tail stream) 0))))
 
       (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)))
 (defmacro output-wrapper/variable-width ((stream size buffering restart)
                                          &body body)
   (let ((stream-var (gensym)))

@@ -531,59 +536,40 @@
 ;;; 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.
 ;;; 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)
 (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))
   (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
 
 (defvar *external-formats* ()
   #!+sb-doc

@@ -711,56 +697,80 @@
                              stream
                              errno)))))
 
                              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))
 (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 (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
-                           (int-sap (+ (sap-int ibuf-sap) tail))
-                           (- buflen tail))
-      (cond ((null count)
-             (if #!-win32 (eql errno sb!unix:ewouldblock) #!+win32 t #!-win32
-                 (progn
-                   (unless (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.
 
 ;;; Make sure there are at least BYTES number of bytes in the input
 ;;; buffer. Keep calling REFILL-BUFFER/FD until that condition is met.

@@ -1078,7 +1088,8 @@
          (in-char-function (symbolicate "INPUT-CHAR/" name))
          (size-function (symbolicate "BYTES-FOR-CHAR/" name))
          (read-c-string-function (symbolicate "READ-FROM-C-STRING/" name))
          (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))
     `(progn
       (defun ,size-function (byte)
         (declare (ignore byte))

@@ -1098,7 +1109,7 @@
             (setf (fd-stream-obuf-tail stream)
                   (string-dispatch (simple-base-string
                                     #!+sb-unicode
             (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))
                                     string)
                       string
                     (let ((len (fd-stream-obuf-length stream))

@@ -1142,9 +1153,11 @@
           ,out-expr))
       (defun ,in-function (stream buffer start requested eof-error-p
                            &aux (index start) (end (+ start requested)))
           ,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)
         (let ((unread (fd-stream-unread stream)))
           (when unread
             (setf (aref buffer index) unread)

@@ -1188,16 +1201,18 @@
         (locally
             (declare (optimize (speed 3) (safety 0)))
           (let* ((stream ,name)
         (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)
                  (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
             (/show0 before-copy-loop)
             (loop for head of-type index upfrom 0 by ,size
                for index of-type index below length

@@ -1210,8 +1225,14 @@
           (locally
               (declare (optimize (speed 3) (safety 0)))
             (let* ((length (length string))
           (locally
               (declare (optimize (speed 3) (safety 0)))
             (let* ((length (length string))

-                   (buffer (make-array (* (1+ length) ,size) :element-type '(unsigned-byte 8)))
-                   (sap (vector-sap buffer))
+                   (,n-buffer (make-array (* (1+ length) ,size)
+                                          :element-type '(unsigned-byte 8)))
+                   ;; This SAP-taking may seem unsafe without pinning,
+                   ;; but since the variable name is a gensym OUT-EXPR
+                   ;; cannot close over it even if it tried, so the buffer
+                   ;; will always be either in a register or on stack.
+                   ;; FIXME: But ...this is true on x86oids only!
+                   (sap (vector-sap ,n-buffer))

                    (tail 0)
                    (stream ,name))
               (declare (type index length tail)
                    (tail 0)
                    (stream ,name))
               (declare (type index length tail)

@@ -1226,7 +1247,7 @@
                      (byte (code-char bits)))
                 (declare (ignorable bits byte))
                 ,out-expr)
                      (byte (code-char bits)))
                 (declare (ignorable bits byte))
                 ,out-expr)

-              buffer)))
+              ,n-buffer)))

       (setf *external-formats*
        (cons '(,external-format ,in-function ,in-char-function ,out-function
                ,@(mapcar #'(lambda (buffering)
       (setf *external-formats*
        (cons '(,external-format ,in-function ,in-char-function ,out-function
                ,@(mapcar #'(lambda (buffering)

@@ -1247,7 +1268,8 @@
          (resync-function (symbolicate "RESYNC/" name))
          (size-function (symbolicate "BYTES-FOR-CHAR/" name))
          (read-c-string-function (symbolicate "READ-FROM-C-STRING/" name))
          (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))
     `(progn
       (defun ,size-function (byte)
         (declare (ignorable byte))

@@ -1267,7 +1289,7 @@
             (setf (fd-stream-obuf-tail stream)
                   (string-dispatch (simple-base-string
                                     #!+sb-unicode
             (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))
                                     string)
                       string
                     (let ((len (fd-stream-obuf-length stream))

@@ -1313,9 +1335,11 @@
           ,out-expr))
       (defun ,in-function (stream buffer start requested eof-error-p
                            &aux (total-copied 0))
           ,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)
         (let ((unread (fd-stream-unread stream)))
           (when unread
             (setf (aref buffer start) unread)

@@ -1453,26 +1477,32 @@
                        (setf (aref char-length length)
                              (the index ,out-size-expr)))))
                  (tail 0)
                        (setf (aref char-length length)
                              (the index ,out-size-expr)))))
                  (tail 0)

-                 (buffer (make-array buffer-length :element-type '(unsigned-byte 8)))
-                 (sap (vector-sap buffer))
+                 (,n-buffer (make-array buffer-length
+                                        :element-type '(unsigned-byte 8)))
+                 ;; This SAP-taking may seem unsafe without pinning,
+                 ;; but since the variable name is a gensym OUT-EXPR
+                 ;; cannot close over it even if it tried, so the buffer
+                 ;; will always be either in a register or on stack.
+                 ;; FIXME: But ...this is true on x86oids only!
+                 (sap (vector-sap ,n-buffer))

                  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
                  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)))
+                  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)
             (let* ((bits 0)
                    (byte (code-char bits))
                    (size (aref char-length length)))
               (declare (ignorable bits byte size))
               ,out-expr)

-            buffer)))
+            ,n-buffer)))

 
       (setf *external-formats*
        (cons '(,external-format ,in-function ,in-char-function ,out-function
 
       (setf *external-formats*
        (cons '(,external-format ,in-function ,in-char-function ,out-function

@@ -1903,7 +1933,6 @@
     (:force-output
      (flush-output-buffer fd-stream))
     (:finish-output
     (:force-output
      (flush-output-buffer fd-stream))
     (:finish-output

-     (flush-output-buffer fd-stream)

      (finish-fd-stream-output fd-stream))
     (:element-type
      (fd-stream-element-type fd-stream))
      (finish-fd-stream-output fd-stream))
     (:element-type
      (fd-stream-element-type fd-stream))

@@ -1942,84 +1971,109 @@
        (character (fd-stream-character-size fd-stream arg1))
        (string (fd-stream-string-size fd-stream arg1))))
     (:file-position
        (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)
 
 (defun finish-fd-stream-output (stream)

+  (flush-output-buffer stream)

   (do ()
       ((null (fd-stream-output-later stream)))
     (serve-all-events)))
 
   (do ()
       ((null (fd-stream-output-later stream)))
     (serve-all-events)))
 

-(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)
-      (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
-                 (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)
-        (finish-fd-stream-output stream)
-        ;; 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)))))))
+(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))))))))
+

 \f
 ;;;; creation routines (MAKE-FD-STREAM and OPEN)
 
 \f
 ;;;; creation routines (MAKE-FD-STREAM and OPEN)
 

@@ -2058,7 +2112,7 @@
                                  (format nil "file ~A" file)
                                  (format nil "descriptor ~W" fd)))
                        auto-close)
                                  (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))
            (type (member :none :line :full) buffering))
   (cond ((not (or input-p output-p))
          (setf input t))

@@ -2073,7 +2127,10 @@
                                  :buffering buffering
                                  :dual-channel-p dual-channel-p
                                  :external-format external-format
                                  :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))
     (set-fd-stream-routines stream element-type external-format
                             input output input-buffer-p)
     (when (and auto-close (fboundp 'finalize))