1.0.30.41: Octets support for ebcdic-us

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

diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index 825933b..4c978bc 100644 (file)
--- a/src/code/fd-stream.lisp
+++ b/src/code/fd-stream.lisp
@@ -1678,38 +1678,6 @@
       (setf (sap-ref-8 sap tail) bits))
   (code-char byte))
 
-(let* ((table (let ((s (make-string 256)))
-                (map-into s #'code-char
-                          '(#x00 #x01 #x02 #x03 #x9c #x09 #x86 #x7f #x97 #x8d #x8e #x0b #x0c #x0d #x0e #x0f
-                            #x10 #x11 #x12 #x13 #x9d #x85 #x08 #x87 #x18 #x19 #x92 #x8f #x1c #x1d #x1e #x1f
-                            #x80 #x81 #x82 #x83 #x84 #x0a #x17 #x1b #x88 #x89 #x8a #x8b #x8c #x05 #x06 #x07
-                            #x90 #x91 #x16 #x93 #x94 #x95 #x96 #x04 #x98 #x99 #x9a #x9b #x14 #x15 #x9e #x1a
-                            #x20 #xa0 #xe2 #xe4 #xe0 #xe1 #xe3 #xe5 #xe7 #xf1 #xa2 #x2e #x3c #x28 #x2b #x7c
-                            #x26 #xe9 #xea #xeb #xe8 #xed #xee #xef #xec #xdf #x21 #x24 #x2a #x29 #x3b #xac
-                            #x2d #x2f #xc2 #xc4 #xc0 #xc1 #xc3 #xc5 #xc7 #xd1 #xa6 #x2c #x25 #x5f #x3e #x3f
-                            #xf8 #xc9 #xca #xcb #xc8 #xcd #xce #xcf #xcc #x60 #x3a #x23 #x40 #x27 #x3d #x22
-                            #xd8 #x61 #x62 #x63 #x64 #x65 #x66 #x67 #x68 #x69 #xab #xbb #xf0 #xfd #xfe #xb1
-                            #xb0 #x6a #x6b #x6c #x6d #x6e #x6f #x70 #x71 #x72 #xaa #xba #xe6 #xb8 #xc6 #xa4
-                            #xb5 #x7e #x73 #x74 #x75 #x76 #x77 #x78 #x79 #x7a #xa1 #xbf #xd0 #xdd #xde #xae
-                            #x5e #xa3 #xa5 #xb7 #xa9 #xa7 #xb6 #xbc #xbd #xbe #x5b #x5d #xaf #xa8 #xb4 #xd7
-                            #x7b #x41 #x42 #x43 #x44 #x45 #x46 #x47 #x48 #x49 #xad #xf4 #xf6 #xf2 #xf3 #xf5
-                            #x7d #x4a #x4b #x4c #x4d #x4e #x4f #x50 #x51 #x52 #xb9 #xfb #xfc #xf9 #xfa #xff
-                            #x5c #xf7 #x53 #x54 #x55 #x56 #x57 #x58 #x59 #x5a #xb2 #xd4 #xd6 #xd2 #xd3 #xd5
-                            #x30 #x31 #x32 #x33 #x34 #x35 #x36 #x37 #x38 #x39 #xb3 #xdb #xdc #xd9 #xda #x9f))
-                s))
-       (reverse-table (let ((rt (make-array 256 :element-type '(unsigned-byte 8) :initial-element 0)))
-                          (loop for char across table for i from 0
-                               do (aver (= 0 (aref rt (char-code char))))
-                               do (setf (aref rt (char-code char)) i))
-                          rt)))
-  (define-external-format (:ebcdic-us :ibm-037 :ibm037)
-      1 t
-    (if (>= bits 256)
-        (external-format-encoding-error stream bits)
-        (setf (sap-ref-8 sap tail) (aref reverse-table bits)))
-    (aref table byte)))
-
-
 #!+sb-unicode
 (let ((latin-9-table (let ((table (make-string 256)))
                        (do ((i 0 (1+ i)))
@@ -2405,13 +2373,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
@@ -2476,7 +2448,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)))
@@ -2629,7 +2601,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)))))