X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=ea3e1166fd570573633782422a1790d53223d22a;hb=77d1a39f28fe8d240cf441a9a54a80d4bc98ea52;hp=4b6f09d19b42a70ca9f9907b3cef9fde9f65942a;hpb=e37366e7bb72bc80c6c9908efe09f94ce26add16;p=sbcl.git

diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index 4b6f09d..ea3e116 100644
--- a/src/code/fd-stream.lisp
+++ b/src/code/fd-stream.lisp
@@ -11,14 +11,6 @@
 
 (in-package "SB!IMPL")
 
-;;; FIXME: Wouldn't it be clearer to just have the structure
-;;; definition be DEFSTRUCT FILE-STREAM (instead of DEFSTRUCT
-;;; FD-STREAM)? That way we'd have TYPE-OF and PRINT-OBJECT refer to
-;;; these objects as FILE-STREAMs (the ANSI name) instead of the
-;;; internal implementation name FD-STREAM, and there might be other
-;;; benefits as well.
-(deftype file-stream () 'fd-stream)
-
 ;;;; buffer manipulation routines
 
 ;;; FIXME: Is it really good to maintain this pool separate from the
@@ -43,7 +35,9 @@
 
 (defstruct (fd-stream
 	    (:constructor %make-fd-stream)
-	    (:include lisp-stream
+	    (:conc-name fd-stream-)
+	    (:predicate fd-stream-p)
+	    (:include ansi-stream
 		      (misc #'fd-stream-misc-routine))
 	    (:copier nil))
 
@@ -86,7 +80,9 @@
   ;; timeout specified for this stream, or NIL if none
   (timeout nil :type (or index null))
   ;; pathname of the file this stream is opened to (returned by PATHNAME)
-  (pathname nil :type (or pathname null)))
+  (pathname nil :type (or pathname null))
+  (external-format :default)
+  (output-bytes #'ill-out :type function))
 (def!method print-object ((fd-stream fd-stream) stream)
   (declare (type stream stream))
   (print-unreadable-object (fd-stream stream :type t :identity t)
@@ -107,17 +103,28 @@
 	 :format-control "~@<~?: ~2I~_~A~:>"
 	 :format-arguments (list note-format (list stream) (strerror errno))))
 (defun simple-file-perror (note-format pathname errno)
-  (error 'simple-stream-error
+  (error 'simple-file-error
 	 :pathname pathname
 	 :format-control "~@<~?: ~2I~_~A~:>"
 	 :format-arguments
 	 (list note-format (list pathname) (strerror errno))))
 
+(defun stream-decoding-error (stream octets)
+  (error 'stream-decoding-error
+	 :stream stream
+         ;; FIXME: dunno how to get at OCTETS currently, or even if
+         ;; that's the right thing to report.
+         :octets octets))
+(defun stream-encoding-error (stream code)
+  (error 'stream-encoding-error
+	 :stream stream
+         :code code))
+
 ;;; 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
 ;;; the data from the OUTPUT-LATER list. If it didn't work, something
 ;;; is wrong.
-(defun do-output-later (stream)
+(defun frob-output-later (stream)
   (let* ((stuff (pop (fd-stream-output-later stream)))
 	 (base (car stuff))
 	 (start (cadr stuff))
@@ -154,9 +161,9 @@
 	 (setf (fd-stream-handler stream)
 	       (sb!sys:add-fd-handler (fd-stream-fd stream)
 				      :output
-				      #'(lambda (fd)
-					  (declare (ignore fd))
-					  (do-output-later stream)))))
+				      (lambda (fd)
+					(declare (ignore fd))
+					(frob-output-later stream)))))
 	(t
 	 (nconc (fd-stream-output-later stream)
 		(list (list base start end reuse-sap)))))
@@ -168,7 +175,7 @@
 ;;; Output the given noise. Check to see whether there are any pending
 ;;; writes. If so, just queue this one. Otherwise, try to write it. If
 ;;; this would block, queue it.
-(defun do-output (stream base start end reuse-sap)
+(defun frob-output (stream base start end reuse-sap)
   (declare (type fd-stream stream)
 	   (type (or system-area-pointer (simple-array * (*))) base)
 	   (type index start end))
@@ -194,54 +201,131 @@
 (defun flush-output-buffer (stream)
   (let ((length (fd-stream-obuf-tail stream)))
     (unless (= length 0)
-      (do-output stream (fd-stream-obuf-sap stream) 0 length t)
+      (frob-output stream (fd-stream-obuf-sap stream) 0 length t)
       (setf (fd-stream-obuf-tail stream) 0))))
 
+(defmacro output-wrapper/variable-width ((stream size buffering restart)
+					 &body body)
+  (let ((stream-var (gensym)))
+    `(let ((,stream-var ,stream)
+	   (size ,size))
+      ,(unless (eq (car buffering) :none)
+	 `(when (< (fd-stream-obuf-length ,stream-var)
+	           (+ (fd-stream-obuf-tail ,stream-var)
+		       size))
+            (flush-output-buffer ,stream-var)))
+      ,(unless (eq (car buffering) :none)
+	 `(when (> (fd-stream-ibuf-tail ,stream-var)
+		   (fd-stream-ibuf-head ,stream-var))
+            (file-position ,stream-var (file-position ,stream-var))))
+      ,(if restart
+           
+           `(with-simple-restart (output-nothing
+                                  "~@<Skip output of this character.~@:>")
+             ,@body
+             (incf (fd-stream-obuf-tail ,stream-var) size))
+           `(progn
+             ,@body
+             (incf (fd-stream-obuf-tail ,stream-var) size)))
+      ,(ecase (car buffering)
+	 (:none
+	  `(flush-output-buffer ,stream-var))
+	 (:line
+	  `(when (eq (char-code byte) (char-code #\Newline))
+	     (flush-output-buffer ,stream-var)))
+	 (:full))
+    (values))))
+
+(defmacro output-wrapper ((stream size buffering restart) &body body)
+  (let ((stream-var (gensym)))
+    `(let ((,stream-var ,stream))
+      ,(unless (eq (car buffering) :none)
+	 `(when (< (fd-stream-obuf-length ,stream-var)
+	           (+ (fd-stream-obuf-tail ,stream-var)
+		       ,size))
+            (flush-output-buffer ,stream-var)))
+      ,(unless (eq (car buffering) :none)
+	 `(when (> (fd-stream-ibuf-tail ,stream-var)
+		   (fd-stream-ibuf-head ,stream-var))
+            (file-position ,stream-var (file-position ,stream-var))))
+      ,(if restart
+           `(with-simple-restart (output-nothing
+                                  "~@<Skip output of this character.~@:>")
+             ,@body
+             (incf (fd-stream-obuf-tail ,stream-var) ,size))
+           `(progn
+             ,@body
+             (incf (fd-stream-obuf-tail ,stream-var) ,size)))
+      ,(ecase (car buffering)
+	 (:none
+	  `(flush-output-buffer ,stream-var))
+	 (:line
+	  `(when (eq (char-code byte) (char-code #\Newline))
+	     (flush-output-buffer ,stream-var)))
+	 (:full))
+    (values))))
+
+(defmacro def-output-routines/variable-width
+    ((name-fmt size restart external-format &rest bufferings)
+     &body body)
+  (declare (optimize (speed 1)))
+  (cons 'progn
+	(mapcar
+	    (lambda (buffering)
+	      (let ((function
+		     (intern (let ((*print-case* :upcase))
+			       (format nil name-fmt (car buffering))))))
+		`(progn
+		   (defun ,function (stream byte)
+		     (output-wrapper/variable-width (stream ,size ,buffering ,restart)
+		       ,@body))
+		   (setf *output-routines*
+			 (nconc *output-routines*
+				',(mapcar
+				   (lambda (type)
+				     (list type
+					   (car buffering)
+					   function
+					   1
+					   external-format))
+				   (cdr buffering)))))))
+	    bufferings)))
+
 ;;; Define output routines that output numbers SIZE bytes long for the
 ;;; given bufferings. Use BODY to do the actual output.
-(defmacro def-output-routines ((name-fmt size &rest bufferings) &body body)
+(defmacro def-output-routines ((name-fmt size restart &rest bufferings)
+                               &body body)
   (declare (optimize (speed 1)))
   (cons 'progn
 	(mapcar
-	    #'(lambda (buffering)
-		(let ((function
-		       (intern (let ((*print-case* :upcase))
-				 (format nil name-fmt (car buffering))))))
-		  `(progn
-		     (defun ,function (stream byte)
-		       ,(unless (eq (car buffering) :none)
-			  `(when (< (fd-stream-obuf-length stream)
-				    (+ (fd-stream-obuf-tail stream)
-				       ,size))
-			     (flush-output-buffer stream)))
-		       ,@body
-		       (incf (fd-stream-obuf-tail stream) ,size)
-		       ,(ecase (car buffering)
-			  (:none
-			   `(flush-output-buffer stream))
-			  (:line
-			   `(when (eq (char-code byte) (char-code #\Newline))
-			      (flush-output-buffer stream)))
-			  (:full
-			   ))
-		       (values))
-		     (setf *output-routines*
-			   (nconc *output-routines*
-				  ',(mapcar
-					#'(lambda (type)
-					    (list type
-						  (car buffering)
-						  function
-						  size))
-				      (cdr buffering)))))))
-	  bufferings)))
-
+	    (lambda (buffering)
+	      (let ((function
+		     (intern (let ((*print-case* :upcase))
+			       (format nil name-fmt (car buffering))))))
+		`(progn
+		   (defun ,function (stream byte)
+		     (output-wrapper (stream ,size ,buffering ,restart)
+		       ,@body))
+		   (setf *output-routines*
+			 (nconc *output-routines*
+				',(mapcar
+				   (lambda (type)
+				     (list type
+					   (car buffering)
+					   function
+					   size
+					   nil))
+				   (cdr buffering)))))))
+	    bufferings)))
+
+;;; FIXME: is this used anywhere any more?
 (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
 		      1
+                      t
 		      (:none character)
 		      (:line character)
 		      (:full character))
-  (if (and (base-char-p byte) (char= byte #\Newline))
+  (if (char= byte #\Newline)
       (setf (fd-stream-char-pos stream) 0)
       (incf (fd-stream-char-pos stream)))
   (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
@@ -249,6 +333,7 @@
 
 (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED"
 		      1
+                      nil
 		      (:none (unsigned-byte 8))
 		      (:full (unsigned-byte 8)))
   (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
@@ -256,6 +341,7 @@
 
 (def-output-routines ("OUTPUT-SIGNED-BYTE-~A-BUFFERED"
 		      1
+                      nil
 		      (:none (signed-byte 8))
 		      (:full (signed-byte 8)))
   (setf (signed-sap-ref-8 (fd-stream-obuf-sap stream)
@@ -264,6 +350,7 @@
 
 (def-output-routines ("OUTPUT-UNSIGNED-SHORT-~A-BUFFERED"
 		      2
+                      nil
 		      (:none (unsigned-byte 16))
 		      (:full (unsigned-byte 16)))
   (setf (sap-ref-16 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
@@ -271,6 +358,7 @@
 
 (def-output-routines ("OUTPUT-SIGNED-SHORT-~A-BUFFERED"
 		      2
+                      nil
 		      (:none (signed-byte 16))
 		      (:full (signed-byte 16)))
   (setf (signed-sap-ref-16 (fd-stream-obuf-sap stream)
@@ -279,6 +367,7 @@
 
 (def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED"
 		      4
+                      nil
 		      (:none (unsigned-byte 32))
 		      (:full (unsigned-byte 32)))
   (setf (sap-ref-32 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
@@ -286,6 +375,7 @@
 
 (def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED"
 		      4
+                      nil
 		      (:none (signed-byte 32))
 		      (:full (signed-byte 32)))
   (setf (signed-sap-ref-32 (fd-stream-obuf-sap stream)
@@ -305,6 +395,9 @@
   (let ((start (or start 0))
 	(end (or end (length (the (simple-array * (*)) thing)))))
     (declare (type index start end))
+    (when (> (fd-stream-ibuf-tail fd-stream)
+	     (fd-stream-ibuf-head fd-stream))
+      (file-position fd-stream (file-position fd-stream)))
     (let* ((len (fd-stream-obuf-length fd-stream))
 	   (tail (fd-stream-obuf-tail fd-stream))
 	   (space (- len tail))
@@ -316,41 +409,41 @@
 	    ((<= bytes space)
 	     (if (system-area-pointer-p thing)
 		 (system-area-copy thing
-				   (* start sb!vm:byte-bits)
+				   (* start sb!vm:n-byte-bits)
 				   (fd-stream-obuf-sap fd-stream)
-				   (* tail sb!vm:byte-bits)
-				   (* bytes sb!vm:byte-bits))
+				   (* tail sb!vm:n-byte-bits)
+				   (* bytes sb!vm:n-byte-bits))
 		 ;; FIXME: There should be some type checking somewhere to
 		 ;; verify that THING here is a vector, not just <not a SAP>.
 		 (copy-to-system-area thing
-				      (+ (* start sb!vm:byte-bits)
+				      (+ (* start sb!vm:n-byte-bits)
 					 (* sb!vm:vector-data-offset
-					    sb!vm:word-bits))
+					    sb!vm:n-word-bits))
 				      (fd-stream-obuf-sap fd-stream)
-				      (* tail sb!vm:byte-bits)
-				      (* bytes sb!vm:byte-bits)))
+				      (* tail sb!vm:n-byte-bits)
+				      (* bytes sb!vm:n-byte-bits)))
 	     (setf (fd-stream-obuf-tail fd-stream) newtail))
 	    ((<= bytes len)
 	     (flush-output-buffer fd-stream)
 	     (if (system-area-pointer-p thing)
 		 (system-area-copy thing
-				   (* start sb!vm:byte-bits)
+				   (* start sb!vm:n-byte-bits)
 				   (fd-stream-obuf-sap fd-stream)
 				   0
-				   (* bytes sb!vm:byte-bits))
+				   (* bytes sb!vm:n-byte-bits))
 		 ;; FIXME: There should be some type checking somewhere to
 		 ;; verify that THING here is a vector, not just <not a SAP>.
 		 (copy-to-system-area thing
-				      (+ (* start sb!vm:byte-bits)
+				      (+ (* start sb!vm:n-byte-bits)
 					 (* sb!vm:vector-data-offset
-					    sb!vm:word-bits))
+					    sb!vm:n-word-bits))
 				      (fd-stream-obuf-sap fd-stream)
 				      0
-				      (* bytes sb!vm:byte-bits)))
+				      (* bytes sb!vm:n-byte-bits)))
 	     (setf (fd-stream-obuf-tail fd-stream) bytes))
 	    (t
 	     (flush-output-buffer fd-stream)
-	     (do-output fd-stream thing start end nil))))))
+	     (frob-output fd-stream thing start end nil))))))
 
 ;;; the routine to use to output a string. If the stream is
 ;;; unbuffered, slam the string down the file descriptor, otherwise
@@ -369,10 +462,15 @@
     (if (stringp thing)
 	(let ((last-newline (and (find #\newline (the simple-string thing)
 				       :start start :end end)
+				 ;; FIXME why do we need both calls?
+				 ;; Is find faster forwards than
+				 ;; position is backwards?
 				 (position #\newline (the simple-string thing)
 					   :from-end t
 					   :start start
 					   :end end))))
+	  (if (and (typep thing 'base-string)
+		   (eq (fd-stream-external-format stream) :latin-1))
 	  (ecase (fd-stream-buffering stream)
 	    (:full
 	     (output-raw-bytes stream thing start end))
@@ -381,7 +479,14 @@
 	     (when last-newline
 	       (flush-output-buffer stream)))
 	    (:none
-	     (do-output stream thing start end nil)))
+	     (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))
@@ -391,18 +496,90 @@
 	  ((:line :full)
 	   (output-raw-bytes stream thing start end))
 	  (:none
-	   (do-output stream thing start end nil))))))
+	   (frob-output stream thing start end nil))))))
+
+(defvar *external-formats* ()
+  #!+sb-doc
+  "List of all available external formats. Each element is a list of the
+  element-type, string input function name, character input function name,
+  and string output function name.")
 
 ;;; 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)
+(defun pick-output-routine (type buffering &optional external-format)
+  (when (subtypep type 'character)
+    (dolist (entry *external-formats*)
+      (when (member external-format (first entry))
+	(return-from pick-output-routine
+	  (values (symbol-function (nth (ecase buffering
+					  (:none 4)
+					  (:line 5)
+					  (:full 6))
+					entry))
+		  'character
+		  1
+		  (symbol-function (fourth entry))
+		  (first (first entry)))))))
   (dolist (entry *output-routines*)
-    (when (and (subtypep type (car entry))
-	       (eq buffering (cadr entry)))
-      (return (values (symbol-function (caddr entry))
-		      (car entry)
-		      (cadddr entry))))))
+    (when (and (subtypep type (first entry))
+	       (eq buffering (second entry))
+	       (or (not (fifth entry))
+		   (eq external-format (fifth entry))))
+      (return-from pick-output-routine
+	(values (symbol-function (third entry))
+		(first entry)
+		(fourth entry)))))
+  ;; KLUDGE: dealing with the buffering here leads to excessive code
+  ;; explosion.
+  ;;
+  ;; KLUDGE: also see comments in PICK-INPUT-ROUTINE
+  (loop for i from 40 by 8 to 1024 ; ARB (KLUDGE)
+	if (subtypep type `(unsigned-byte ,i))
+	do (return-from pick-output-routine
+	     (values
+	      (ecase buffering
+		(:none
+		 (lambda (stream byte)
+		   (output-wrapper (stream (/ i 8) (:none) nil)
+		     (loop for j from 0 below (/ i 8)
+			   do (setf (sap-ref-8 
+				     (fd-stream-obuf-sap stream)
+				     (+ j (fd-stream-obuf-tail stream)))
+				    (ldb (byte 8 (- i 8 (* j 8))) byte))))))
+		(:full
+		 (lambda (stream byte)
+		   (output-wrapper (stream (/ i 8) (:full) nil)
+		     (loop for j from 0 below (/ i 8)
+			   do (setf (sap-ref-8 
+				     (fd-stream-obuf-sap stream)
+				     (+ j (fd-stream-obuf-tail stream)))
+				    (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
+	      `(unsigned-byte ,i)
+	      (/ i 8))))
+  (loop for i from 40 by 8 to 1024 ; ARB (KLUDGE)
+	if (subtypep type `(signed-byte ,i))
+	do (return-from pick-output-routine
+	     (values
+	      (ecase buffering
+		(:none
+		 (lambda (stream byte)
+		   (output-wrapper (stream (/ i 8) (:none) nil)
+		     (loop for j from 0 below (/ i 8)
+			   do (setf (sap-ref-8 
+				     (fd-stream-obuf-sap stream)
+				     (+ j (fd-stream-obuf-tail stream)))
+				    (ldb (byte 8 (- i 8 (* j 8))) byte))))))
+		(:full
+		 (lambda (stream byte)
+		   (output-wrapper (stream (/ i 8) (:full) nil)
+		     (loop for j from 0 below (/ i 8)
+			   do (setf (sap-ref-8 
+				     (fd-stream-obuf-sap stream)
+				     (+ j (fd-stream-obuf-tail stream)))
+				    (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
+	      `(signed-byte ,i)
+	      (/ i 8)))))
 
 ;;;; input routines and related noise
 
@@ -414,7 +591,7 @@
 ;;; Fill the input buffer, and return the first character. Throw to
 ;;; EOF-INPUT-CATCHER if the eof was reached. Drop into SYSTEM:SERVER
 ;;; if necessary.
-(defun do-input (stream)
+(defun frob-input (stream)
   (let ((fd (fd-stream-fd stream))
 	(ibuf-sap (fd-stream-ibuf-sap stream))
 	(buflen (fd-stream-ibuf-length stream))
@@ -429,8 +606,8 @@
 	     (setf (fd-stream-ibuf-tail stream) 0))
 	    (t
 	     (decf tail head)
-	     (system-area-copy ibuf-sap (* head sb!vm:byte-bits)
-			       ibuf-sap 0 (* tail sb!vm:byte-bits))
+	     (system-area-copy ibuf-sap (* head sb!vm:n-byte-bits)
+			       ibuf-sap 0 (* tail sb!vm:n-byte-bits))
 	     (setf head 0)
 	     (setf (fd-stream-ibuf-head stream) 0)
 	     (setf (fd-stream-ibuf-tail stream) tail))))
@@ -454,10 +631,8 @@
       (case count
 	(1)
 	(0
-	 (unless #!-mp (sb!sys:wait-until-fd-usable
-		       fd :input (fd-stream-timeout stream))
-		 #!+mp (sb!mp:process-wait-until-fd-usable
-		       fd :input (fd-stream-timeout stream))
+	 (unless (sb!sys:wait-until-fd-usable
+		  fd :input (fd-stream-timeout stream))
 	   (error 'io-timeout :stream stream :direction :read)))
 	(t
 	 (simple-stream-perror "couldn't check whether ~S is readable"
@@ -470,21 +645,20 @@
       (cond ((null count)
 	     (if (eql errno sb!unix:ewouldblock)
 		 (progn
-		   (unless #!-mp (sb!sys:wait-until-fd-usable
-				 fd :input (fd-stream-timeout stream))
-			   #!+mp (sb!mp:process-wait-until-fd-usable
-				 fd :input (fd-stream-timeout stream))
+		   (unless (sb!sys:wait-until-fd-usable
+			    fd :input (fd-stream-timeout stream))
 		     (error 'io-timeout :stream stream :direction :read))
-		   (do-input stream))
+		   (frob-input stream))
 		 (simple-stream-perror "couldn't read from ~S" stream errno)))
 	    ((zerop count)
 	     (setf (fd-stream-listen stream) :eof)
+	     (/show0 "THROWing EOF-INPUT-CATCHER")
 	     (throw 'eof-input-catcher nil))
 	    (t
 	     (incf (fd-stream-ibuf-tail stream) count))))))
 			
 ;;; Make sure there are at least BYTES number of bytes in the input
-;;; buffer. Keep calling DO-INPUT until that condition is met.
+;;; buffer. Keep calling FROB-INPUT until that condition is met.
 (defmacro input-at-least (stream bytes)
   (let ((stream-var (gensym))
 	(bytes-var (gensym)))
@@ -495,7 +669,67 @@
 		      (fd-stream-ibuf-head ,stream-var))
 		   ,bytes-var)
 	   (return))
-	 (do-input ,stream-var)))))
+	 (frob-input ,stream-var)))))
+
+(defmacro input-wrapper/variable-width ((stream bytes eof-error eof-value
+						resync-function)
+					&body read-forms)
+  (let ((stream-var (gensym))
+	(retry-var (gensym))
+	(element-var (gensym)))
+    `(let ((,stream-var ,stream)
+	   (size nil))
+       (if (fd-stream-unread ,stream-var)
+	   (prog1
+	       (fd-stream-unread ,stream-var)
+	     (setf (fd-stream-unread ,stream-var) nil)
+	     (setf (fd-stream-listen ,stream-var) nil))
+	   (let ((,element-var nil))
+	     (do ((,retry-var t))
+		 ((not ,retry-var))
+	       (setq ,retry-var nil)
+	       (restart-case
+		   (catch 'eof-input-catcher
+		     (unless
+			 (block character-decode
+			   (input-at-least ,stream-var 1)
+			   (let* ((byte (sap-ref-8 (fd-stream-ibuf-sap
+						    ,stream-var)
+						   (fd-stream-ibuf-head
+						    ,stream-var))))
+			     (setq size ,bytes)
+			     (input-at-least ,stream-var size)
+			     (setq ,element-var (locally ,@read-forms))))
+		       (stream-decoding-error
+			,stream-var
+			(if size
+			    (loop for i from 0 below size
+				  collect (sap-ref-8 (fd-stream-ibuf-sap
+						      ,stream-var)
+						     (+ (fd-stream-ibuf-head
+							 ,stream-var)
+							i)))
+			    (list (sap-ref-8 (fd-stream-ibuf-sap
+					      ,stream-var)
+					     (fd-stream-ibuf-head
+					      ,stream-var)))))))
+		 (attempt-resync ()
+		   :report (lambda (stream)
+			     (format stream
+				     "~@<Attempt to resync the stream at a ~
+                                     character boundary and continue.~@:>"))
+		   (,resync-function ,stream-var)
+		   (setq ,retry-var t))
+		 (force-end-of-file ()
+		   :report (lambda (stream)
+			     (format stream
+				     "~@<Force an end of file.~@:>"))
+		   nil)))
+	     (cond (,element-var
+		    (incf (fd-stream-ibuf-head ,stream-var) size)
+		    ,element-var)
+		   (t
+		    (eof-or-lose ,stream-var ,eof-error ,eof-value))))))))
 
 ;;; a macro to wrap around all input routines to handle EOF-ERROR noise
 (defmacro input-wrapper ((stream bytes eof-error eof-value) &body read-forms)
@@ -510,13 +744,28 @@
 	   (let ((,element-var
 		  (catch 'eof-input-catcher
 		    (input-at-least ,stream-var ,bytes)
-		    ,@read-forms)))
+		    (locally ,@read-forms))))
 	     (cond (,element-var
 		    (incf (fd-stream-ibuf-head ,stream-var) ,bytes)
 		    ,element-var)
 		   (t
 		    (eof-or-lose ,stream-var ,eof-error ,eof-value))))))))
 
+(defmacro def-input-routine/variable-width (name
+					    (type external-format size sap head
+						  resync-function)
+					    &rest body)
+  `(progn
+     (defun ,name (stream eof-error eof-value)
+       (input-wrapper/variable-width (stream ,size eof-error eof-value
+					     ,resync-function)
+	 (let ((,sap (fd-stream-ibuf-sap stream))
+	       (,head (fd-stream-ibuf-head stream)))
+	   ,@body)))
+     (setf *input-routines*
+	   (nconc *input-routines*
+		  (list (list ',type ',name 1 ',external-format))))))
+
 (defmacro def-input-routine (name
 			     (type size sap head)
 			     &rest body)
@@ -528,7 +777,7 @@
 	   ,@body)))
      (setf *input-routines*
 	   (nconc *input-routines*
-		  (list (list ',type ',name ',size))))))
+		  (list (list ',type ',name ',size nil))))))
 
 ;;; STREAM-IN routine for reading a string char
 (def-input-routine input-character
@@ -565,24 +814,76 @@
 		   ((signed-byte 32) 4 sap head)
   (signed-sap-ref-32 sap head))
 
+
+
 ;;; Find an input routine to use given the type. Return as multiple
 ;;; values the routine, the real type transfered, and the number of
-;;; bytes per element.
-(defun pick-input-routine (type)
+;;; bytes per element (and for character types string input routine).
+(defun pick-input-routine (type &optional external-format)
+  (when (subtypep type 'character)
+    (dolist (entry *external-formats*)
+      (when (member external-format (first entry))
+	(return-from pick-input-routine
+	  (values (symbol-function (third entry))
+		  'character
+		  1
+		  (symbol-function (second entry))
+		  (first (first entry)))))))
   (dolist (entry *input-routines*)
-    (when (subtypep type (car entry))
-      (return (values (symbol-function (cadr entry))
-		      (car entry)
-		      (caddr entry))))))
+    (when (and (subtypep type (first entry))
+	       (or (not (fourth entry))
+		   (eq external-format (fourth entry))))
+      (return-from pick-input-routine
+	(values (symbol-function (second entry))
+		(first entry)
+		(third entry)))))
+  ;; FIXME: let's do it the hard way, then (but ignore things like
+  ;; endianness, efficiency, and the necessary coupling between these
+  ;; and the output routines).  -- CSR, 2004-02-09
+  (loop for i from 40 by 8 to 1024 ; ARB (well, KLUDGE really)
+	if (subtypep type `(unsigned-byte ,i))
+	do (return-from pick-input-routine
+	     (values
+	      (lambda (stream eof-error eof-value)
+		(input-wrapper (stream (/ i 8) eof-error eof-value)
+		  (let ((sap (fd-stream-ibuf-sap stream))
+			(head (fd-stream-ibuf-head stream)))
+		    (loop for j from 0 below (/ i 8)
+			  with result = 0
+			  do (setf result
+				   (+ (* 256 result)
+				      (sap-ref-8 sap (+ head j))))
+			  finally (return result)))))
+	      `(unsigned-byte ,i)
+	      (/ i 8))))
+  (loop for i from 40 by 8 to 1024 ; ARB (well, KLUDGE really)
+	if (subtypep type `(signed-byte ,i))
+	do (return-from pick-input-routine
+	     (values
+	      (lambda (stream eof-error eof-value)
+		(input-wrapper (stream (/ i 8) eof-error eof-value)
+		  (let ((sap (fd-stream-ibuf-sap stream))
+			(head (fd-stream-ibuf-head stream)))
+		    (loop for j from 0 below (/ i 8)
+			  with result = 0
+			  do (setf result
+				   (+ (* 256 result)
+				      (sap-ref-8 sap (+ head j))))
+			  finally (return (if (logbitp (1- i) result)
+                                              (dpb result (byte i 0) -1)
+                                              result))))))
+	      `(signed-byte ,i)
+	      (/ i 8)))))
 
 ;;; Return a string constructed from SAP, START, and END.
 (defun string-from-sap (sap start end)
   (declare (type index start end))
   (let* ((length (- end start))
 	 (string (make-string length)))
-    (copy-from-system-area sap (* start sb!vm:byte-bits)
-			   string (* sb!vm:vector-data-offset sb!vm:word-bits)
-			   (* length sb!vm:byte-bits))
+    (copy-from-system-area sap (* start sb!vm:n-byte-bits)
+			   string (* sb!vm:vector-data-offset
+				     sb!vm:n-word-bits)
+			   (* length sb!vm:n-byte-bits))
     string))
 
 ;;; the N-BIN method for FD-STREAMs
@@ -590,12 +891,28 @@
 ;;; Note that this blocks in UNIX-READ. It is generally used where
 ;;; there is a definite amount of reading to be done, so blocking
 ;;; isn't too problematical.
-(defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p)
+(defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p
+			       &aux (total-copied 0))
   (declare (type fd-stream stream))
-  (declare (type index start requested))
-  (do ((total-copied 0))
+  (declare (type index start requested total-copied))
+  (let ((unread (fd-stream-unread stream)))
+    (when unread
+      ;; AVERs designed to fail when we have more complicated
+      ;; character representations.
+      (aver (typep unread 'base-char))
+      (aver (= (fd-stream-element-size stream) 1))
+      ;; KLUDGE: this is a slightly-unrolled-and-inlined version of
+      ;; %BYTE-BLT
+      (etypecase buffer
+	(system-area-pointer
+	 (setf (sap-ref-8 buffer start) (char-code unread)))
+	((simple-unboxed-array (*))
+	 (setf (aref buffer start) unread)))
+      (setf (fd-stream-unread stream) nil)
+      (setf (fd-stream-listen stream) nil)
+      (incf total-copied)))
+  (do ()
       (nil)
-    (declare (type index total-copied))
     (let* ((remaining-request (- requested total-copied))
 	   (head (fd-stream-ibuf-head stream))
 	   (tail (fd-stream-ibuf-tail stream))
@@ -628,18 +945,372 @@
 (defun refill-fd-stream-buffer (stream)
   ;; We don't have any logic to preserve leftover bytes in the buffer,
   ;; so we should only be called when the buffer is empty.
-  (aver (= (fd-stream-ibuf-head stream) (fd-stream-ibuf-tail stream)))
-  (multiple-value-bind (count err)
-      (sb!unix:unix-read (fd-stream-fd stream)
-			 (fd-stream-ibuf-sap stream)
-			 (fd-stream-ibuf-length stream))
-    (declare (type (or index null) count))
-    (when (null count)
-      (simple-stream-perror "couldn't read from ~S" stream err))
-    (setf (fd-stream-listen stream) nil
-	  (fd-stream-ibuf-head stream) 0
-	  (fd-stream-ibuf-tail stream) count)
-    count))
+  ;; FIXME: can have three bytes in buffer because of UTF-8
+  (let ((new-head 0)
+        (sap (fd-stream-ibuf-sap stream)))
+    (do ((head (fd-stream-ibuf-head stream) (1+ head))
+         (tail (fd-stream-ibuf-tail stream)))
+        ((= head tail))
+      (setf (sap-ref-8 sap new-head) (sap-ref-8 sap head))
+      (incf new-head))
+    (multiple-value-bind (count err)
+        (sb!unix:unix-read (fd-stream-fd stream)
+                           (sap+ sap new-head)
+                           (- (fd-stream-ibuf-length stream) new-head))
+      (declare (type (or index null) count))
+      (when (null count)
+        (simple-stream-perror "couldn't read from ~S" stream err))
+      (setf (fd-stream-listen stream) nil
+            (fd-stream-ibuf-head stream) 0
+            (fd-stream-ibuf-tail stream) (+ count new-head))
+      count)))
+
+(defmacro define-external-format (external-format size output-restart
+                                  out-expr in-expr)
+  (let* ((name (first external-format))
+         (out-function (intern (let ((*print-case* :upcase))
+                                 (format nil "OUTPUT-BYTES/~A" name))))
+         (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" name))
+         (in-function (intern (let ((*print-case* :upcase))
+                                (format nil "FD-STREAM-READ-N-CHARACTERS/~A"
+                                        name))))
+         (in-char-function (intern (let ((*print-case* :upcase))
+                                     (format nil "INPUT-CHAR/~A" name)))))
+    `(progn
+      (defun ,out-function (stream string flush-p start end)
+	(let ((start (or start 0))
+	      (end (or end (length string))))
+	  (declare (type index start end))
+	  (when (> (fd-stream-ibuf-tail stream)
+		   (fd-stream-ibuf-head stream))
+	    (file-position stream (file-position stream)))
+	  (when (< end start)
+	    (error ":END before :START!"))
+	  (do ()
+	      ((= end start))
+	    (setf (fd-stream-obuf-tail stream)
+		  (do* ((len (fd-stream-obuf-length stream))
+			(sap (fd-stream-obuf-sap stream))
+			(tail (fd-stream-obuf-tail stream)))
+		       ((or (= start end) (< (- len tail) 4)) tail)
+                    ,(if output-restart
+                         `(with-simple-restart (output-nothing
+                                                "~@<Skip output of this character.~@:>")
+                           (let* ((byte (aref string start))
+                                  (bits (char-code byte)))
+                             ,out-expr
+                             (incf tail ,size)))
+                         `(let* ((byte (aref string start))
+                                  (bits (char-code byte)))
+                             ,out-expr
+                             (incf tail ,size)))
+		    (incf start)))
+	    (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 (char= byte #\Newline)
+	      (setf (fd-stream-char-pos stream) 0)
+	      (incf (fd-stream-char-pos stream)))
+	(let ((bits (char-code byte))
+	      (sap (fd-stream-obuf-sap stream))
+	      (tail (fd-stream-obuf-tail stream)))
+	  ,out-expr))
+      (defun ,in-function (stream buffer start requested eof-error-p
+			   &aux (total-copied 0))
+	(declare (type fd-stream stream))
+	(declare (type index start requested total-copied))
+	(let ((unread (fd-stream-unread stream)))
+	  (when unread
+	    (setf (aref buffer start) unread)
+	    (setf (fd-stream-unread stream) nil)
+	    (setf (fd-stream-listen stream) nil)
+	    (incf total-copied)))
+	(do ()
+	    (nil)
+	  (let* ((head (fd-stream-ibuf-head stream))
+		 (tail (fd-stream-ibuf-tail stream))
+		 (sap (fd-stream-ibuf-sap stream)))
+	    (declare (type index head tail))
+	    ;; Copy data from stream buffer into user's buffer.
+	    (do ()
+		((or (= tail head) (= requested total-copied)))
+	      (let* ((byte (sap-ref-8 sap head)))
+		(when (> ,size (- tail head))
+		  (return))
+		(setf (aref buffer (+ start total-copied)) ,in-expr)
+		(incf total-copied)
+		(incf head ,size)))
+	    (setf (fd-stream-ibuf-head stream) head)
+	    ;; Maybe we need to refill the stream buffer.
+	    (cond ( ;; If there were enough data in the stream buffer, we're done.
+		   (= total-copied requested)
+		   (return total-copied))
+		  ( ;; If EOF, we're done in another way.
+		   (zerop (refill-fd-stream-buffer stream))
+		   (if eof-error-p
+		       (error 'end-of-file :stream stream)
+		       (return total-copied)))
+		  ;; Otherwise we refilled the stream buffer, so fall
+		  ;; through into another pass of the loop.
+		  ))))
+      (def-input-routine ,in-char-function (character ,size sap head)
+	(let ((byte (sap-ref-8 sap head)))
+	  ,in-expr))
+      (setf *external-formats*
+       (cons '(,external-format ,in-function ,in-char-function ,out-function
+	       ,@(mapcar #'(lambda (buffering)
+			     (intern (let ((*print-case* :upcase))
+				       (format nil format buffering))))
+			 '(:none :line :full)))
+	*external-formats*)))))
+
+(defmacro define-external-format/variable-width
+    (external-format output-restart out-size-expr
+     out-expr in-size-expr in-expr)
+  (let* ((name (first external-format))
+	 (out-function (intern (let ((*print-case* :upcase))
+				 (format nil "OUTPUT-BYTES/~A" name))))
+	 (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" name))
+	 (in-function (intern (let ((*print-case* :upcase))
+				(format nil "FD-STREAM-READ-N-CHARACTERS/~A"
+					name))))
+	 (in-char-function (intern (let ((*print-case* :upcase))
+				     (format nil "INPUT-CHAR/~A" name))))
+	 (resync-function (intern (let ((*print-case* :upcase))
+				    (format nil "RESYNC/~A" name)))))
+    `(progn
+      (defun ,out-function (fd-stream string flush-p start end)
+	(let ((start (or start 0))
+	      (end (or end (length string))))
+	  (declare (type index start end))
+	  (when (> (fd-stream-ibuf-tail fd-stream)
+		   (fd-stream-ibuf-head fd-stream))
+	    (file-position fd-stream (file-position fd-stream)))
+	  (when (< end start)
+	    (error ":END before :START!"))
+	  (do ()
+	      ((= end start))
+	    (setf (fd-stream-obuf-tail fd-stream)
+		  (do* ((len (fd-stream-obuf-length fd-stream))
+			(sap (fd-stream-obuf-sap fd-stream))
+			(tail (fd-stream-obuf-tail fd-stream)))
+		       ((or (= start end) (< (- len tail) 4)) tail)
+		    (let* ((byte (aref string start))
+			   (bits (char-code byte))
+			   (size ,out-size-expr))
+		      ,out-expr
+		      (incf tail size)
+		      (incf start))))
+	    (when (< start end)
+	      (flush-output-buffer fd-stream)))
+	  (when flush-p
+	    (flush-output-buffer fd-stream))))
+      (def-output-routines/variable-width (,format
+					   ,out-size-expr
+                                           ,output-restart
+					   ,external-format
+					   (:none character)
+					   (:line character)
+					   (:full character))
+	  (if (char= byte #\Newline)
+	      (setf (fd-stream-char-pos stream) 0)
+	      (incf (fd-stream-char-pos stream)))
+	(let ((bits (char-code byte))
+	      (sap (fd-stream-obuf-sap stream))
+	      (tail (fd-stream-obuf-tail stream)))
+	  ,out-expr))
+      (defun ,in-function (stream buffer start requested eof-error-p
+			   &aux (total-copied 0))
+	(declare (type fd-stream stream))
+	(declare (type index start requested total-copied))
+	(let ((unread (fd-stream-unread stream)))
+	  (when unread
+	    (setf (aref buffer start) unread)
+	    (setf (fd-stream-unread stream) nil)
+	    (setf (fd-stream-listen stream) nil)
+	    (incf total-copied)))
+	(do ()
+	    (nil)
+	  (let* ((head (fd-stream-ibuf-head stream))
+		 (tail (fd-stream-ibuf-tail stream))
+		 (sap (fd-stream-ibuf-sap stream)))
+	    (declare (type index head tail))
+	    ;; Copy data from stream buffer into user's buffer.
+	    (do ((size nil nil))
+		((or (= tail head) (= requested total-copied)))
+	      (restart-case
+		  (unless (block character-decode
+			    (let ((byte (sap-ref-8 sap head)))
+			      (setq size ,in-size-expr)
+			      (when (> size (- tail head))
+				(return))
+			      (setf (aref buffer (+ start total-copied))
+				    ,in-expr)
+			      (incf total-copied)
+			      (incf head size)))
+		    (setf (fd-stream-ibuf-head stream) head)
+		    (if (plusp total-copied)
+			(return-from ,in-function total-copied)
+			(stream-decoding-error
+			 stream
+			 (if size
+			     (loop for i from 0 below size
+				   collect (sap-ref-8 (fd-stream-ibuf-sap
+						       stream)
+						      (+ (fd-stream-ibuf-head
+							  stream)
+							 i)))
+			     (list (sap-ref-8 (fd-stream-ibuf-sap stream)
+					      (fd-stream-ibuf-head stream)))))))
+		(attempt-resync ()
+		  :report (lambda (stream)
+			    (format stream
+				    "~@<Attempt to resync the stream at a ~
+                                    character boundary and continue.~@:>"))
+		  (,resync-function stream)
+		  (setf head (fd-stream-ibuf-head stream)))
+		(force-end-of-file ()
+		  :report (lambda (stream)
+			    (format stream "~@<Force an end of file.~@:>"))
+		  (if eof-error-p
+		      (error 'end-of-file :stream stream)
+		      (return-from ,in-function total-copied)))))
+	    (setf (fd-stream-ibuf-head stream) head)
+	    ;; Maybe we need to refill the stream buffer.
+	    (cond ( ;; If there were enough data in the stream buffer, we're done.
+		   (= total-copied requested)
+		   (return total-copied))
+		  ( ;; If EOF, we're done in another way.
+		   (zerop (refill-fd-stream-buffer stream))
+		   (if eof-error-p
+		       (error 'end-of-file :stream stream)
+		       (return total-copied)))
+		  ;; Otherwise we refilled the stream buffer, so fall
+		  ;; through into another pass of the loop.
+		  ))))
+      (def-input-routine/variable-width ,in-char-function (character
+							   ,external-format
+							   ,in-size-expr
+							   sap head
+							   ,resync-function)
+	(let ((byte (sap-ref-8 sap head)))
+	  ,in-expr))
+      (defun ,resync-function (stream)
+        (loop (input-at-least stream 1)
+              (incf (fd-stream-ibuf-head stream))
+              (when (block character-decode
+                      (let* ((sap (fd-stream-ibuf-sap stream))
+                             (head (fd-stream-ibuf-head stream))
+                             (byte (sap-ref-8 sap head))
+                             (size ,in-size-expr))
+                        ,in-expr))
+                (return))))
+      (setf *external-formats*
+       (cons '(,external-format ,in-function ,in-char-function ,out-function
+	       ,@(mapcar #'(lambda (buffering)
+			     (intern (let ((*print-case* :upcase))
+				       (format nil format buffering))))
+			 '(:none :line :full))
+	       ,resync-function)
+	*external-formats*)))))
+
+(define-external-format (:latin-1 :latin1 :iso-8859-1)
+    1 t
+  (if (>= bits 256)
+      (stream-encoding-error stream bits)
+      (setf (sap-ref-8 sap tail) bits))
+  (code-char byte))
+
+(define-external-format (:ascii :us-ascii :ansi_x3.4-1968)
+    1 t
+  (if (>= bits 128)
+      (stream-encoding-error stream bits)
+      (setf (sap-ref-8 sap tail) bits))
+  (code-char byte))
+
+#!+sb-unicode
+(let ((latin-9-table (let ((table (make-string 256)))
+                       (do ((i 0 (1+ i)))
+                           ((= i 256))
+                         (setf (aref table i) (code-char i)))
+                       (setf (aref table #xa4) (code-char #x20ac))
+                       (setf (aref table #xa6) (code-char #x0160))
+                       (setf (aref table #xa8) (code-char #x0161))
+                       (setf (aref table #xb4) (code-char #x017d))
+                       (setf (aref table #xb8) (code-char #x017e))
+                       (setf (aref table #xbc) (code-char #x0152))
+                       (setf (aref table #xbd) (code-char #x0153))
+                       (setf (aref table #xbe) (code-char #x0178))
+                       table))
+      (latin-9-reverse-1 (make-array 16
+                                     :element-type '(unsigned-byte 21)
+                                     :initial-contents '(#x0160 #x0161 #x0152 #x0153 0 0 0 0 #x0178 0 0 0 #x20ac #x017d #x017e 0)))
+      (latin-9-reverse-2 (make-array 16
+                                     :element-type '(unsigned-byte 8)
+                                     :initial-contents '(#xa6 #xa8 #xbc #xbd 0 0 0 0 #xbe 0 0 0 #xa4 #xb4 #xb8 0))))
+  (define-external-format (:latin-9 :latin9 :iso-8859-15)
+      1 t
+    (setf (sap-ref-8 sap tail)
+          (if (< bits 256)
+              (if (= bits (char-code (aref latin-9-table bits)))
+                  bits
+                  (stream-encoding-error stream byte))
+              (if (= (aref latin-9-reverse-1 (logand bits 15)) bits)
+                  (aref latin-9-reverse-2 (logand bits 15))
+                  (stream-encoding-error stream byte))))
+    (aref latin-9-table byte)))
+
+(define-external-format/variable-width (:utf-8 :utf8) nil
+  (let ((bits (char-code byte)))
+    (cond ((< bits #x80) 1)
+	  ((< bits #x800) 2)
+	  ((< bits #x10000) 3)
+	  (t 4)))
+  (ecase size
+    (1 (setf (sap-ref-8 sap tail) bits))
+    (2 (setf (sap-ref-8 sap tail) (logior #xc0 (ldb (byte 5 6) bits))
+	     (sap-ref-8 sap (1+ tail)) (logior #x80 (ldb (byte 6 0) bits))))
+    (3 (setf (sap-ref-8 sap tail) (logior #xe0 (ldb (byte 4 12) bits))
+	     (sap-ref-8 sap (1+ tail)) (logior #x80 (ldb (byte 6 6) bits))
+	     (sap-ref-8 sap (+ 2 tail)) (logior #x80 (ldb (byte 6 0) bits))))
+    (4 (setf (sap-ref-8 sap tail) (logior #xf0 (ldb (byte 3 18) bits))
+	     (sap-ref-8 sap (1+ tail)) (logior #x80 (ldb (byte 6 12) bits))
+	     (sap-ref-8 sap (+ 2 tail)) (logior #x80 (ldb (byte 6 6) bits))
+	     (sap-ref-8 sap (+ 3 tail)) (logior #x80 (ldb (byte 6 0) bits)))))
+  (cond ((< byte #x80) 1)
+	((< byte #xc2) (return-from character-decode))
+	((< byte #xe0) 2)
+	((< byte #xf0) 3)
+	(t 4))
+  (code-char (ecase size
+	       (1 byte)
+	       (2 (let ((byte2 (sap-ref-8 sap (1+ head))))
+		    (unless (<= #x80 byte2 #xbf)
+		      (return-from character-decode))
+		    (dpb byte (byte 5 6) byte2)))
+	       (3 (let ((byte2 (sap-ref-8 sap (1+ head)))
+			(byte3 (sap-ref-8 sap (+ 2 head))))
+		    (unless (and (<= #x80 byte2 #xbf)
+				 (<= #x80 byte3 #xbf))
+		      (return-from character-decode))
+		    (dpb byte (byte 4 12) (dpb byte2 (byte 6 6) byte3))))
+	       (4 (let ((byte2 (sap-ref-8 sap (1+ head)))
+			(byte3 (sap-ref-8 sap (+ 2 head)))
+			(byte4 (sap-ref-8 sap (+ 3 head))))
+		    (unless (and (<= #x80 byte2 #xbf)
+				 (<= #x80 byte3 #xbf)
+				 (<= #x80 byte4 #xbf))
+		      (return-from character-decode))
+		    (dpb byte (byte 3 18)
+			 (dpb byte2 (byte 6 12)
+			      (dpb byte3 (byte 6 6) byte4))))))))
 
 ;;;; utility functions (misc routines, etc)
 
@@ -657,7 +1328,8 @@
 	(input-type nil)
 	(output-type nil)
 	(input-size nil)
-	(output-size nil))
+	(output-size nil)
+	(character-stream-p (subtypep type 'character)))
 
     (when (fd-stream-obuf-sap fd-stream)
       (push (fd-stream-obuf-sap fd-stream) *available-buffers*)
@@ -666,31 +1338,73 @@
       (push (fd-stream-ibuf-sap fd-stream) *available-buffers*)
       (setf (fd-stream-ibuf-sap fd-stream) nil))
 
+    (when (and character-stream-p
+	       (eq (fd-stream-external-format fd-stream) :default))
+      (setf (fd-stream-external-format fd-stream)
+	    (intern (or (alien-funcall
+			 (extern-alien "nl_langinfo"
+				       (function c-string int))
+			 sb!unix:codeset)
+			"LATIN-1")
+		    "KEYWORD")))
+    (dolist (entry *external-formats*
+	     (setf (fd-stream-external-format fd-stream) :latin-1))
+      (when (member (fd-stream-external-format fd-stream) (first entry))
+	(return)))
+
     (when input-p
-      (multiple-value-bind (routine type size)
-	  (pick-input-routine target-type)
+      (multiple-value-bind (routine type size read-n-characters
+                                    normalized-external-format)
+	  (pick-input-routine target-type
+                              (fd-stream-external-format fd-stream))
+        (when normalized-external-format
+          (setf (fd-stream-external-format fd-stream)
+                normalized-external-format))
 	(unless routine
 	  (error "could not find any input routine for ~S" target-type))
 	(setf (fd-stream-ibuf-sap fd-stream) (next-available-buffer))
 	(setf (fd-stream-ibuf-length fd-stream) bytes-per-buffer)
 	(setf (fd-stream-ibuf-tail fd-stream) 0)
-	(if (subtypep type 'character)
+	(if character-stream-p
 	    (setf (fd-stream-in fd-stream) routine
 		  (fd-stream-bin fd-stream) #'ill-bin)
 	    (setf (fd-stream-in fd-stream) #'ill-in
 		  (fd-stream-bin fd-stream) routine))
 	(when (eql size 1)
-	  (setf (fd-stream-n-bin fd-stream) #'fd-stream-read-n-bytes)
-	  (when buffer-p
-	    (setf (lisp-stream-in-buffer fd-stream)
-		  (make-array +in-buffer-length+
-			      :element-type '(unsigned-byte 8)))))
+	  (setf (fd-stream-n-bin fd-stream)
+                (if character-stream-p
+                    read-n-characters
+                    #'fd-stream-read-n-bytes))
+	  (when (and buffer-p
+		     ;; We only create this buffer for streams of type
+		     ;; (unsigned-byte 8).  Because there's no buffer, the
+		     ;; other element-types will dispatch to the appropriate
+		     ;; input (output) routine in fast-read-byte.
+		     (or character-stream-p
+			 (equal target-type '(unsigned-byte 8)))
+		     (not output-p) ; temporary disable on :io streams
+		     #+(or)
+		     (or (eq type 'unsigned-byte)
+			 (eq type :default)))
+            (if character-stream-p
+                (setf (ansi-stream-cin-buffer fd-stream)
+                      (make-array +ansi-stream-in-buffer-length+
+                                  :element-type 'character))
+                (setf (ansi-stream-in-buffer fd-stream)
+                      (make-array +ansi-stream-in-buffer-length+
+                                  :element-type '(unsigned-byte 8))))))
 	(setf input-size size)
 	(setf input-type type)))
 
     (when output-p
-      (multiple-value-bind (routine type size)
-	  (pick-output-routine target-type (fd-stream-buffering fd-stream))
+      (multiple-value-bind (routine type size output-bytes
+				    normalized-external-format)
+	  (pick-output-routine target-type
+			       (fd-stream-buffering fd-stream)
+			       (fd-stream-external-format fd-stream))
+	(when normalized-external-format
+	  (setf (fd-stream-external-format fd-stream)
+		normalized-external-format))
 	(unless routine
 	  (error "could not find any output routine for ~S buffered ~S"
 		 (fd-stream-buffering fd-stream)
@@ -698,13 +1412,15 @@
 	(setf (fd-stream-obuf-sap fd-stream) (next-available-buffer))
 	(setf (fd-stream-obuf-length fd-stream) bytes-per-buffer)
 	(setf (fd-stream-obuf-tail fd-stream) 0)
-	(if (subtypep type 'character)
+	(when character-stream-p
+	  (setf (fd-stream-output-bytes fd-stream) output-bytes))
+	(if character-stream-p
 	  (setf (fd-stream-out fd-stream) routine
 		(fd-stream-bout fd-stream) #'ill-bout)
 	  (setf (fd-stream-out fd-stream)
 		(or (if (eql size 1)
-		      (pick-output-routine 'base-char
-					   (fd-stream-buffering fd-stream)))
+			  (pick-output-routine
+			   'base-char (fd-stream-buffering fd-stream)))
 		    #'ill-out)
 		(fd-stream-bout fd-stream) routine))
 	(setf (fd-stream-sout fd-stream)
@@ -758,27 +1474,40 @@
      (setf (fd-stream-unread fd-stream) arg1)
      (setf (fd-stream-listen fd-stream) t))
     (:close
-     (cond (arg1
-	    ;; We got us an abort on our hands.
+     (cond (arg1 ; We got us an abort on our hands.
 	    (when (fd-stream-handler fd-stream)
-		  (sb!sys:remove-fd-handler (fd-stream-handler fd-stream))
-		  (setf (fd-stream-handler fd-stream) nil))
+	      (sb!sys:remove-fd-handler (fd-stream-handler fd-stream))
+	      (setf (fd-stream-handler fd-stream) nil))
+	    ;; We can't do anything unless we know what file were
+	    ;; dealing with, and we don't want to do anything
+	    ;; strange unless we were writing to the file.
 	    (when (and (fd-stream-file fd-stream)
 		       (fd-stream-obuf-sap fd-stream))
-	      ;; We can't do anything unless we know what file were
-	      ;; dealing with, and we don't want to do anything
-	      ;; strange unless we were writing to the file.
 	      (if (fd-stream-original fd-stream)
-		  ;; We have a handle on the original, just revert.
-		  (multiple-value-bind (okay err)
-		      (sb!unix:unix-rename (fd-stream-original fd-stream)
-					   (fd-stream-file fd-stream))
-		    (unless okay
-		      (simple-stream-perror
-		       "couldn't restore ~S to its original contents"
-		       fd-stream
-		       err)))
-		  ;; We can't restore the original, so nuke that puppy.
+		  ;; If the original is EQ to file we are appending
+		  ;; and can just close the file without renaming.
+		  (unless (eq (fd-stream-original fd-stream)
+			      (fd-stream-file fd-stream))
+		    ;; We have a handle on the original, just revert.
+		    (multiple-value-bind (okay err)
+			(sb!unix:unix-rename (fd-stream-original fd-stream)
+					     (fd-stream-file fd-stream))
+		      (unless okay
+			(simple-stream-perror
+			 "couldn't restore ~S to its original contents"
+			 fd-stream
+			 err))))
+		  ;; We can't restore the original, and aren't
+		  ;; appending, so nuke that puppy.
+		  ;;
+		  ;; FIXME: This is currently the fate of superseded
+		  ;; files, and according to the CLOSE spec this is
+		  ;; wrong. However, there seems to be no clean way to
+		  ;; do that that doesn't involve either copying the
+		  ;; data (bad if the :abort resulted from a full
+		  ;; disk), or renaming the old file temporarily
+		  ;; (probably bad because stream opening becomes more
+		  ;; racy).
 		  (multiple-value-bind (okay err)
 		      (sb!unix:unix-unlink (fd-stream-file fd-stream))
 		    (unless okay
@@ -831,7 +1560,7 @@
 						 0
 						 0))))
 	  (cond ((eql count 1)
-		 (do-input fd-stream)
+		 (frob-input fd-stream)
 		 (setf (fd-stream-ibuf-head fd-stream) 0)
 		 (setf (fd-stream-ibuf-tail fd-stream) 0))
 		(t
@@ -846,8 +1575,8 @@
     (:element-type
      (fd-stream-element-type fd-stream))
     (:interactive-p
-      ;; FIXME: sb!unix:unix-isatty is undefined.
-     (sb!unix:unix-isatty (fd-stream-fd fd-stream)))
+     (= 1 (the (member 0 1)
+            (sb!unix:unix-isatty (fd-stream-fd fd-stream)))))
     (:line-length
      80)
     (:charpos
@@ -860,7 +1589,7 @@
        ;; appropriate value for the EXPECTED-TYPE slot..
        (error 'simple-type-error
               :datum fd-stream
-              :expected-type 'file-stream
+              :expected-type 'fd-stream
               :format-control "~S is not a stream associated with a file."
               :format-arguments (list fd-stream)))
      (multiple-value-bind (okay dev ino mode nlink uid gid rdev size
@@ -878,22 +1607,22 @@
 
 (defun fd-stream-file-position (stream &optional newpos)
   (declare (type fd-stream stream)
-	   (type (or index (member nil :start :end)) newpos))
+	   (type (or (alien sb!unix:off-t) (member nil :start :end)) newpos))
   (if (null newpos)
       (sb!sys:without-interrupts
 	;; First, find the position of the UNIX file descriptor in the file.
 	(multiple-value-bind (posn errno)
 	    (sb!unix:unix-lseek (fd-stream-fd stream) 0 sb!unix:l_incr)
-	  (declare (type (or index null) posn))
-	  (cond ((fixnump posn)
+	  (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
+		 ;; 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 (- (the index (caddr later))
-				 (the index (cadr later)))))
+		   (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
@@ -914,7 +1643,7 @@
 					 stream
 					 errno))))))
       (let ((offset 0) origin)
-	(declare (type index offset))
+	(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.
@@ -934,14 +1663,14 @@
 	       (setf offset 0 origin sb!unix:l_set))
 	      ((eq newpos :end)
 	       (setf offset 0 origin sb!unix:l_xtnd))
-	      ((typep newpos 'index)
+	      ((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 'fixnum)
+	  (cond ((typep posn '(alien sb!unix:off-t))
 		 t)
 		((eq errno sb!unix:espipe)
 		 nil)
@@ -975,6 +1704,7 @@
 		       (output nil output-p)
 		       (element-type 'base-char)
 		       (buffering :full)
+		       (external-format :default)
 		       timeout
 		       file
 		       original
@@ -983,7 +1713,7 @@
 		       input-buffer-p
 		       (name (if file
 				 (format nil "file ~S" file)
-				 (format nil "descriptor ~D" fd)))
+				 (format nil "descriptor ~W" fd)))
 		       auto-close)
   (declare (type index fd) (type (or index null) timeout)
 	   (type (member :none :line :full) buffering))
@@ -998,6 +1728,7 @@
 				 :delete-original delete-original
 				 :pathname pathname
 				 :buffering buffering
+				 :external-format external-format
 				 :timeout timeout)))
     (set-fd-stream-routines stream element-type input output input-buffer-p)
     (when (and auto-close (fboundp 'finalize))
@@ -1005,15 +1736,15 @@
 		(lambda ()
 		  (sb!unix:unix-close fd)
 		  #!+sb-show
-		  (format *terminal-io* "** closed file descriptor ~D **~%"
+		  (format *terminal-io* "** closed file descriptor ~W **~%"
 			  fd))))
     stream))
 
 ;;; Pick a name to use for the backup file for the :IF-EXISTS
 ;;; :RENAME-AND-DELETE and :RENAME options.
 (defun pick-backup-name (name)
-  (declare (type simple-string name))
-  (concatenate 'simple-string name ".bak"))
+  (declare (type simple-base-string name))
+  (concatenate 'simple-base-string name ".bak"))
 
 ;;; Ensure that the given arg is one of the given list of valid
 ;;; things. Allow the user to fix any problems.
@@ -1028,7 +1759,7 @@
 ;;; Rename NAMESTRING to ORIGINAL. First, check whether we have write
 ;;; access, since we don't want to trash unwritable files even if we
 ;;; technically can. We return true if we succeed in renaming.
-(defun do-old-rename (namestring original)
+(defun rename-the-old-one (namestring original)
   (unless (sb!unix:unix-access namestring sb!unix:w_ok)
     (error "~@<The file ~2I~_~S ~I~_is not writable.~:>" namestring))
   (multiple-value-bind (okay err) (sb!unix:unix-rename namestring original)
@@ -1057,18 +1788,10 @@
    :DIRECTION - one of :INPUT, :OUTPUT, :IO, or :PROBE
    :ELEMENT-TYPE - the type of object to read or write, default BASE-CHAR
    :IF-EXISTS - one of :ERROR, :NEW-VERSION, :RENAME, :RENAME-AND-DELETE,
-		       :OVERWRITE, :APPEND, :SUPERSEDE or NIL
-   :IF-DOES-NOT-EXIST - one of :ERROR, :CREATE or nil
+                       :OVERWRITE, :APPEND, :SUPERSEDE or NIL
+   :IF-DOES-NOT-EXIST - one of :ERROR, :CREATE or NIL
   See the manual for details."
 
-  (unless (eq external-format :default)
-    (error "Any external format other than :DEFAULT isn't recognized."))
-
-  ;; First, make sure that DIRECTION is valid.
-  (ensure-one-of direction
-		 '(:input :output :io :probe)
-		 :direction)
-
   ;; Calculate useful stuff.
   (multiple-value-bind (input output mask)
       (case direction
@@ -1077,10 +1800,12 @@
 	(:io     (values   t   t sb!unix:o_rdwr))
 	(:probe  (values   t nil sb!unix:o_rdonly)))
     (declare (type index mask))
-    (let* ((pathname (pathname filename))
+    (let* ((pathname (merge-pathnames filename))
 	   (namestring
 	    (cond ((unix-namestring pathname input))
 		  ((and input (eq if-does-not-exist :create))
+		   (unix-namestring pathname nil))
+		  ((and (eq direction :io) (not if-does-not-exist-given))
 		   (unix-namestring pathname nil)))))
       ;; Process if-exists argument if we are doing any output.
       (cond (output
@@ -1095,11 +1820,11 @@
 				     :append :supersede nil)
 			    :if-exists)
 	     (case if-exists
-	       ((:error nil)
+	       ((:new-version :error nil)
 		(setf mask (logior mask sb!unix:o_excl)))
 	       ((:rename :rename-and-delete)
 		(setf mask (logior mask sb!unix:o_creat)))
-	       ((:new-version :supersede)
+	       ((:supersede)
 		(setf mask (logior mask sb!unix:o_trunc)))
 	       (:append
 		(setf mask (logior mask sb!unix:o_append)))))
@@ -1122,12 +1847,16 @@
       (if (eq if-does-not-exist :create)
 	(setf mask (logior mask sb!unix:o_creat)))
 
-      (let ((original (if (member if-exists
-				  '(:rename :rename-and-delete))
-			  (pick-backup-name namestring)))
+      (let ((original (case if-exists
+			((:rename :rename-and-delete)
+			 (pick-backup-name namestring))
+			((:append)
+			 ;; KLUDGE: Provent CLOSE from deleting
+			 ;; appending streams when called with :ABORT T
+			 namestring)))
 	    (delete-original (eq if-exists :rename-and-delete))
 	    (mode #o666))
-	(when original
+	(when (and original (not (eq original namestring)))
 	  ;; We are doing a :RENAME or :RENAME-AND-DELETE. Determine
 	  ;; whether the file already exists, make sure the original
 	  ;; file is not a directory, and keep the mode.
@@ -1155,7 +1884,7 @@
 					      namestring
 					      err/dev)))))))
 	    (unless (and exists
-			 (do-old-rename namestring original))
+			 (rename-the-old-one namestring original))
 	      (setf original nil)
 	      (setf delete-original nil)
 	      ;; In order to use :SUPERSEDE instead, we have to make
@@ -1167,7 +1896,7 @@
 		      (logior (logandc2 mask sb!unix:o_creat)
 			      sb!unix:o_trunc)))
 	      (setf if-exists :supersede))))
-	
+
 	;; Now we can try the actual Unix open(2).
 	(multiple-value-bind (fd errno)
 	    (if namestring
@@ -1187,6 +1916,7 @@
 				      :input input
 				      :output output
 				      :element-type element-type
+				      :external-format external-format
 				      :file namestring
 				      :original original
 				      :delete-original delete-original
@@ -1208,7 +1938,7 @@
 		      (open-error "~@<The path ~2I~_~S ~I~_does not exist.~:>"
 				  pathname))
 		     (t nil)))
-		  ((and (eql errno sb!unix:eexist) if-exists)
+		  ((and (eql errno sb!unix:eexist) (null if-exists))
 		   nil)
 		  (t
 		   (vanilla-open-error)))))))))
@@ -1233,14 +1963,7 @@
   (stream-reinit)
   (setf *terminal-io* (make-synonym-stream '*tty*))
   (setf *standard-output* (make-synonym-stream '*stdout*))
-  (setf *standard-input*
-	(#!-high-security
-	 ;; FIXME: Why is *STANDARD-INPUT* a TWO-WAY-STREAM? ANSI says
-	 ;; it's an input stream.
-	 make-two-way-stream
-	 #!+high-security
-	 %make-two-way-stream (make-synonym-stream '*stdin*)
-			     *standard-output*))
+  (setf *standard-input* (make-synonym-stream '*stdin*))
   (setf *error-output* (make-synonym-stream '*stderr*))
   (setf *query-io* (make-synonym-stream '*terminal-io*))
   (setf *debug-io* *query-io*)
@@ -1256,7 +1979,8 @@
 	(make-fd-stream 1 :name "standard output" :output t :buffering :line))
   (setf *stderr*
 	(make-fd-stream 2 :name "standard error" :output t :buffering :line))
-  (let ((tty (sb!unix:unix-open "/dev/tty" sb!unix:o_rdwr #o666)))
+  (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
@@ -1297,7 +2021,7 @@
 ;;;; COMMON-LISP.)
 
 (defun file-string-length (stream object)
-  (declare (type (or string character) object) (type file-stream stream))
+  (declare (type (or string character) object) (type fd-stream stream))
   #!+sb-doc
   "Return the delta in STREAM's FILE-POSITION that would be caused by writing
    OBJECT to STREAM. Non-trivial only in implementations that support
@@ -1308,7 +2032,9 @@
     (string (length object))))
 
 (defun stream-external-format (stream)
-  (declare (type file-stream stream) (ignore stream))
+  (declare (type fd-stream stream))
   #!+sb-doc
-  "Return :DEFAULT."
-  :default)
+  "Return the actual external format for fd-streams, otherwise :DEFAULT."
+  (if (typep stream 'fd-stream)
+      (fd-stream-external-format stream)
+      :default))