X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=9c8ac6b9cb70728ba291db32c5570e2e4a2dcb5f;hb=64ed946d513d0cd0508fea90cd3b44328e75df9a;hp=771cd10e7c2cfbaeea272a13c5b6a1bf93900a5a;hpb=e7ef1082bd3e7f3851de9d90c5dbddf226a71382;p=sbcl.git

diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index 771cd10..9c8ac6b 100644
--- a/src/code/fd-stream.lisp
+++ b/src/code/fd-stream.lisp
@@ -187,7 +187,10 @@
   (external-format :default)
   ;; fixed width, or function to call with a character
   (char-size 1 :type (or fixnum function))
-  (output-bytes #'ill-out :type function))
+  (output-bytes #'ill-out :type function)
+  ;; a boolean indicating whether the stream is bivalent.  For
+  ;; internal use only.
+  (bivalent-p nil :type boolean))
 (def!method print-object ((fd-stream fd-stream) stream)
   (declare (type stream stream))
   (print-unreadable-object (fd-stream stream :type t :identity t)
@@ -2041,7 +2044,16 @@
                                  (do-listen)))))))
        (do-listen)))
     (:unread
-     (setf (fd-stream-unread fd-stream) arg1)
+     ;; If the stream is bivalent, the user might follow an
+     ;; unread-char with a read-byte.  In this case, the bookkeeping
+     ;; is simpler if we adjust the buffer head by the number of code
+     ;; units in the character.
+     ;; FIXME: there has to be a proper way to check for bivalence,
+     ;; right?
+     (if (fd-stream-bivalent-p fd-stream)
+         (decf (buffer-head (fd-stream-ibuf fd-stream))
+               (fd-stream-character-size fd-stream arg1))
+         (setf (fd-stream-unread fd-stream) arg1))
      (setf (fd-stream-listen fd-stream) t))
     (:close
      ;; Drop input buffers
@@ -2315,6 +2327,7 @@
                                  :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)
                                  :timeout
                                  (if timeout
@@ -2392,13 +2405,17 @@
         (:io     (values   t   t sb!unix:o_rdwr))
         (:probe  (values   t nil sb!unix:o_rdonly)))
     (declare (type index mask))
-    (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)))))
+    (let* (;; PATHNAME is the pathname we associate with the stream.
+           (pathname (merge-pathnames filename))
+           (physical (physicalize-pathname pathname))
+           (truename (probe-file physical))
+           ;; NAMESTRING is the native namestring we open the file with.
+           (namestring (cond (truename
+                              (native-namestring truename :as-file t))
+                             ((or (not input)
+                                  (and input (eq if-does-not-exist :create))
+                                  (and (eq direction :io) (not if-does-not-exist-given)))
+                              (native-namestring physical :as-file t)))))
       ;; Process if-exists argument if we are doing any output.
       (cond (output
              (unless if-exists-given
@@ -2463,7 +2480,7 @@
                           (when (and output (= (logand orig-mode #o170000)
                                                #o40000))
                             (error 'simple-file-error
-                                   :pathname namestring
+                                   :pathname pathname
                                    :format-control
                                    "can't open ~S for output: is a directory"
                                    :format-arguments (list namestring)))
@@ -2616,7 +2633,8 @@
       (cond (new-name
              (setf (fd-stream-pathname stream) new-name)
              (setf (fd-stream-file stream)
-                   (unix-namestring new-name nil))
+                   (native-namestring (physicalize-pathname new-name)
+                                      :as-file t))
              t)
             (t
              (fd-stream-pathname stream)))))