X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-simple-streams%2Finternal.lisp;h=a74aabb2951f2e75b5d3b656bbf3788e20ad52bb;hb=338732358d49ab202fe55c3581294597d63aec6b;hp=4f79d4b9ed02743c47918a339b2ac395cd40f4f1;hpb=ac85367426b222612311c5cf7b061ff89c64d825;p=sbcl.git

diff --git a/contrib/sb-simple-streams/internal.lisp b/contrib/sb-simple-streams/internal.lisp
index 4f79d4b..a74aabb 100644
--- a/contrib/sb-simple-streams/internal.lisp
+++ b/contrib/sb-simple-streams/internal.lisp
@@ -1,144 +1,20 @@
 ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: STREAM -*-
 
-;;; This code is in the public domain.
+;;; **********************************************************************
+;;; This code was written by Paul Foley and has been placed in the public
+;;; domain.
+;;; 
 
-;;; The cmucl implementation of simple-streams was done by Paul Foley,
-;;; who placed the code in the public domain.  Sbcl port by Rudi
-;;; Schlatte.
+;;; Sbcl port by Rudi Schlatte.
 
 (in-package "SB-SIMPLE-STREAMS")
 
 ;;;
-;;; HELPER FUNCTIONS
+;;; **********************************************************************
 ;;;
