X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=4c978bc7be66a7523174538dfa9fdbe1e4e81429;hb=d442c23da9851beac541b8bddfc2c0837cb87309;hp=8d369bdd59982b7bf25b2237026c6cb1973a66a1;hpb=de7e68bb937622ca7fe99a1acbf26703b7695cc7;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 8d369bd..4c978bc 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -70,8 +70,8 @@ ;; ;; ...again, once we have smarted locks the spinlock here can become ;; a mutex. - `(sb!thread::call-with-system-spinlock (lambda () ,@body) - *available-buffers-spinlock*)) + `(sb!thread::with-system-spinlock (*available-buffers-spinlock*) + ,@body)) (defconstant +bytes-per-buffer+ (* 4 1024) #!+sb-doc @@ -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) @@ -418,12 +421,14 @@ (defun stream-decoding-error (stream octets) (error 'stream-decoding-error + :external-format (stream-external-format stream) :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 + :external-format (stream-external-format stream) :stream stream :code code)) @@ -450,7 +455,7 @@ (attempt-resync () :report (lambda (stream) (format stream - "~@")) (fd-stream-resync stream) nil) @@ -821,10 +826,10 @@ ;;; correct on win32. However, none of the places that use it require ;;; further assurance than "may" versus "will definitely not". (defun sysread-may-block-p (stream) - #+win32 + #!+win32 ;; This answers T at EOF on win32, I think. (not (sb!win32:fd-listen (fd-stream-fd stream))) - #-win32 + #!-win32 (sb!unix:with-restarted-syscall (count errno) (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set))) (sb!unix:fd-zero read-fds) @@ -844,10 +849,9 @@ ;;; then fill the input buffer, and return the number of bytes read. Throws ;;; to EOF-INPUT-CATCHER if the eof was reached. (defun refill-input-buffer (stream) - (let ((fd (fd-stream-fd stream)) - (errno 0) - (count 0)) - (declare (dynamic-extent fd errno count)) + (dx-let ((fd (fd-stream-fd stream)) + (errno 0) + (count 0)) (tagbody ;; Check for blocking input before touching the stream, as if ;; we happen to wait we are liable to be interrupted, and the @@ -1674,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))) @@ -2040,10 +2012,24 @@ (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 - (cond (arg1 ; We got us an abort on our hands. + ;; Drop input buffers + (setf (ansi-stream-in-index fd-stream) +ansi-stream-in-buffer-length+ + (ansi-stream-cin-buffer fd-stream) nil + (ansi-stream-in-buffer fd-stream) nil) + (cond (arg1 + ;; We got us an abort on our hands. (let ((outputp (fd-stream-obuf fd-stream)) (file (fd-stream-file fd-stream)) (orig (fd-stream-original fd-stream))) @@ -2309,6 +2295,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 @@ -2380,19 +2367,23 @@ ;; Calculate useful stuff. (multiple-value-bind (input output mask) - (case direction + (ecase direction (:input (values t nil sb!unix:o_rdonly)) (:output (values nil t sb!unix:o_wronly)) (: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 @@ -2457,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))) @@ -2610,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)))))