X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=311a4b990389bf74d9110527a352bf6beb440a95;hb=3f3033a6c0ddf0af8dd1b5a17c2a4b82ea59b94f;hp=5daab69d3e2b5c6354d1a7e51c6fe8106745d594;hpb=75476d1d19ac3d7239c8963a498c447a8368433d;p=sbcl.git

diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index 5daab69..311a4b9 100644
--- a/src/code/fd-stream.lisp
+++ b/src/code/fd-stream.lisp
@@ -52,25 +52,16 @@
   #!+sb-doc
   "List of available buffers.")
 
-(defvar *available-buffers-spinlock* (sb!thread::make-spinlock
-                                      :name "lock for *AVAILABLE-BUFFERS*")
+(defvar *available-buffers-lock* (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)
-  ;; CALL-WITH-SYSTEM-SPINLOCK because
-  ;;
-  ;; 1. 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
-  ;;
-  ;; 2. this can potentially be a fairly busy (but also probably
-  ;;    uncontended) lock, so we don't want to pay the syscall per
-  ;;    release -- hence a spinlock.
-  ;;
-  ;; ...again, once we have smarted locks the spinlock here can become
-  ;; a mutex.
-  `(sb!thread::with-system-spinlock (*available-buffers-spinlock*)
+  ;; 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.
+  `(sb!thread::with-system-mutex (*available-buffers-lock*)
      ,@body))
 
 (defconstant +bytes-per-buffer+ (* 4 1024)
@@ -157,6 +148,8 @@
   (element-type 'base-char)
   ;; the Unix file descriptor
   (fd -1 :type fixnum)
+  ;; What do we know about the FD?
+  (fd-type :unknown :type keyword)
   ;; controls when the output buffer is flushed
   (buffering :full :type (member :full :line :none))
   ;; controls whether the input buffer must be cleared before output
@@ -169,6 +162,8 @@
   (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))
+  ;; T if serve-event is allowed when this stream blocks
+  (serve-events nil :type boolean)
 
   ;; the input buffer
   (instead (make-array 0 :element-type 'character :adjustable t :fill-pointer t) :type (array character (*)))
@@ -185,7 +180,8 @@
   (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)
+  ;; Not :DEFAULT, because we want to match CHAR-SIZE!
+  (external-format :latin-1)
   ;; fixed width, or function to call with a character
   (char-size 1 :type (or fixnum function))
   (output-bytes #'ill-out :type function)
@@ -262,32 +258,45 @@
                (aver (< head tail))
                (%queue-and-replace-output-buffer stream))
               (t
-               ;; Try a non-blocking write, queue whatever is left over.
+               ;; Try a non-blocking write, if SERVE-EVENT is allowed, queue
+               ;; whatever is left over. Otherwise wait until we can write.
                (aver (< head tail))
                (synchronize-stream-output stream)
-               (let ((length (- tail head)))
-                 (multiple-value-bind (count errno)
-                     (sb!unix:unix-write (fd-stream-fd stream) (buffer-sap obuf)
-                                         head length)
-                   (cond ((eql count length)
-                          ;; Complete write -- we can use the same buffer.
-                          (reset-buffer obuf))
-                         (count
-                          ;; Partial write -- update buffer status and queue.
-                          ;; Do not use INCF! Another thread might have moved
-                          ;; head...
-                          (setf (buffer-head obuf) (+ count head))
-                          (%queue-and-replace-output-buffer stream))
-                         #!-win32
-                         ((eql errno sb!unix:ewouldblock)
-                          ;; Blocking, queue.
-                          (%queue-and-replace-output-buffer stream))
-                         (t
-                          (simple-stream-perror "Couldn't write to ~s"
-                                                stream errno)))))))))))
+               (loop
+                 (let ((length (- tail head)))
+                   (multiple-value-bind (count errno)
+                       (sb!unix:unix-write (fd-stream-fd stream) (buffer-sap obuf)
+                                           head length)
+                     (flet ((queue-or-wait ()
+                              (if (fd-stream-serve-events stream)
+                                  (return (%queue-and-replace-output-buffer stream))
+                                  (or (wait-until-fd-usable (fd-stream-fd stream) :output
+                                                            (fd-stream-timeout stream)
+                                                            nil)
+                                      (signal-timeout 'io-timeout
+                                                      :stream stream
+                                                      :direction :output
+                                                      :seconds (fd-stream-timeout stream))))))
+                        (cond ((eql count length)
+                               ;; Complete write -- we can use the same buffer.
+                               (return (reset-buffer obuf)))
+                              (count
+                               ;; Partial write -- update buffer status and
+                               ;; queue or wait.
+                               (incf head count)
+                               (setf (buffer-head obuf) head)
+                               (queue-or-wait))
+                              #!-win32
+                              ((eql errno sb!unix:ewouldblock)
+                               ;; Blocking, queue or wair.
+                               (queue-or-wait))
+                              (t
+                               (simple-stream-perror "Couldn't write to ~s"
+                                                     stream errno)))))))))))))
 
 ;;; Helper for FLUSH-OUTPUT-BUFFER -- returns the new buffer.
 (defun %queue-and-replace-output-buffer (stream)
+  (aver (fd-stream-serve-events stream))
   (let ((queue (fd-stream-output-queue stream))
         (later (list (or (fd-stream-obuf stream) (bug "Missing obuf."))))
         (new (get-buffer)))
@@ -312,6 +321,7 @@
 ;;; This is called by the FD-HANDLER for the stream when output is
 ;;; possible.
 (defun write-output-from-queue (stream)
+  (aver (fd-stream-serve-events stream))
   (synchronize-stream-output stream)
   (let (not-first-p)
     (tagbody
@@ -390,14 +400,10 @@
 ;;; this is not something we want to export. Nikodemus thinks the
 ;;; right thing is to support a low-level non-stream like IO layer,
 ;;; akin to java.nio.
-(defun output-raw-bytes (stream thing &optional start end)
+(declaim (inline output-raw-bytes))
+(define-deprecated-function :late "1.0.8.16" output-raw-bytes write-sequence
+    (stream thing &optional start end)
   (write-or-buffer-output stream thing (or start 0) (or end (length thing))))
-
-(define-compiler-macro output-raw-bytes (stream thing &optional start end)
-  (deprecation-warning 'output-raw-bytes)
-  (let ((x (gensym "THING")))
-    `(let ((,x ,thing))
-       (write-or-buffer-output ,stream ,x (or ,start 0) (or ,end (length ,x))))))
 
 ;;;; output routines and related noise
 
@@ -437,11 +443,10 @@
   (error 'c-string-encoding-error
          :external-format external-format
          :code code))
-
-(defun c-string-decoding-error (external-format octets)
+(defun c-string-decoding-error (external-format sap offset count)
   (error 'c-string-decoding-error
          :external-format external-format
-         :octets octets))
+         :octets (sap-ref-octets sap offset count)))
 
 ;;; Returning true goes into end of file handling, false will enter another
 ;;; round of input buffer filling followed by re-entering character decode.
@@ -505,11 +510,6 @@
       (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)))
-
 (defun synchronize-stream-output (stream)
   ;; If we're reading and writing on the same file, flush buffered
   ;; input and rewind file position accordingly.
@@ -730,7 +730,7 @@
              (position #\newline thing :from-end t
                        :start start :end end))))
       (if (and (typep thing 'base-string)
-               (eq (fd-stream-external-format stream) :latin-1))
+               (eq (fd-stream-external-format-keyword stream) :latin-1))
           (ecase (fd-stream-buffering stream)
             (:full
              (buffer-output stream thing start end))
@@ -755,28 +755,53 @@
              (:constructor %make-external-format)
              (:conc-name ef-)
              (:predicate external-format-p)
-             (:copier nil))
+             (:copier %copy-external-format))
   ;; All the names that can refer to this external format.  The first
   ;; one is the canonical name.
   (names (missing-arg) :type list :read-only t)
-  (read-n-chars-fun (missing-arg) :type function :read-only t)
-  (read-char-fun (missing-arg) :type function :read-only t)
-  (write-n-bytes-fun (missing-arg) :type function :read-only t)
-  (write-char-none-buffered-fun (missing-arg) :type function :read-only t)
-  (write-char-line-buffered-fun (missing-arg) :type function :read-only t)
-  (write-char-full-buffered-fun (missing-arg) :type function :read-only t)
+  (default-replacement-character (missing-arg) :type character)
+  (read-n-chars-fun (missing-arg) :type function)
+  (read-char-fun (missing-arg) :type function)
+  (write-n-bytes-fun (missing-arg) :type function)
+  (write-char-none-buffered-fun (missing-arg) :type function)
+  (write-char-line-buffered-fun (missing-arg) :type function)
+  (write-char-full-buffered-fun (missing-arg) :type function)
   ;; Can be nil for fixed-width formats.
-  (resync-fun nil :type (or function null) :read-only t)
-  (bytes-for-char-fun (missing-arg) :type function :read-only t)
-  (read-c-string-fun (missing-arg) :type function :read-only t)
-  (write-c-string-fun (missing-arg) :type function :read-only t)
-  ;; We make these symbols so that a developer working on the octets
-  ;; code can easily redefine things and use the new function definition
-  ;; without redefining the external format as well.  The slots above
-  ;; are functions because a developer working with those slots would be
+  (resync-fun nil :type (or function null))
+  (bytes-for-char-fun (missing-arg) :type function)
+  (read-c-string-fun (missing-arg) :type function)
+  (write-c-string-fun (missing-arg) :type function)
+  ;; We indirect through symbols in these functions so that a
+  ;; developer working on the octets code can easily redefine things
+  ;; and use the new function definition without redefining the
+  ;; external format as well.  The slots above don't do any
+  ;; indirection because a developer working with those slots would be
   ;; redefining the external format anyway.
-  (octets-to-string-sym (missing-arg) :type symbol :read-only t)
-  (string-to-octets-sym (missing-arg) :type symbol :read-only t))
+  (octets-to-string-fun (missing-arg) :type function)
+  (string-to-octets-fun (missing-arg) :type function))
+
+(defun ef-char-size (ef-entry)
+  (if (variable-width-external-format-p ef-entry)
+      (bytes-for-char-fun ef-entry)
+      (funcall (bytes-for-char-fun ef-entry) #\x)))
+
+(defun wrap-external-format-functions (external-format fun)
+  (let ((result (%copy-external-format external-format)))
+    (macrolet ((frob (accessor)
+                 `(setf (,accessor result) (funcall fun (,accessor result)))))
+      (frob ef-read-n-chars-fun)
+      (frob ef-read-char-fun)
+      (frob ef-write-n-bytes-fun)
+      (frob ef-write-char-none-buffered-fun)
+      (frob ef-write-char-line-buffered-fun)
+      (frob ef-write-char-full-buffered-fun)
+      (frob ef-resync-fun)
+      (frob ef-bytes-for-char-fun)
+      (frob ef-read-c-string-fun)
+      (frob ef-write-c-string-fun)
+      (frob ef-octets-to-string-fun)
+      (frob ef-string-to-octets-fun))
+    result))
 
 (defvar *external-formats* (make-hash-table)
   #!+sb-doc
@@ -784,28 +809,73 @@
   external-format names to EXTERNAL-FORMAT structures.")
 
 (defun get-external-format (external-format)
-  (gethash external-format *external-formats*))
+  (flet ((keyword-external-format (keyword)
+           (declare (type keyword keyword))
+           (gethash keyword *external-formats*))
+         (replacement-handlerify (entry replacement)
+           (when entry
+             (wrap-external-format-functions
+              entry
+              (lambda (fun)
+                (and fun
+                     (lambda (&rest rest)
+                       (declare (dynamic-extent rest))
+                       (handler-bind
+                           ((stream-decoding-error
+                             (lambda (c)
+                               (declare (ignore c))
+                               (invoke-restart 'input-replacement replacement)))
+                            (stream-encoding-error
+                             (lambda (c)
+                               (declare (ignore c))
+                               (invoke-restart 'output-replacement replacement)))
+                            (octets-encoding-error
+                             (lambda (c) (use-value replacement c)))
+                            (octet-decoding-error
+                             (lambda (c) (use-value replacement c))))
+                         (apply fun rest)))))))))
+    (typecase external-format
+      (keyword (keyword-external-format external-format))
+      ((cons keyword)
+       (let ((entry (keyword-external-format (car external-format)))
+             (replacement (getf (cdr external-format) :replacement)))
+         (if replacement
+             (replacement-handlerify entry replacement)
+             entry))))))
 
 (defun get-external-format-or-lose (external-format)
   (or (get-external-format external-format)
-      (error "Undefined external-format ~A" external-format)))
+      (error "Undefined external-format: ~S" external-format)))
+
+(defun external-format-keyword (external-format)
+  (typecase external-format
+    (keyword external-format)
+    ((cons keyword) (car external-format))))
+
+(defun fd-stream-external-format-keyword (stream)
+  (external-format-keyword (fd-stream-external-format stream)))
+
+(defun canonize-external-format (external-format entry)
+  (typecase external-format
+    (keyword (first (ef-names entry)))
+    ((cons keyword) (cons (first (ef-names entry)) (rest external-format)))))
 
 ;;; Find an output routine to use given the type and buffering. Return
 ;;; as multiple values the routine, the real type transfered, and the
 ;;; number of bytes per element.
 (defun pick-output-routine (type buffering &optional external-format)
   (when (subtypep type 'character)
-    (let ((entry (get-external-format external-format)))
-      (when entry
-        (return-from pick-output-routine
-          (values (ecase buffering
-                    (:none (ef-write-char-none-buffered-fun entry))
-                    (:line (ef-write-char-line-buffered-fun entry))
-                    (:full (ef-write-char-full-buffered-fun entry)))
-                  'character
-                  1
-                  (ef-write-n-bytes-fun entry)
-                  (first (ef-names entry)))))))
+    (let ((entry (get-external-format-or-lose external-format)))
+      (return-from pick-output-routine
+        (values (ecase buffering
+                  (:none (ef-write-char-none-buffered-fun entry))
+                  (:line (ef-write-char-line-buffered-fun entry))
+                  (:full (ef-write-char-full-buffered-fun entry)))
+                'character
+                1
+                (ef-write-n-bytes-fun entry)
+                (ef-char-size entry)
+                (canonize-external-format external-format entry)))))
   (dolist (entry *output-routines*)
     (when (and (subtypep type (first entry))
                (eq buffering (second entry))
@@ -881,20 +951,7 @@
   ;; This answers T at EOF on win32, I think.
   (not (sb!win32:fd-listen (fd-stream-fd stream)))
   #!-win32
-  (sb!unix:with-restarted-syscall (count errno)
-    (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 stream) read-fds)
-      (sb!unix:unix-fast-select (1+ (fd-stream-fd stream))
-                                (sb!alien:addr read-fds)
-                                nil nil 0 0))
-    (case count
-      ((1) nil)
-      ((0) t)
-      (otherwise
-       (simple-stream-perror "couldn't check whether ~S is readable"
-                             stream
-                             errno)))))
+  (not (sb!unix:unix-simple-poll (fd-stream-fd stream) :input 0)))
 
 ;;; 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
@@ -904,10 +961,11 @@
            (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)
+       ;; Check for blocking input before touching the stream if we are to
+       ;; serve events: if the FD is blocking, we don't want to try an uninterruptible
+       ;; read(). Regular files should never block, so we can elide the check.
+       (if (and (neq :regular (fd-stream-fd-type stream))
+                (sysread-may-block-p stream))
            (go :wait-for-input)
            (go :main))
        ;; These (:CLOSED-FLAME and :READ-ERROR) tags are here so what
@@ -919,8 +977,11 @@
      :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
+       (unless (wait-until-fd-usable fd :input (fd-stream-timeout stream)
+                                     (fd-stream-serve-events stream))
+         (signal-timeout 'io-timeout
+                         :stream stream
+                         :direction :input
                          :seconds (fd-stream-timeout stream)))
      :main
        ;; Since the read should not block, we'll disable the
@@ -931,7 +992,7 @@
        ;; resulting thunk is stack-allocatable.
        ((lambda (return-reason)
           (ecase return-reason
-            ((nil))             ; fast path normal cases
+            ((nil))                     ; fast path normal cases
             ((:wait-for-input) (go :wait-for-input))
             ((:closed-flame)   (go :closed-flame))
             ((:read-error)     (go :read-error))))
@@ -1027,12 +1088,15 @@
                      (catch 'eof-input-catcher
                        (setf decode-break-reason
                              (block decode-break-reason
-                               (input-at-least ,stream-var 1)
-                               (let* ((byte (sap-ref-8 (buffer-sap ibuf)
-                                                       (buffer-head ibuf))))
+                               (input-at-least ,stream-var ,(if (consp bytes) (car bytes) `(setq size ,bytes)))
+                               (let* ((byte (sap-ref-8 (buffer-sap ibuf) (buffer-head ibuf))))
                                  (declare (ignorable byte))
-                                 (setq size ,bytes)
-                                 (input-at-least ,stream-var size)
+                                 ,@(when (consp bytes)
+                                     `((let ((sap (buffer-sap ibuf))
+                                             (head (buffer-head ibuf)))
+                                         (declare (ignorable sap head))
+                                         (setq size ,(cadr bytes))
+                                         (input-at-least ,stream-var size))))
                                  (setq ,element-var (locally ,@read-forms))
                                  (setq ,retry-var nil))
                                nil))
@@ -1149,14 +1213,14 @@
 ;;; bytes per element (and for character types string input routine).
 (defun pick-input-routine (type &optional external-format)
   (when (subtypep type 'character)
-    (let ((entry (get-external-format external-format)))
-      (when entry
-        (return-from pick-input-routine
-          (values (ef-read-char-fun entry)
-                  'character
-                  1
-                  (ef-read-n-chars-fun entry)
-                  (first (ef-names entry)))))))
+    (let ((entry (get-external-format-or-lose external-format)))
+      (return-from pick-input-routine
+        (values (ef-read-char-fun entry)
+                'character
+                1
+                (ef-read-n-chars-fun entry)
+                (ef-char-size entry)
+                (canonize-external-format external-format entry)))))
   (dolist (entry *input-routines*)
     (when (and (subtypep type (first entry))
                (or (not (fourth entry))
@@ -1272,198 +1336,73 @@
 (defun bytes-for-char-fun (ef-entry)
   (if ef-entry (ef-bytes-for-char-fun ef-entry) (constantly 1)))
 
-(defmacro define-external-format (external-format size output-restart
-                                  out-expr in-expr
-                                  octets-to-string-sym
-                                  string-to-octets-sym)
-  (let* ((name (first external-format))
-         (out-function (symbolicate "OUTPUT-BYTES/" name))
-         (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" (string name)))
-         (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" 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))
-         (n-buffer (gensym "BUFFER")))
+(defmacro define-unibyte-mapping-external-format
+    (canonical-name (&rest other-names) &body exceptions)
+  (let ((->code-name (symbolicate canonical-name '->code-mapper))
+        (code->-name (symbolicate 'code-> canonical-name '-mapper))
+        (get-bytes-name (symbolicate 'get- canonical-name '-bytes))
+        (string->-name (symbolicate 'string-> canonical-name))
+        (define-string*-name (symbolicate 'define- canonical-name '->string*))
+        (string*-name (symbolicate canonical-name '->string*))
+        (define-string-name (symbolicate 'define- canonical-name '->string))
+        (string-name (symbolicate canonical-name '->string))
+        (->string-aref-name (symbolicate canonical-name '->string-aref)))
     `(progn
-      (defun ,size-function (byte)
-        (declare (ignore byte))
-        ,size)
-      (defun ,out-function (stream string flush-p start end)
-        (let ((start (or start 0))
-              (end (or end (length string))))
-          (declare (type index start end))
-          (synchronize-stream-output stream)
-          (unless (<= 0 start end (length string))
-            (sequence-bounding-indices-bad-error string start end))
-          (do ()
-              ((= end start))
-            (let ((obuf (fd-stream-obuf stream)))
-              (string-dispatch (simple-base-string
-                                #!+sb-unicode
-                                (simple-array character (*))
-                                string)
-                  string
-                (let ((sap (buffer-sap obuf))
-                      (len (buffer-length obuf))
-                      ;; FIXME: rename
-                      (tail (buffer-tail obuf)))
-                  (declare (type index tail)
-                           ;; STRING bounds have already been checked.
-                           (optimize (safety 0)))
-                  (,@(if output-restart
-                         `(catch 'output-nothing)
-                         `(progn))
-                     (do* ()
-                          ((or (= start end) (< (- len tail) 4)))
-                       (let* ((byte (aref string start))
-                              (bits (char-code byte)))
-                         ,out-expr
-                         (incf tail ,size)
-                         (setf (buffer-tail obuf) tail)
-                         (incf start)))
-                     ;; Exited from the loop normally
-                     (go flush))
-                  ;; Exited via CATCH. Skip the current character.
-                  (incf start))))
-           flush
-            (when (< start end)
-              (flush-output-buffer stream)))
-          (when flush-p
-            (flush-output-buffer stream))))
-      (def-output-routines (,format
-                            ,size
-                            ,output-restart
-                            (:none character)
-                            (:line character)
-                            (:full character))
-          (if (eql byte #\Newline)
-              (setf (fd-stream-char-pos stream) 0)
-              (incf (fd-stream-char-pos stream)))
-          (let* ((obuf (fd-stream-obuf stream))
-                 (bits (char-code byte))
-                 (sap (buffer-sap obuf))
-                 (tail (buffer-tail obuf)))
-            ,out-expr))
-      (defun ,in-function (stream buffer start requested eof-error-p
-                           &aux (index start) (end (+ start requested)))
-        (declare (type fd-stream stream)
-                 (type index start requested index end)
-                 (type
-                  (simple-array character (#.+ansi-stream-in-buffer-length+))
-                  buffer))
-        (when (fd-stream-eof-forced-p stream)
-          (setf (fd-stream-eof-forced-p stream) nil)
-          (return-from ,in-function 0))
-        (do ((instead (fd-stream-instead stream)))
-            ((= (fill-pointer instead) 0)
-             (setf (fd-stream-listen stream) nil))
-          (setf (aref buffer index) (vector-pop instead))
-          (incf index)
-          (when (= index end)
-            (return-from ,in-function (- index start))))
-        (do ()
-            (nil)
-          (let* ((ibuf (fd-stream-ibuf stream))
-                 (head (buffer-head ibuf))
-                 (tail (buffer-tail ibuf))
-                 (sap (buffer-sap ibuf)))
-            (declare (type index head tail)
-                     (type system-area-pointer sap))
-            ;; Copy data from stream buffer into user's buffer.
-            (dotimes (i (min (truncate (- tail head) ,size)
-                             (- end index)))
-              (declare (optimize speed))
-              (let* ((byte (sap-ref-8 sap head)))
-                (setf (aref buffer index) ,in-expr)
-                (incf index)
-                (incf head ,size)))
-            (setf (buffer-head ibuf) head)
-            ;; Maybe we need to refill the stream buffer.
-            (cond ( ;; If there was enough data in the stream buffer, we're done.
-                   (= index end)
-                   (return (- index start)))
-                  ( ;; If EOF, we're done in another way.
-                   (null (catch 'eof-input-catcher (refill-input-buffer stream)))
-                   (if eof-error-p
-                       (error 'end-of-file :stream stream)
-                       (return (- index start))))
-                  ;; Otherwise we refilled the stream buffer, so fall
-                  ;; through into another pass of the loop.
-                  ))))
-      (def-input-routine ,in-char-function (character ,size sap head)
-        (let ((byte (sap-ref-8 sap head)))
-          ,in-expr))
-      (defun ,read-c-string-function (sap element-type)
-        (declare (type system-area-pointer sap)
-                 (type (member character base-char) element-type))
-        (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)))
-                 ;; Inline the common cases
-                 (string (make-string length :element-type element-type)))
-            (declare (ignorable stream)
-                     (type index length)
-                     (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
-               for byte = (sap-ref-8 sap head)
-               for char of-type character = ,in-expr
-               do (setf (aref string index) char))
-            string))) ;; last loop rewrite to dotimes?
-        (defun ,output-c-string-function (string)
-          (declare (type simple-string string))
-          (locally
-              (declare (optimize (speed 3) (safety 0)))
-            (let* ((length (length string))
-                   (,n-buffer (make-array (* (1+ length) ,size)
-                                          :element-type '(unsigned-byte 8)))
-                   (tail 0)
-                   (stream ,name))
-              (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)))
-        (let ((entry (%make-external-format
-                      :names ',external-format
-                      :read-n-chars-fun #',in-function
-                      :read-char-fun #',in-char-function
-                      :write-n-bytes-fun #',out-function
-                      ,@(mapcan #'(lambda (buffering)
-                                    (list (intern (format nil "WRITE-CHAR-~A-BUFFERED-FUN" buffering) :keyword)
-                                          `#',(intern (format nil format (string buffering)))))
-                                '(:none :line :full))
-                      :resync-fun nil
-                      :bytes-for-char-fun #',size-function
-                      :read-c-string-fun #',read-c-string-function
-                      :write-c-string-fun #',output-c-string-function
-                      :octets-to-string-sym ',octets-to-string-sym
-                      :string-to-octets-sym ',string-to-octets-sym)))
-          (dolist (ef ',external-format)
-            (setf (gethash ef *external-formats*) entry))))))
+       (define-unibyte-mapper ,->code-name ,code->-name
+         ,@exceptions)
+       (declaim (inline ,get-bytes-name))
+       (defun ,get-bytes-name (string pos)
+         (declare (optimize speed (safety 0))
+                  (type simple-string string)
+                  (type array-range pos))
+         (get-latin-bytes #',code->-name ,canonical-name string pos))
+       (defun ,string->-name (string sstart send null-padding)
+         (declare (optimize speed (safety 0))
+                  (type simple-string string)
+                  (type array-range sstart send))
+         (values (string->latin% string sstart send #',get-bytes-name null-padding)))
+       (defmacro ,define-string*-name (accessor type)
+         (declare (ignore type))
+         (let ((name (make-od-name ',string*-name accessor)))
+           `(progn
+              (defun ,name (string sstart send array astart aend)
+                (,(make-od-name 'latin->string* accessor)
+                  string sstart send array astart aend #',',->code-name)))))
+       (instantiate-octets-definition ,define-string*-name)
+       (defmacro ,define-string-name (accessor type)
+         (declare (ignore type))
+         (let ((name (make-od-name ',string-name accessor)))
+           `(progn
+              (defun ,name (array astart aend)
+                (,(make-od-name 'latin->string accessor)
+                  array astart aend #',',->code-name)))))
+       (instantiate-octets-definition ,define-string-name)
+       (define-unibyte-external-format ,canonical-name ,other-names
+         (let ((octet (,code->-name bits)))
+           (if octet
+               (setf (sap-ref-8 sap tail) octet)
+               (external-format-encoding-error stream bits)))
+         (let ((code (,->code-name byte)))
+           (if code
+               (code-char code)
+               (return-from decode-break-reason 1)))
+         ,->string-aref-name
+         ,string->-name))))
+
+(defmacro define-unibyte-external-format
+    (canonical-name (&rest other-names)
+     out-form in-form octets-to-string-symbol string-to-octets-symbol)
+  `(define-external-format/variable-width (,canonical-name ,@other-names)
+     t #\? 1
+     ,out-form
+     1
+     ,in-form
+     ,octets-to-string-symbol
+     ,string-to-octets-symbol))
 
 (defmacro define-external-format/variable-width
-    (external-format output-restart out-size-expr
-     out-expr in-size-expr in-expr
+    (external-format output-restart replacement-character
+     out-size-expr out-expr in-size-expr in-expr
      octets-to-string-sym string-to-octets-sym)
   (let* ((name (first external-format))
          (out-function (symbolicate "OUTPUT-BYTES/" name))
@@ -1550,6 +1489,8 @@
           (setf (aref buffer (+ start total-copied)) (vector-pop instead))
           (incf total-copied)
           (when (= requested total-copied)
+            (when (= (fill-pointer instead) 0)
+              (setf (fd-stream-listen stream) nil))
             (return-from ,in-function total-copied)))
         (do ()
             (nil)
@@ -1564,9 +1505,12 @@
                 ((or (= tail head) (= requested total-copied)))
               (setf decode-break-reason
                     (block decode-break-reason
+                      ,@(when (consp in-size-expr)
+                          `((when (> ,(car in-size-expr) (- tail head))
+                              (return))))
                       (let ((byte (sap-ref-8 sap head)))
                         (declare (ignorable byte))
-                        (setq size ,in-size-expr)
+                        (setq size ,(if (consp in-size-expr) (cadr in-size-expr) in-size-expr))
                         (when (> size (- tail head))
                           (return))
                         (setf (aref buffer (+ start total-copied)) ,in-expr)
@@ -1594,8 +1538,8 @@
                 (return-from ,in-function total-copied)))
             (setf (buffer-head ibuf) 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)
+            (cond ( ;; If was data in the stream buffer, we're done.
+                   (plusp total-copied)
                    (return total-copied))
                   ( ;; If EOF, we're done in another way.
                    (or (eq decode-break-reason 'eof)
@@ -1615,18 +1559,20 @@
           (declare (ignorable byte))
           ,in-expr))
       (defun ,resync-function (stream)
-        (let ((ibuf (fd-stream-ibuf stream)))
+        (let ((ibuf (fd-stream-ibuf stream))
+              size)
           (catch 'eof-input-catcher
             (loop
                (incf (buffer-head ibuf))
-               (input-at-least stream 1)
+               (input-at-least stream ,(if (consp in-size-expr) (car in-size-expr) `(setq size ,in-size-expr)))
                (unless (block decode-break-reason
                          (let* ((sap (buffer-sap ibuf))
                                 (head (buffer-head ibuf))
-                                (byte (sap-ref-8 sap head))
-                                (size ,in-size-expr))
+                                (byte (sap-ref-8 sap head)))
                            (declare (ignorable byte))
-                           (input-at-least stream size)
+                           ,@(when (consp in-size-expr)
+                               `((setq size ,(cadr in-size-expr))
+                                 (input-at-least stream size)))
                            (setf head (buffer-head ibuf))
                            ,in-expr)
                          nil)
@@ -1642,12 +1588,13 @@
                            (setf decode-break-reason
                                  (block decode-break-reason
                                    (setf byte (sap-ref-8 sap head)
-                                         size ,in-size-expr
+                                         size ,(if (consp in-size-expr) (cadr in-size-expr) in-size-expr)
                                          char ,in-expr)
                                    (incf head size)
                                    nil))
                            (when decode-break-reason
-                             (c-string-decoding-error ,name decode-break-reason))
+                             (c-string-decoding-error
+                              ,name sap head decode-break-reason))
                            (when (zerop (char-code char))
                              (return count))))
                  (string (make-string length :element-type element-type)))
@@ -1661,12 +1608,13 @@
               (setf decode-break-reason
                     (block decode-break-reason
                       (setf byte (sap-ref-8 sap head)
-                            size ,in-size-expr
+                            size ,(if (consp in-size-expr) (cadr in-size-expr) in-size-expr)
                             char ,in-expr)
                       (incf head size)
                       nil))
               (when decode-break-reason
-                (c-string-decoding-error ,name decode-break-reason))
+                (c-string-decoding-error
+                 ,name sap head decode-break-reason))
               (setf (aref string index) char)))))
 
       (defun ,output-c-string-function (string)
@@ -1712,6 +1660,7 @@
 
       (let ((entry (%make-external-format
                     :names ',external-format
+                    :default-replacement-character ,replacement-character
                     :read-n-chars-fun #',in-function
                     :read-char-fun #',in-char-function
                     :write-n-bytes-fun #',out-function
@@ -1723,8 +1672,12 @@
                     :bytes-for-char-fun #',size-function
                     :read-c-string-fun #',read-c-string-function
                     :write-c-string-fun #',output-c-string-function
-                    :octets-to-string-sym ',octets-to-string-sym
-                    :string-to-octets-sym ',string-to-octets-sym)))
+                    :octets-to-string-fun (lambda (&rest rest)
+                                            (declare (dynamic-extent rest))
+                                            (apply ',octets-to-string-sym rest))
+                    :string-to-octets-fun (lambda (&rest rest)
+                                            (declare (dynamic-extent rest))
+                                            (apply ',string-to-octets-sym rest)))))
         (dolist (ef ',external-format)
           (setf (gethash ef *external-formats*) entry))))))
 
@@ -1743,6 +1696,7 @@
          (character-stream-p (subtypep target-type 'character))
          (bivalent-stream-p (eq element-type :default))
          normalized-external-format
+         char-size
          (bin-routine #'ill-bin)
          (bin-type nil)
          (bin-size nil)
@@ -1786,24 +1740,23 @@
     (when output-p
       (setf (fd-stream-char-pos fd-stream) 0))
 
-    (when (and character-stream-p
-               (eq external-format :default))
+    (when (and character-stream-p (eq external-format :default))
       (/show0 "/getting default external format")
       (setf external-format (default-external-format)))
 
     (when input-p
       (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))
+        (setf (values bin-routine bin-type bin-size read-n-characters
+                      char-size 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))
+        (setf (values cin-routine cin-type cin-size read-n-characters
+                      char-size 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
@@ -1812,8 +1765,8 @@
       (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))
+        (setf (fd-stream-external-format fd-stream) normalized-external-format
+              (fd-stream-char-size fd-stream) char-size))
       (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))
@@ -1840,30 +1793,33 @@
 
     (when output-p
       (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))
+        (setf (values bout-routine bout-type bout-size output-bytes
+                      char-size normalized-external-format)
+              (let ((buffering (fd-stream-buffering fd-stream)))
+                (if bivalent-stream-p
+                    (pick-output-routine '(unsigned-byte 8)
+                                         (if (eq :line buffering)
+                                             :full
+                                             buffering)
+                                         external-format)
+                    (pick-output-routine target-type buffering 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))
+        (setf (values cout-routine cout-type cout-size output-bytes
+                      char-size 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))
+        (setf (fd-stream-external-format fd-stream) normalized-external-format
+              (fd-stream-char-size fd-stream) char-size))
       (when character-stream-p
         (setf (fd-stream-output-bytes fd-stream) output-bytes))
       (setf (fd-stream-out fd-stream) cout-routine
@@ -1985,8 +1941,7 @@
        (do-listen)))
     (:unread
      (decf (buffer-head (fd-stream-ibuf fd-stream))
-           (fd-stream-character-size fd-stream arg1))
-     (setf (fd-stream-listen fd-stream) t))
+           (fd-stream-character-size fd-stream arg1)))
     (:close
      ;; Drop input buffers
      (setf (ansi-stream-in-index fd-stream) +ansi-stream-in-buffer-length+
@@ -2123,6 +2078,7 @@
   (flush-output-buffer stream)
   (do ()
       ((null (fd-stream-output-queue stream)))
+    (aver (fd-stream-serve-events stream))
     (serve-all-events)))
 
 (defun fd-stream-get-file-position (stream)
@@ -2224,6 +2180,9 @@
 ;;; FILE is the name of the file (will be returned by PATHNAME).
 ;;;
 ;;; NAME is used to identify the stream when printed.
+;;;
+;;; If SERVE-EVENTS is true, SERVE-EVENT machinery is used to
+;;; handle blocking IO on the stream.
 (defun make-fd-stream (fd
                        &key
                        (input nil input-p)
@@ -2231,6 +2190,7 @@
                        (element-type 'base-char)
                        (buffering :full)
                        (external-format :default)
+                       serve-events
                        timeout
                        file
                        original
@@ -2249,6 +2209,12 @@
         ((not (or input output))
          (error "File descriptor must be opened either for input or output.")))
   (let ((stream (%make-fd-stream :fd fd
+                                 :fd-type (progn
+                                            #!-win32 (sb!unix:fd-type fd)
+                                            ;; KLUDGE.
+                                            #!+win32 (if serve-events
+                                                         :unknown
+                                                         :regular))
                                  :name name
                                  :file file
                                  :original original
@@ -2256,9 +2222,8 @@
                                  :pathname pathname
                                  :buffering buffering
                                  :dual-channel-p dual-channel-p
-                                 :external-format external-format
                                  :bivalent-p (eq element-type :default)
-                                 :char-size (external-format-char-size external-format)
+                                 :serve-events serve-events
                                  :timeout
                                  (if timeout
                                      (coerce timeout 'single-float)
@@ -2451,6 +2416,10 @@
             (cond ((numberp fd)
                    (case direction
                      ((:input :output :io)
+                      ;; For O_APPEND opened files, lseek returns 0 until first write.
+                      ;; So we jump ahead here.
+                      (when (eq if-exists :append)
+                        (sb!unix:unix-lseek fd 0 sb!unix:l_xtnd))
                       (make-fd-stream fd
                                       :input input
                                       :output output
@@ -2461,6 +2430,7 @@
                                       :delete-original delete-original
                                       :pathname pathname
                                       :dual-channel-p nil
+                                      :serve-events nil
                                       :input-buffer-p t
                                       :auto-close t))
                      (:probe
@@ -2517,6 +2487,14 @@
     (without-package-locks
         (makunbound '*available-buffers*))))
 
+(defun stdstream-external-format (outputp)
+  (declare (ignorable outputp))
+  (let* ((keyword #!+win32 (if outputp (sb!win32::console-output-codepage) (sb!win32::console-input-codepage))
+                  #!-win32 (default-external-format))
+         (ef (get-external-format keyword))
+         (replacement (ef-default-replacement-character ef)))
+    `(,keyword :replacement ,replacement)))
+
 ;;; This is called whenever a saved core is restarted.
 (defun stream-reinit (&optional init-buffers-p)
   (when init-buffers-p
@@ -2526,22 +2504,25 @@
   (with-output-to-string (*error-output*)
     (setf *stdin*
           (make-fd-stream 0 :name "standard input" :input t :buffering :line
-                            #!+win32 :external-format #!+win32 (sb!win32::console-input-codepage)))
+                          :element-type :default
+                          :serve-events t
+                          :external-format (stdstream-external-format nil)))
     (setf *stdout*
           (make-fd-stream 1 :name "standard output" :output t :buffering :line
-                            #!+win32 :external-format #!+win32 (sb!win32::console-output-codepage)))
+                          :element-type :default
+                          :external-format (stdstream-external-format t)))
     (setf *stderr*
           (make-fd-stream 2 :name "standard error" :output t :buffering :line
-                            #!+win32 :external-format #!+win32 (sb!win32::console-output-codepage)))
+                          :element-type :default
+                          :external-format (stdstream-external-format t)))
     (let* ((ttyname #.(coerce "/dev/tty" 'simple-base-string))
            (tty (sb!unix:unix-open ttyname sb!unix:o_rdwr #o666)))
       (if tty
           (setf *tty*
-                (make-fd-stream tty
-                                :name "the terminal"
-                                :input t
-                                :output t
-                                :buffering :line
+                (make-fd-stream tty :name "the terminal"
+                                :input t :output t :buffering :line
+                                :external-format (stdstream-external-format t)
+                                :serve-events t
                                 :auto-close t))
           (setf *tty* (make-two-way-stream *stdin* *stdout*))))
     (princ (get-output-stream-string *error-output*) *stderr*))