-
-;; All known stream flags.  Note that the position in the constant
-;; list is significant (cf. %flags below).
-(sb-int:defconstant-eqx +flag-bits+
-                        '(:simple       ; instance is valid
-                          :input :output ; direction
-                          :dual :string	; type of stream
-                          :eof          ; latched EOF
-                          :dirty        ; output buffer needs write
-                          :interactive) ; interactive stream
-                        #'equal)
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defun %flags (flags)
-    (loop for flag in flags
-	  as pos = (position flag +flag-bits+)
-	when (eq flag :gray) do
-	  (error "Gray streams not supported.")
-	if pos
-	  sum (ash 1 pos) into bits
-	else
-	  collect flag into unused
-      finally (when unused
-		(warn "Invalid stream instance flag~P: ~{~S~^, ~}"
-		      (length unused) unused))
-	      (return bits))))
-
-;;; Setup an environment where sm, funcall-stm-handler and
-;;; funcall-stm-handler-2 are valid and efficient for a stream of type
-;;; class-name or for the stream argument (in which case the
-;;; class-name argument is ignored).  In nested with-stream-class
-;;; forms, the inner with-stream-class form must specify a stream
-;;; argument if the outer one specifies one, or the wrong object will
-;;; be accessed.
-(defmacro with-stream-class ((class-name &optional stream) &body body)
-  (if stream
-      (let ((stm (gensym "STREAM"))
-	    (slt (gensym)))
-	`(let* ((,stm ,stream)
-		(,slt (sb-pcl::std-instance-slots ,stm)))
-	   (declare (type ,class-name ,stm) (ignorable ,slt))
-	   (macrolet ((sm (slot-name stream)
-			(declare (ignore stream))
-			(let ((slot-access (gethash slot-name
-						    *slot-access-functions*)))
-			  (cond ((sb-int:fixnump (cdr slot-access))
-                                 ;; Get value in nth slot
-				 `(the ,(car slot-access)
-				    (sb-pcl::clos-slots-ref ,',slt
-                                                            ,(cdr slot-access))))
-				(slot-access
-                                 ;; Call memorized function
-				 `(the ,(car slot-access) (,(cdr slot-access)
-							    ,',stm)))
-				(t
-                                 ;; Use slot-value
-                                 `(slot-value ,',stm ',slot-name)))))
-		      (add-stream-instance-flags (stream &rest flags)
-			(declare (ignore stream))
-			`(setf (sm %flags ,',stm) (logior (sm %flags ,',stm)
-							  ,(%flags flags))))
-		      (remove-stream-instance-flags (stream &rest flags)
-			(declare (ignore stream))
-			`(setf (sm %flags ,',stm) (logandc2 (sm %flags ,',stm)
-							    ,(%flags flags))))
-		      (any-stream-instance-flags (stream &rest flags)
-			(declare (ignore stream))
-			`(not (zerop (logand (sm %flags ,',stm)
-					     ,(%flags flags))))))
-	     ,@body)))
-      `(macrolet ((sm (slot-name stream)
-		    (let ((slot-access (gethash slot-name
-						*slot-access-functions*)))
-		      (cond ((sb-int:fixnump (cdr slot-access))
-			     `(the ,(car slot-access)
-				(sb-pcl::clos-slots-ref
-				 (sb-pcl::std-instance-slots ,stream)
-				 ,(cdr slot-access))))
-			    (slot-access
-			     `(the ,(car slot-access) (,(cdr slot-access)
-							,stream)))
-			    (t `(slot-value ,stream ',slot-name))))))
-	 ,@body)))
-
-(defmacro sm (slot-name stream)
-  (let ((slot-access (gethash slot-name *slot-access-functions*)))
-    (warn "Using ~S macro outside ~S" 'sm 'with-stream-class)
-    (cond ((sb-int:fixnump (cdr slot-access))
-	   `(the ,(car slot-access) (sb-pcl::clos-slots-ref
-				     (sb-pcl::std-instance-slots ,stream)
-				     ,(cdr slot-access))))
-	  (slot-access
-	   `(the ,(car slot-access) (,(cdr slot-access) ,stream)))
-	  (t `(slot-value ,stream ',slot-name)))))
-
-(defmacro funcall-stm-handler (slot-name stream &rest args)
-  (let ((s (gensym)))
-    `(let ((,s ,stream))
-       (funcall (sm ,slot-name ,s) ,s ,@args))))
-
-(defmacro funcall-stm-handler-2 (slot-name arg1 stream &rest args)
-  (let ((s (gensym)))
-    `(let ((,s ,stream))
-       (funcall (sm ,slot-name ,s) ,arg1 ,s ,@args))))
-
-(defmacro add-stream-instance-flags (stream &rest flags)
-  "Set the given flag bits in STREAM."
-  (let ((s (gensym "STREAM")))
-    `(let ((,s ,stream))
-       (with-stream-class (simple-stream ,s)
-	 (setf (sm %flags ,s) (logior (sm %flags ,s) ,(%flags flags)))))))
-
-(defmacro remove-stream-instance-flags (stream &rest flags)
-  "Clear the given flag bits in STREAM."
-  (let ((s (gensym "STREAM")))
-    `(let ((,s ,stream))
-       (with-stream-class (simple-stream ,s)
-	 (setf (sm %flags ,s) (logandc2 (sm %flags ,s) ,(%flags flags)))))))
-
-(defmacro any-stream-instance-flags (stream &rest flags)
-  "Determine whether any one of the FLAGS is set in STREAM."
-  (let ((s (gensym "STREAM")))
-    `(let ((,s ,stream))
-       (with-stream-class (simple-stream ,s)
-	 (not (zerop (logand (sm %flags ,s) ,(%flags flags))))))))
-
-
-(declaim (inline buffer-sap bref (setf bref) buffer-copy))
+;;; Various functions needed by simple-streams
+(declaim (inline buffer-sap bref (setf bref) buffer-copy
+		 allocate-buffer free-buffer))
 
 (defun buffer-sap (thing &optional offset)
   (declare (type simple-stream-buffer thing) (type (or fixnum null) offset)
@@ -151,21 +27,25 @@
 (defun bref (buffer index)
   (declare (type simple-stream-buffer buffer)
 	   (type (integer 0 #.most-positive-fixnum) index))
-  (sb-sys:sap-ref-8 (buffer-sap buffer) index))
+  (if (vectorp buffer)
+      (sb-sys:sap-ref-8 (sb-sys:vector-sap buffer) index)
+      (sb-sys:sap-ref-8 buffer index)))
 
 (defun (setf bref) (octet buffer index)
   (declare (type (unsigned-byte 8) octet)
 	   (type simple-stream-buffer buffer)
 	   (type (integer 0 #.most-positive-fixnum) index))
-  (setf (sb-sys:sap-ref-8 (buffer-sap buffer) index) octet))
+  (if (vectorp buffer)
+      (setf (sb-sys:sap-ref-8 (sb-sys:vector-sap buffer) index) octet)
+      (setf (sb-sys:sap-ref-8 buffer index) octet)))
 
 (defun buffer-copy (src soff dst doff length)
   (declare (type simple-stream-buffer src dst)
 	   (type fixnum soff doff length))
   (sb-sys:without-gcing ;; is this necessary??
-   (sb-kernel:system-area-copy (buffer-sap src) (* soff 8)
-                               (buffer-sap dst) (* doff 8)
-                               (* length 8))))
+   (sb-kernel:system-area-ub8-copy (buffer-sap src) soff
+                                   (buffer-sap dst) doff
+                                   length)))
 
 (defun allocate-buffer (size)
   (if (= size sb-impl::bytes-per-buffer)
@@ -173,10 +53,410 @@
       (make-array size :element-type '(unsigned-byte 8))))
 
 (defun free-buffer (buffer)
-  (when (not (vectorp buffer))
+  (when (sb-sys:system-area-pointer-p buffer)
     (push buffer sb-impl::*available-buffers*))
   t)
 
+
+(defun make-control-table (&rest inits)
+  (let ((table (make-array 32 :initial-element nil)))
+    (do* ((char (pop inits) (pop inits))
+	  (func (pop inits) (pop inits)))
+	 ((null char))
+      (when (< (char-code char) 32)
+	(setf (aref table (char-code char)) func)))
+    table))
+
+(defun std-newline-out-handler (stream character)
+  (declare (ignore character))
+  (with-stream-class (simple-stream stream)
+    (setf (sm charpos stream) -1)
+    nil))
+
+(defun std-tab-out-handler (stream character)
+  (declare (ignore character))
+  (with-stream-class (simple-stream stream)
+    (let ((col (sm charpos stream)))
+      (when col
+	(setf (sm charpos stream) (1- (* 8 (1+ (floor col 8)))))))
+    nil))
+
+(defun std-dc-newline-in-handler (stream character)
+  (with-stream-class (dual-channel-simple-stream stream)
+    ;; FIXME: Currently, -1 is wrong, since callers of CHARPOS expect
+    ;; a result in (or null (and fixnum unsigned-byte)), so they must
+    ;; never see this temporary value.  Note that in
+    ;; STD-NEWLINE-OUT-HANDLER it is correct to use -1, since CHARPOS
+    ;; is incremented to zero before WRITE-CHAR returns.  Perhaps the
+    ;; same should happen for input?
+    (setf (sm charpos stream) 0) ; was -1
+    character))
+
+(defvar *std-control-out-table*
+  (make-control-table #\Newline #'std-newline-out-handler
+		      #\Tab     #'std-tab-out-handler))
+
+(defvar *default-external-format* :iso8859-1)
+
+(defvar *external-formats* (make-hash-table))
+(defvar *external-format-aliases* (make-hash-table))
+
+(defstruct (external-format
+	     (:conc-name ef-)
+	     (:print-function %print-external-format)
+             (:constructor make-external-format (name octets-to-char
+                                                      char-to-octets)))
+  (name (sb-int:missing-arg) :type keyword :read-only t)
+  (octets-to-char (sb-int:missing-arg) :type function :read-only t)
+  (char-to-octets (sb-int:missing-arg) :type function :read-only t))
+
+(defun %print-external-format (ef stream depth)
+  (declare (ignore depth))
+  (print-unreadable-object (ef stream :type t :identity t)
+    (princ (ef-name ef) stream)))
+
+(defmacro define-external-format (name octets-to-char char-to-octets)
+  `(macrolet ((octets-to-char ((state input unput) &body body)
+	        `(lambda (,state ,input ,unput)
+		   (declare (type (function () (unsigned-byte 8)) ,input)
+			    (type (function (sb-int:index) t) ,unput)
+			    (ignorable ,state ,input ,unput)
+			    (values character sb-int:index t))
+		   ,@body))
+	      (char-to-octets ((char state output) &body body)
+	        `(lambda (,char ,state ,output)
+		   (declare (type character ,char)
+			    (type (function ((unsigned-byte 8)) t) ,output)
+			    (ignorable state ,output)
+			    (values t))
+		   ,@body)))
+     (setf (gethash ,name *external-formats*)
+	   (make-external-format ,name ,octets-to-char ,char-to-octets))))
+
+;;; TODO: make this work
+(defun load-external-format-aliases ()
+  (let ((*package* (find-package "KEYWORD")))
+    (with-open-file (stm "ef:aliases" :if-does-not-exist nil)
+      (when stm
+	(do ((alias (read stm nil stm) (read stm nil stm))
+	     (value (read stm nil stm) (read stm nil stm)))
+	    ((or (eq alias stm) (eq value stm))
+	     (unless (eq alias stm)
+	       (warn "External-format aliases file ends early.")))
+	  (if (and (keywordp alias) (keywordp value))
+	      (setf (gethash alias *external-format-aliases*) value)
+	      (warn "Bad entry in external-format aliases file: ~S => ~S."
+		    alias value)))))))
+
+(defun find-external-format (name &optional (error-p t))
+  (when (external-format-p name)
+    (return-from find-external-format name))
+
+  (when (eq name :default)
+    (setq name *default-external-format*))
+
+  ;; TODO: make this work
+  #+nil
+  (unless (ext:search-list-defined-p "ef:")
+    (setf (ext:search-list "ef:") '("library:ef/")))
+
+  (when (zerop (hash-table-count *external-format-aliases*))
+    (setf (gethash :latin1 *external-format-aliases*) :iso8859-1)
+    (setf (gethash :latin-1 *external-format-aliases*) :iso8859-1)
+    (setf (gethash :iso-8859-1 *external-format-aliases*) :iso8859-1)
+    (load-external-format-aliases))
+
+  (do ((tmp (gethash name *external-format-aliases*)
+	    (gethash tmp *external-format-aliases*))
+       (cnt 0 (1+ cnt)))
+      ((or (null tmp) (= cnt 50))
+       (unless (null tmp)
+	 (error "External-format aliasing depth exceeded.")))
+    (setq name tmp))
+
+  (or (gethash name *external-formats*)
+      (and (let ((*package* (find-package "SB-SIMPLE-STREAMS")))
+	     (load (format nil "ef:~(~A~)" name) :if-does-not-exist nil))
+	   (gethash name *external-formats*))
+      (if error-p (error "External format ~S not found." name) nil)))
+
+(define-condition void-external-format (error)
+  ()
+  (:report
+    (lambda (condition stream)
+      (declare (ignore condition))
+      (format stream "Attempting I/O through void external-format."))))
+
+(define-external-format :void
+    (octets-to-char (state input unput)
+      (declare (ignore state input unput))
+      (error 'void-external-format))
+  (char-to-octets (char state output)
+    (declare (ignore char state output))
+    (error 'void-external-format)))
+
+(define-external-format :iso8859-1
+    (octets-to-char (state input unput)
+      (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
+      (values (code-char (funcall input)) 1 state))
+  (char-to-octets (char state output)
+    (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)))
+    (let ((code (char-code char)))
+      #-(or)
+      (funcall output code)
+      #+(or)
+      (if (< code 256)
+	  (funcall output code)
+	  (funcall output (char-code #\?))))
+    state))
+
+(defmacro octets-to-char (external-format state count input unput)
+  (let ((tmp1 (gensym)) (tmp2 (gensym)) (tmp3 (gensym)))
+    `(multiple-value-bind (,tmp1 ,tmp2 ,tmp3)
+	 (funcall (ef-octets-to-char ,external-format) ,state ,input ,unput)
+       (setf ,state ,tmp3 ,count ,tmp2)
+       ,tmp1)))
+
+(defmacro char-to-octets (external-format char state output)
+  `(progn
+     (setf ,state (funcall (ef-char-to-octets ,external-format)
+			   ,char ,state ,output))
+     nil))
+
+(defun string-to-octets (string &key (start 0) end (external-format :default))
+  (declare (type string string)
+	   (type sb-int:index start)
+	   (type (or null sb-int:index) end))
+  (let ((ef (find-external-format external-format))
+	(buffer (make-array (length string) :element-type '(unsigned-byte 8)))
+	(ptr 0)
+	(state nil))
+    (flet ((out (b)
+	     (setf (aref buffer ptr) b)
+	     (when (= (incf ptr) (length buffer))
+	       (setq buffer (adjust-array buffer (* 2 ptr))))))
+      (dotimes (i (- (or end (length string)) start))
+	(declare (type sb-int:index i))
+	(char-to-octets ef (char string (+ start i)) state #'out))
+      (sb-kernel:shrink-vector buffer ptr))))
+
+(defun octets-to-string (octets &key (start 0) end (external-format :default))
+  (declare (type vector octets)
+	   (type sb-int:index start)
+	   (type (or null sb-int:index) end))
+  (let ((ef (find-external-format external-format))
+	(end (1- (or end (length octets))))
+	(string (make-string (length octets)))
+	(ptr (1- start))
+	(pos -1)
+	(count 0)
+	(state nil))
+    (flet ((input ()
+	     (aref octets (incf ptr)))
+	   (unput (n)
+	     (decf ptr n)))
+      (loop until (>= ptr end)
+	    do (setf (schar string (incf pos))
+		 (octets-to-char ef state count #'input #'unput))))
+    (sb-kernel:shrink-vector string (1+ pos))))
+
+(defun vector-elt-width (vector)
+  ;; Return octet-width of vector elements
+  (etypecase vector
+    ;; (simple-array fixnum (*)) not supported
+    ;; (simple-array base-char (*)) treated specially; don't call this
+    ((simple-array bit (*)) 1)
+    ((simple-array (unsigned-byte 2) (*)) 1)
+    ((simple-array (unsigned-byte 4) (*)) 1)
+    ((simple-array (signed-byte 8) (*)) 1)
+    ((simple-array (unsigned-byte 8) (*)) 1)
+    ((simple-array (signed-byte 16) (*)) 2)
+    ((simple-array (unsigned-byte 16) (*)) 2)
+    ((simple-array (signed-byte 32) (*)) 4)
+    ((simple-array (unsigned-byte 32) (*)) 4)
+    ((simple-array single-float (*)) 4)
+    ((simple-array double-float (*)) 8)
+    ((simple-array (complex single-float) (*)) 8)
+    ((simple-array (complex double-float) (*)) 16)))
+
+#-(or big-endian little-endian)
+(eval-when (:compile-toplevel)
+  (push sb-c::*backend-byte-order* *features*))
+
+(defun endian-swap-value (vector endian-swap)
+  #+big-endian (declare (ignore vector))
+  (case endian-swap
+    (:network-order #+big-endian 0
+		    #+little-endian (1- (vector-elt-width vector)))
+    (:byte-8 0)
+    (:byte-16 1)
+    (:byte-32 3)
+    (:byte-64 7)
+    (:byte-128 15)
+    (otherwise endian-swap)))
+
+#+(or)
+(defun %read-vector (vector stream start end endian-swap blocking)
+  (declare (type (kernel:simple-unboxed-array (*)) vector)
+	   (type stream stream))
+  ;; move code from read-vector
+  )
+
+#+(or)
+(defun %write-vector (... blocking)
+  ;; implement me
+  )
+
+(defun read-octets (stream buffer start end blocking)
+  (declare (type simple-stream stream)
+	   (type (or null simple-stream-buffer) buffer)
+	   (type fixnum start)
+	   (type (or null fixnum) end)
+           (type blocking blocking)
+	   (optimize (speed 3) (space 2) (safety 0) (debug 0)))
+  (with-stream-class (simple-stream stream)
+    (let ((fd (sm input-handle stream))
+	  (end (or end (sm buf-len stream)))
+	  (buffer (or buffer (sm buffer stream))))
+      (declare (fixnum end))
+      (typecase fd
+	(fixnum
+	 (let ((flag (sb-sys:wait-until-fd-usable fd :input
+                                                  (if blocking nil 0))))
+	   (cond
+	     ((and (not blocking) (= start end)) (if flag -3 0))
+	     ((and (not blocking) (not flag)) 0)
+	     (t (block nil
+		  (let ((count 0))
+		    (declare (type fixnum count))
+		    (tagbody
+		     again
+		       ;; Avoid CMUCL gengc write barrier
+		       (do ((i start (+ i (the fixnum #.(sb-posix:getpagesize)))))
+			   ((>= i end))
+			 (declare (type fixnum i))
+			 (setf (bref buffer i) 0))
+		       (setf (bref buffer (1- end)) 0)
+		       (multiple-value-bind (bytes errno)
+			   (sb-unix:unix-read fd (buffer-sap buffer start)
+                                              (the fixnum (- end start)))
+			 (declare (type (or null fixnum) bytes)
+				  (type (integer 0 100) errno))
+			 (when bytes
+			   (incf count bytes)
+			   (incf start bytes))
+			 (cond ((null bytes)
+				(format *debug-io* "~&;; UNIX-READ: errno=~D~%" errno)
+				(cond ((= errno sb-unix:eintr) (go again))
+				      ((and blocking
+					    (or (= errno ;;sb-unix:eagain
+                                                   ;; TODO: move
+                                                   ;; eagain into
+                                                   ;; sb-unix
+                                                   11)
+						(= errno sb-unix:ewouldblock)))
+				       (sb-sys:wait-until-fd-usable fd :input nil)
+				       (go again))
+				      (t (return (- -10 errno)))))
+			       ((zerop count) (return -1))
+			       (t (return count)))))))))))
+	(t (%read-vector buffer fd start end :byte-8
+			 (if blocking :bnb nil)))))))
+
+(defun write-octets (stream buffer start end blocking)
+  (declare (type simple-stream stream)
+	   (type simple-stream-buffer buffer)
+	   (type fixnum start)
+	   (type (or null fixnum) end))
+  (with-stream-class (simple-stream stream)
+    (when (sm handler stream)
+      (do ()
+	  ((null (sm pending stream)))
+	(sb-sys:serve-all-events)))
+
+    (let ((fd (sm output-handle stream))
+	  (end (or end (length buffer))))
+      (typecase fd
+	(fixnum
+	 (let ((flag (sb-sys:wait-until-fd-usable fd :output
+                                                  (if blocking nil 0))))
+	   (cond
+	     ((and (not blocking) (= start end)) (if flag -3 0))
+	     ((and (not blocking) (not flag)) 0)
+	     (t
+	      (block nil
+		(let ((count 0))
+		  (tagbody again
+		     (multiple-value-bind (bytes errno)
+			 (sb-unix:unix-write fd (buffer-sap buffer) start
+					  (- end start))
+		       (when bytes
+			 (incf count bytes)
+			 (incf start bytes))
+		       (cond ((null bytes)
+			      (format *debug-io* "~&;; UNIX-WRITE: errno=~D~%" errno)
+			      (cond ((= errno sb-unix:eintr) (go again))
+				    ;; don't block for subsequent chars
+				    (t (return (- -10 errno)))))
+			     (t (return count)))))))))))
+	(t (error "implement me"))))))
+
+(defun do-some-output (stream)
+  ;; Do some pending output; return T if completed, NIL if more to do
+  (with-stream-class (simple-stream stream)
+    (let ((fd (sm output-handle stream)))
+      (loop
+	(let ((list (pop (sm pending stream))))
+	  (unless list
+	    (sb-sys:remove-fd-handler (sm handler stream))
+	    (setf (sm handler stream) nil)
+	    (return t))
+	  (let* ((buffer (first list))
+		 (start (second list))
+		 (end (third list))
+		 (len (- end start)))
+	    (declare (type simple-stream-buffer buffer)
+		     (type sb-int:index start end len))
+	    (tagbody again
+	       (multiple-value-bind (bytes errno)
+		   (sb-unix:unix-write fd (buffer-sap buffer) start len)
+		 (cond ((null bytes)
+			(if (= errno sb-unix:eintr)
+			    (go again)
+			    (progn (push list (sm pending stream))
+				   (return nil))))
+		       ((< bytes len)
+			(setf (second list) (+ start bytes))
+			(push list (sm pending stream))
+			(return nil))
+		       ((= bytes len)
+			(free-buffer buffer)))))))))))
+
+(defun queue-write (stream buffer start end)
+  ;; Queue a write; return T if buffer needs changing, NIL otherwise
+  (declare (type simple-stream stream)
+	   (type simple-stream-buffer buffer)
+	   (type sb-int:index start end))
+  (with-stream-class (simple-stream stream)
+    (when (sm handler stream)
+      (unless (do-some-output stream)
+	(let ((last (last (sm pending stream))))
+	  (setf (cdr last) (list (list buffer start end)))
+	  (return-from queue-write t))))
+    (let ((bytes (write-octets stream buffer start end nil)))
+      (unless (or (= bytes (- end start)) ; completed
+		  (= bytes -3))	; empty buffer; shouldn't happen
+	(setf (sm pending stream) (list (list buffer start end)))
+	(setf (sm handler stream)
+	      (sb-sys:add-fd-handler (sm output-handle stream) :output
+                                     (lambda (fd)
+                                       (declare (ignore fd))
+                                       (do-some-output stream))))
+	t))))
+
+
+
+
 (defun %fd-open (pathname direction if-exists if-exists-given
 			  if-does-not-exist if-does-not-exist-given)
   (declare (type pathname pathname)
@@ -193,6 +473,8 @@
     (declare (type sb-int:index mask))
     (let ((name (cond ((sb-int:unix-namestring pathname input))
 		      ((and input (eq if-does-not-exist :create))
+		       (sb-int:unix-namestring pathname nil))
+		      ((and (eq direction :io) (not if-does-not-exist-given))
 		       (sb-int:unix-namestring pathname nil)))))
       ;; Process if-exists argument if we are doing any output.
       (cond (output
@@ -202,14 +484,12 @@
 			 :new-version
 			 :error)))
 	     (case if-exists
-	       ((:error nil)
+	       ((:error nil :new-version)
 		(setf mask (logior mask sb-unix:o_excl)))
 	       ((:rename :rename-and-delete)
 		(setf mask (logior mask sb-unix:o_creat)))
-	       ((:new-version :supersede)
-		(setf mask (logior mask sb-unix:o_trunc)))
-	       (:append
-		(setf mask (logior mask sb-unix:o_append)))))
+	       ((:supersede)
+		(setf mask (logior mask sb-unix:o_trunc)))))
 	    (t
 	     (setf if-exists nil)))	; :ignore-this-arg
       (unless if-does-not-exist-given
@@ -282,6 +562,8 @@
 		  (sb-unix:unix-open name mask mode)
 		  (values nil sb-unix:enoent))
 	    (cond ((sb-int:fixnump fd)
+                   (when (eql if-exists :append)
+                     (sb-unix:unix-lseek fd 0 sb-unix:l_xtnd))
 		   (return (values fd name original delete-original)))
 		  ((eql errno sb-unix:enoent)
 		   (case if-does-not-exist
@@ -341,50 +623,30 @@
 			 :overwrite :append :supersede nil) if-exists)
 	   (type (member :error :create nil) if-does-not-exist)
 	   (ignore external-format))
-  (setq pathname (pathname pathname))
-  (multiple-value-bind (fd namestring original delete-original)
-      (%fd-open pathname direction if-exists if-exists-given
-		if-does-not-exist if-does-not-exist-given)
-    (when fd
-      (case direction
-	((:input :output :io)
-	 (sb-sys:make-fd-stream fd
-                                :input (member direction '(:input :io))
-                                :output (member direction '(:output :io))
-                                :element-type element-type
-                                :file namestring
-                                :original original
-                                :delete-original delete-original
-                                :pathname pathname
-                                :input-buffer-p t
-                                :auto-close t))
-	(:probe
-	 (let ((stream (sb-impl::%make-fd-stream :name namestring :fd fd
-                                                 :pathname pathname
-                                                 :element-type element-type)))
-	   (close stream)
-	   stream))))))
-
-
-;; Make PATHNAME and NAMESTRING work
-(defun cl::file-name (stream &optional new-name)
-  (typecase stream
-    (file-simple-stream
-     (with-stream-class (file-simple-stream stream)
-       (cond (new-name
-	      (setf (sm pathname stream) new-name)
-	      (setf (sm filename stream) (sb-int:unix-namestring new-name nil))
-	      t)
-	     (t
-	      (sm pathname stream)))))
-    (sb-sys::file-stream
-     (cond (new-name
-	    (setf (sb-impl::fd-stream-pathname stream) new-name)
-	    (setf (sb-impl::fd-stream-file stream)
-		  (sb-int:unix-namestring new-name nil))
-	    t)
-	   (t
-	    (sb-impl::fd-stream-pathname stream))))))
+  (let ((filespec (merge-pathnames pathname)))
+    (multiple-value-bind (fd namestring original delete-original)
+        (%fd-open filespec direction if-exists if-exists-given
+                  if-does-not-exist if-does-not-exist-given)
+      (when fd
+        (case direction
+          ((:input :output :io)
+           (sb-sys:make-fd-stream fd
+                                  :input (member direction '(:input :io))
+                                  :output (member direction '(:output :io))
+                                  :element-type element-type
+                                  :file namestring
+                                  :original original
+                                  :delete-original delete-original
+                                  :pathname pathname
+                                  :input-buffer-p t
+                                  :auto-close t))
+          (:probe
+           (let ((stream (sb-impl::%make-fd-stream :name namestring :fd fd
+                                                   :pathname pathname
+                                                   :element-type element-type)))
+             (close stream)
+             stream)))))))
+
 
 ;; Experimental "filespec" stuff