X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=e74eb220f85bb5ea76a8622f53117f9068c7af33;hb=0c3bbfaa2286626a2d915c8810f690aefc702661;hp=a2940e14176b8d94c6725526043fe3e9268a1d29;hpb=765a042b5f968f285d8bd4a4ea1e897ca29abc8d;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index a2940e1..e74eb22 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -52,25 +52,16 @@ #!+sb-doc "List of available buffers.") -(defvar *available-buffers-spinlock* (sb!thread::make-spinlock - :name "lock for *AVAILABLE-BUFFERS*") +(defvar *available-buffers-lock* (sb!thread:make-mutex + :name "lock for *AVAILABLE-BUFFERS*") #!+sb-doc "Mutex for access to *AVAILABLE-BUFFERS*.") (defmacro with-available-buffers-lock ((&optional) &body body) - ;; CALL-WITH-SYSTEM-SPINLOCK because - ;; - ;; 1. streams are low-level enough to be async signal safe, and in - ;; particular a C-c that brings up the debugger while holding the - ;; mutex would lose badly - ;; - ;; 2. this can potentially be a fairly busy (but also probably - ;; uncontended) lock, so we don't want to pay the syscall per - ;; release -- hence a spinlock. - ;; - ;; ...again, once we have smarted locks the spinlock here can become - ;; a mutex. - `(sb!thread::with-system-spinlock (*available-buffers-spinlock*) + ;; CALL-WITH-SYSTEM-MUTEX because streams are low-level enough to be + ;; async signal safe, and in particular a C-c that brings up the + ;; debugger while holding the mutex would lose badly. + `(sb!thread::with-system-mutex (*available-buffers-lock*) ,@body)) (defconstant +bytes-per-buffer+ (* 4 1024) @@ -156,7 +147,9 @@ ;; the type of element being transfered (element-type 'base-char) ;; the Unix file descriptor - (fd -1 :type fixnum) + (fd -1 :type #!-win32 fixnum #!+win32 sb!vm:signed-word) + ;; What do we know about the FD? + (fd-type :unknown :type keyword) ;; controls when the output buffer is flushed (buffering :full :type (member :full :line :none)) ;; controls whether the input buffer must be cleared before output @@ -289,14 +282,16 @@ (return (reset-buffer obuf))) (count ;; Partial write -- update buffer status and - ;; queue or wait. Do not use INCF! Another - ;; thread might have moved head... - (setf (buffer-head obuf) (+ count head)) + ;; queue or wait. + (incf head count) + (setf (buffer-head obuf) head) (queue-or-wait)) #!-win32 ((eql errno sb!unix:ewouldblock) ;; Blocking, queue or wair. (queue-or-wait)) + ;; if interrupted on win32, just try again + #!+win32 ((eql errno sb!unix:eintr)) (t (simple-stream-perror "Couldn't write to ~s" stream errno))))))))))))) @@ -407,14 +402,10 @@ ;;; this is not something we want to export. Nikodemus thinks the ;;; right thing is to support a low-level non-stream like IO layer, ;;; akin to java.nio. -(defun output-raw-bytes (stream thing &optional start end) +(declaim (inline output-raw-bytes)) +(define-deprecated-function :late "1.0.8.16" output-raw-bytes write-sequence + (stream thing &optional start end) (write-or-buffer-output stream thing (or start 0) (or end (length thing)))) - -(define-compiler-macro output-raw-bytes (stream thing &optional start end) - (deprecation-warning 'output-raw-bytes) - (let ((x (gensym "THING"))) - `(let ((,x ,thing)) - (write-or-buffer-output ,stream ,x (or ,start 0) (or ,end (length ,x)))))) ;;;; output routines and related noise @@ -437,39 +428,26 @@ :format-arguments (list note-format (list pathname) (strerror errno)))) -(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)) - (defun c-string-encoding-error (external-format code) (error 'c-string-encoding-error :external-format external-format :code code)) - -(defun c-string-decoding-error (external-format octets) +(defun c-string-decoding-error (external-format sap offset count) (error 'c-string-decoding-error :external-format external-format - :octets octets)) + :octets (sap-ref-octets sap offset count))) ;;; Returning true goes into end of file handling, false will enter another ;;; round of input buffer filling followed by re-entering character decode. (defun stream-decoding-error-and-handle (stream octet-count) (restart-case - (stream-decoding-error stream - (let* ((buffer (fd-stream-ibuf stream)) - (sap (buffer-sap buffer)) - (head (buffer-head buffer))) - (loop for i from 0 below octet-count - collect (sap-ref-8 sap (+ head i))))) + (error 'stream-decoding-error + :external-format (stream-external-format stream) + :stream stream + :octets (let ((buffer (fd-stream-ibuf stream))) + (sap-ref-octets (buffer-sap buffer) + (buffer-head buffer) + octet-count))) (attempt-resync () :report (lambda (stream) (format stream @@ -501,7 +479,10 @@ (defun stream-encoding-error-and-handle (stream code) (restart-case - (stream-encoding-error stream code) + (error 'stream-encoding-error + :external-format (stream-external-format stream) + :stream stream + :code code) (output-nothing () :report (lambda (stream) (format stream "~@")) @@ -544,7 +525,7 @@ (tail (buffer-tail obuf)) (size ,size)) ,(unless (eq (car buffering) :none) - `(when (<= (buffer-length obuf) (+ tail size)) + `(when (< (buffer-length obuf) (+ tail size)) (setf obuf (flush-output-buffer ,stream-var) tail (buffer-tail obuf)))) ,(unless (eq (car buffering) :none) @@ -571,28 +552,28 @@ `(let* ((,stream-var ,stream) (obuf (fd-stream-obuf ,stream-var)) (tail (buffer-tail obuf))) - ,(unless (eq (car buffering) :none) - `(when (<= (buffer-length obuf) (+ tail ,size)) - (setf obuf (flush-output-buffer ,stream-var) - tail (buffer-tail obuf)))) - ;; FIXME: Why this here? Doesn't seem necessary. - ,(unless (eq (car buffering) :none) - `(synchronize-stream-output ,stream-var)) - ,(if restart - `(catch 'output-nothing - ,@body - (setf (buffer-tail obuf) (+ tail ,size))) - `(progn - ,@body - (setf (buffer-tail obuf) (+ tail ,size)))) - ,(ecase (car buffering) - (:none - `(flush-output-buffer ,stream-var)) - (:line - `(when (eql byte #\Newline) - (flush-output-buffer ,stream-var))) - (:full)) - (values)))) + ,(unless (eq (car buffering) :none) + `(when (< (buffer-length obuf) (+ tail ,size)) + (setf obuf (flush-output-buffer ,stream-var) + tail (buffer-tail obuf)))) + ;; FIXME: Why this here? Doesn't seem necessary. + ,(unless (eq (car buffering) :none) + `(synchronize-stream-output ,stream-var)) + ,(if restart + `(catch 'output-nothing + ,@body + (setf (buffer-tail obuf) (+ tail ,size))) + `(progn + ,@body + (setf (buffer-tail obuf) (+ tail ,size)))) + ,(ecase (car buffering) + (:none + `(flush-output-buffer ,stream-var)) + (:line + `(when (eql byte #\Newline) + (flush-output-buffer ,stream-var))) + (:full)) + (values)))) (defmacro def-output-routines/variable-width ((name-fmt size restart external-format &rest bufferings) @@ -973,12 +954,13 @@ (errno 0) (count 0)) (tagbody + #!+win32 + (go :main) + ;; Check for blocking input before touching the stream if we are to - ;; serve events: if the FD is blocking, we don't want to hang on the - ;; write if we are to serve events or notice timeouts. - (if (and (or (fd-stream-serve-events stream) - (fd-stream-timeout stream) - *deadline*) + ;; serve events: if the FD is blocking, we don't want to try an uninterruptible + ;; read(). Regular files should never block, so we can elide the check. + (if (and (neq :regular (fd-stream-fd-type stream)) (sysread-may-block-p stream)) (go :wait-for-input) (go :main)) @@ -1007,7 +989,7 @@ ((lambda (return-reason) (ecase return-reason ((nil)) ; fast path normal cases - ((:wait-for-input) (go :wait-for-input)) + ((:wait-for-input) (go #!-win32 :wait-for-input #!+win32 :main)) ((:closed-flame) (go :closed-flame)) ((:read-error) (go :read-error)))) (without-interrupts @@ -1043,10 +1025,9 @@ (setf (values count errno) (sb!unix:unix-read fd (sap+ sap tail) (- length tail))) (cond ((null count) - #!+win32 - (return :read-error) - #!-win32 - (if (eql errno sb!unix:ewouldblock) + (if (eql errno + #!+win32 sb!unix:eintr + #!-win32 sb!unix:ewouldblock) (return :wait-for-input) (return :read-error))) ((zerop count) @@ -1102,7 +1083,9 @@ (catch 'eof-input-catcher (setf decode-break-reason (block decode-break-reason - (input-at-least ,stream-var ,(if (consp bytes) (car bytes) `(setq size ,bytes))) + (input-at-least ,stream-var ,(if (consp bytes) + (car bytes) + `(setq size ,bytes))) (let* ((byte (sap-ref-8 (buffer-sap ibuf) (buffer-head ibuf)))) (declare (ignorable byte)) ,@(when (consp bytes) @@ -1602,12 +1585,15 @@ (setf decode-break-reason (block decode-break-reason (setf byte (sap-ref-8 sap head) - size ,(if (consp in-size-expr) (cadr in-size-expr) in-size-expr) + size ,(if (consp in-size-expr) + (cadr in-size-expr) + in-size-expr) char ,in-expr) (incf head size) nil)) (when decode-break-reason - (c-string-decoding-error ,name decode-break-reason)) + (c-string-decoding-error + ,name sap head decode-break-reason)) (when (zerop (char-code char)) (return count)))) (string (make-string length :element-type element-type))) @@ -1621,12 +1607,15 @@ (setf decode-break-reason (block decode-break-reason (setf byte (sap-ref-8 sap head) - size ,(if (consp in-size-expr) (cadr in-size-expr) in-size-expr) + size ,(if (consp in-size-expr) + (cadr in-size-expr) + in-size-expr) char ,in-expr) (incf head size) nil)) (when decode-break-reason - (c-string-decoding-error ,name decode-break-reason)) + (c-string-decoding-error + ,name sap head decode-break-reason)) (setf (aref string index) char))))) (defun ,output-c-string-function (string) @@ -2037,8 +2026,8 @@ (:external-format (fd-stream-external-format fd-stream)) (:interactive-p - (= 1 (the (member 0 1) - (sb!unix:unix-isatty (fd-stream-fd fd-stream))))) + (plusp (the (integer 0) + (sb!unix:unix-isatty (fd-stream-fd fd-stream))))) (:line-length 80) (:charpos @@ -2054,6 +2043,7 @@ :expected-type 'fd-stream :format-control "~S is not a stream associated with a file." :format-arguments (list fd-stream))) + #!-win32 (multiple-value-bind (okay dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks) (sb!unix:unix-fstat (fd-stream-fd fd-stream)) @@ -2063,7 +2053,21 @@ (simple-stream-perror "failed Unix fstat(2) on ~S" fd-stream dev)) (if (zerop mode) nil - (truncate size (fd-stream-element-size fd-stream))))) + (truncate size (fd-stream-element-size fd-stream)))) + #!+win32 + (let* ((handle (fd-stream-fd fd-stream)) + (element-size (fd-stream-element-size fd-stream))) + (multiple-value-bind (got native-size) + (sb!win32:get-file-size-ex handle 0) + (if (zerop got) + ;; Might be a block device, in which case we fall back to + ;; a non-atomic workaround: + (let* ((here (sb!unix:unix-lseek handle 0 sb!unix:l_incr)) + (there (sb!unix:unix-lseek handle 0 sb!unix:l_xtnd))) + (when (and here there) + (sb!unix:unix-lseek handle here sb!unix:l_set) + (truncate there element-size))) + (truncate native-size element-size))))) (:file-string-length (etypecase arg1 (character (fd-stream-character-size fd-stream arg1)) @@ -2097,7 +2101,7 @@ (declare (fd-stream stream)) (without-interrupts (let ((posn (sb!unix:unix-lseek (fd-stream-fd stream) 0 sb!unix:l_incr))) - (declare (type (or (alien sb!unix:off-t) null) posn)) + (declare (type (or (alien sb!unix:unix-offset) null) posn)) ;; We used to return NIL for errno==ESPIPE, and signal an error ;; in other failure cases. However, CLHS says to return NIL if ;; the position cannot be determined -- so that's what we do. @@ -2126,7 +2130,7 @@ (defun fd-stream-set-file-position (stream position-spec) (declare (fd-stream stream)) (check-type position-spec - (or (alien sb!unix:off-t) (member nil :start :end)) + (or (alien sb!unix:unix-offset) (member nil :start :end)) "valid file position designator") (tagbody :again @@ -2158,7 +2162,7 @@ (t (values (* position-spec (fd-stream-element-size stream)) sb!unix:l_set))) - (declare (type (alien sb!unix:off-t) offset)) + (declare (type (alien sb!unix:unix-offset) offset)) (let ((posn (sb!unix:unix-lseek (fd-stream-fd stream) offset origin))) ;; CLHS says to return true if the file-position was set @@ -2170,7 +2174,7 @@ ;; FIXME: We are still liable to signal an error if flushing ;; output fails. (return-from fd-stream-set-file-position - (typep posn '(alien sb!unix:off-t)))))))) + (typep posn '(alien sb!unix:unix-offset)))))))) ;;;; creation routines (MAKE-FD-STREAM and OPEN) @@ -2221,6 +2225,12 @@ ((not (or input output)) (error "File descriptor must be opened either for input or output."))) (let ((stream (%make-fd-stream :fd fd + :fd-type (progn + #!-win32 (sb!unix:fd-type fd) + ;; KLUDGE. + #!+win32 (if serve-events + :unknown + :regular)) :name name :file file :original original @@ -2279,12 +2289,12 @@ (defun open (filename &key - (direction :input) - (element-type 'base-char) - (if-exists nil if-exists-given) - (if-does-not-exist nil if-does-not-exist-given) - (external-format :default) - &aux ; Squelch assignment warning. + (direction :input) + (element-type 'base-char) + (if-exists nil if-exists-given) + (if-does-not-exist nil if-does-not-exist-given) + (external-format :default) + &aux ; Squelch assignment warning. (direction direction) (if-does-not-exist if-does-not-exist) (if-exists if-exists)) @@ -2306,7 +2316,7 @@ (:io (values t t sb!unix:o_rdwr)) (:probe (values t nil sb!unix:o_rdonly))) (declare (type index mask)) - (let* (;; PATHNAME is the pathname we associate with the stream. + (let* ( ;; PATHNAME is the pathname we associate with the stream. (pathname (merge-pathnames filename)) (physical (physicalize-pathname pathname)) (truename (probe-file physical)) @@ -2315,145 +2325,172 @@ (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))) + (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 - (setf if-exists - (if (eq (pathname-version pathname) :newest) - :new-version - :error))) - (ensure-one-of if-exists - '(:error :new-version :rename - :rename-and-delete :overwrite - :append :supersede nil) - :if-exists) - (case if-exists - ((:new-version :error nil) - (setf mask (logior mask sb!unix:o_excl))) - ((:rename :rename-and-delete) - (setf mask (logior mask sb!unix:o_creat))) - ((:supersede) - (setf mask (logior mask sb!unix:o_trunc))) - (:append - (setf mask (logior mask sb!unix:o_append))))) - (t - (setf if-exists :ignore-this-arg))) - - (unless if-does-not-exist-given - (setf if-does-not-exist - (cond ((eq direction :input) :error) - ((and output - (member if-exists '(:overwrite :append))) - :error) - ((eq direction :probe) + (flet ((open-error (format-control &rest format-arguments) + (error 'simple-file-error + :pathname pathname + :format-control format-control + :format-arguments format-arguments))) + ;; Process if-exists argument if we are doing any output. + (cond (output + (unless if-exists-given + (setf if-exists + (if (eq (pathname-version pathname) :newest) + :new-version + :error))) + (ensure-one-of if-exists + '(:error :new-version :rename + :rename-and-delete :overwrite + :append :supersede nil) + :if-exists) + (case if-exists + ((:new-version :error nil) + (setf mask (logior mask sb!unix:o_excl))) + ((:rename :rename-and-delete) + (setf mask (logior mask sb!unix:o_creat))) + ((:supersede) + (setf mask (logior mask sb!unix:o_trunc))) + (:append + (setf mask (logior mask sb!unix:o_append))))) + (t + (setf if-exists :ignore-this-arg))) + + (unless if-does-not-exist-given + (setf if-does-not-exist + (cond ((eq direction :input) :error) + ((and output + (member if-exists '(:overwrite :append))) + :error) + ((eq direction :probe) + nil) + (t + :create)))) + (ensure-one-of if-does-not-exist + '(:error :create nil) + :if-does-not-exist) + (cond ((and if-exists-given + truename + (eq if-exists :new-version)) + (open-error "OPEN :IF-EXISTS :NEW-VERSION is not supported ~ + when a new version must be created.")) + ((eq if-does-not-exist :create) + (setf mask (logior mask sb!unix:o_creat))) + ((not (member if-exists '(:error nil)))) + ;; Both if-does-not-exist and if-exists now imply + ;; that there will be no opening of files, and either + ;; an error would be signalled, or NIL returned + ((and (not if-exists) (not if-does-not-exist)) + (return-from open)) + ((and if-exists if-does-not-exist) + (open-error "OPEN :IF-DOES-NOT-EXIST ~s ~ + :IF-EXISTS ~s will always signal an error." + if-does-not-exist if-exists)) + (truename + (if if-exists + (open-error "File exists ~s." pathname) + (return-from open))) + (if-does-not-exist + (open-error "File does not exist ~s." pathname)) + (t + (return-from open))) + (let ((original (case if-exists + ((:rename :rename-and-delete) + (pick-backup-name namestring)) + ((:append :overwrite) + ;; KLUDGE: Prevent CLOSE from deleting + ;; appending streams when called with :ABORT T + namestring))) + (delete-original (eq if-exists :rename-and-delete)) + (mode #o666)) + (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. + (let ((exists + (and namestring + (multiple-value-bind (okay err/dev inode orig-mode) + (sb!unix:unix-stat namestring) + (declare (ignore inode) + (type (or index null) orig-mode)) + (cond + (okay + (when (and output (= (logand orig-mode #o170000) + #o40000)) + (error 'simple-file-error + :pathname pathname + :format-control + "can't open ~S for output: is a directory" + :format-arguments (list namestring))) + (setf mode (logand orig-mode #o777)) + t) + ((eql err/dev sb!unix:enoent) + nil) + (t + (simple-file-perror "can't find ~S" + namestring + err/dev))))))) + (unless (and exists + (rename-the-old-one namestring original)) + (setf original nil) + (setf delete-original nil) + ;; In order to use :SUPERSEDE instead, we have to make + ;; sure SB!UNIX:O_CREAT corresponds to + ;; IF-DOES-NOT-EXIST. SB!UNIX:O_CREAT was set before + ;; because of IF-EXISTS being :RENAME. + (unless (eq if-does-not-exist :create) + (setf mask + (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 + (sb!unix:unix-open namestring mask mode) + (values nil sb!unix:enoent)) + (flet ((vanilla-open-error () + (simple-file-perror "error opening ~S" pathname errno))) + (cond ((numberp fd) + (case direction + ((:input :output :io) + ;; For O_APPEND opened files, lseek returns 0 until first write. + ;; So we jump ahead here. + (when (eq if-exists :append) + (sb!unix:unix-lseek fd 0 sb!unix:l_xtnd)) + (make-fd-stream fd + :input input + :output output + :element-type element-type + :external-format external-format + :file namestring + :original original + :delete-original delete-original + :pathname pathname + :dual-channel-p nil + :serve-events nil + :input-buffer-p t + :auto-close t)) + (:probe + (let ((stream + (%make-fd-stream :name namestring + :fd fd + :pathname pathname + :element-type element-type))) + (close stream) + stream)))) + ((eql errno sb!unix:enoent) + (case if-does-not-exist + (:error (vanilla-open-error)) + (:create + (open-error "~@" + pathname)) + (t nil))) + ((and (eql errno sb!unix:eexist) (null if-exists)) nil) (t - :create)))) - (ensure-one-of if-does-not-exist - '(:error :create nil) - :if-does-not-exist) - (if (eq if-does-not-exist :create) - (setf mask (logior mask sb!unix:o_creat))) - - (let ((original (case if-exists - ((:rename :rename-and-delete) - (pick-backup-name namestring)) - ((:append :overwrite) - ;; KLUDGE: Provent CLOSE from deleting - ;; appending streams when called with :ABORT T - namestring))) - (delete-original (eq if-exists :rename-and-delete)) - (mode #o666)) - (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. - (let ((exists - (and namestring - (multiple-value-bind (okay err/dev inode orig-mode) - (sb!unix:unix-stat namestring) - (declare (ignore inode) - (type (or index null) orig-mode)) - (cond - (okay - (when (and output (= (logand orig-mode #o170000) - #o40000)) - (error 'simple-file-error - :pathname pathname - :format-control - "can't open ~S for output: is a directory" - :format-arguments (list namestring))) - (setf mode (logand orig-mode #o777)) - t) - ((eql err/dev sb!unix:enoent) - nil) - (t - (simple-file-perror "can't find ~S" - namestring - err/dev))))))) - (unless (and exists - (rename-the-old-one namestring original)) - (setf original nil) - (setf delete-original nil) - ;; In order to use :SUPERSEDE instead, we have to make - ;; sure SB!UNIX:O_CREAT corresponds to - ;; IF-DOES-NOT-EXIST. SB!UNIX:O_CREAT was set before - ;; because of IF-EXISTS being :RENAME. - (unless (eq if-does-not-exist :create) - (setf mask - (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 - (sb!unix:unix-open namestring mask mode) - (values nil sb!unix:enoent)) - (labels ((open-error (format-control &rest format-arguments) - (error 'simple-file-error - :pathname pathname - :format-control format-control - :format-arguments format-arguments)) - (vanilla-open-error () - (simple-file-perror "error opening ~S" pathname errno))) - (cond ((numberp fd) - (case direction - ((:input :output :io) - (make-fd-stream fd - :input input - :output output - :element-type element-type - :external-format external-format - :file namestring - :original original - :delete-original delete-original - :pathname pathname - :dual-channel-p nil - :serve-events nil - :input-buffer-p t - :auto-close t)) - (:probe - (let ((stream - (%make-fd-stream :name namestring - :fd fd - :pathname pathname - :element-type element-type))) - (close stream) - stream)))) - ((eql errno sb!unix:enoent) - (case if-does-not-exist - (:error (vanilla-open-error)) - (:create - (open-error "~@" - pathname)) - (t nil))) - ((and (eql errno sb!unix:eexist) (null if-exists)) - nil) - (t - (vanilla-open-error))))))))) + (vanilla-open-error)))))))))) ;;;; initialization @@ -2489,9 +2526,15 @@ (without-package-locks (makunbound '*available-buffers*)))) -(defun stdstream-external-format (outputp) - (declare (ignorable outputp)) - (let* ((keyword #!+win32 (if outputp (sb!win32::console-output-codepage) (sb!win32::console-input-codepage)) +(defun stdstream-external-format (fd outputp) + #!-win32 (declare (ignore fd outputp)) + (let* ((keyword #!+win32 (if (and (/= fd -1) + (logbitp 0 fd) + (logbitp 1 fd)) + :ucs-2 + (if outputp + (sb!win32::console-output-codepage) + (sb!win32::console-input-codepage))) #!-win32 (default-external-format)) (ef (get-external-format keyword)) (replacement (ef-default-replacement-character ef))) @@ -2504,29 +2547,66 @@ (aver (not (boundp '*available-buffers*))) (setf *available-buffers* nil))) (with-output-to-string (*error-output*) - (setf *stdin* - (make-fd-stream 0 :name "standard input" :input t :buffering :line - :element-type :default - :serve-events t - :external-format (stdstream-external-format nil))) - (setf *stdout* - (make-fd-stream 1 :name "standard output" :output t :buffering :line - :element-type :default - :external-format (stdstream-external-format t))) - (setf *stderr* - (make-fd-stream 2 :name "standard error" :output t :buffering :line - :element-type :default - :external-format (stdstream-external-format t))) + (multiple-value-bind (in out err) + #!-win32 (values 0 1 2) + #!+win32 (sb!win32::get-std-handles) + (labels (#!+win32 + (nul-stream (name inputp outputp) + (let* ((nul-name #.(coerce "NUL" 'simple-base-string)) + (nul-handle + (cond + ((and inputp outputp) + (sb!win32:unixlike-open nul-name sb!unix:o_rdwr 0)) + (inputp + (sb!win32:unixlike-open nul-name sb!unix:o_rdonly 0)) + (outputp + (sb!win32:unixlike-open nul-name sb!unix:o_wronly 0)) + (t + ;; Not quite sure what to do in this case. + nil)))) + (make-fd-stream + nul-handle + :name name + :input inputp + :output outputp + :buffering :line + :element-type :default + :serve-events inputp + :auto-close t + :external-format (stdstream-external-format nul-handle outputp)))) + (stdio-stream (handle name inputp outputp) + (cond + #!+win32 + ((null handle) + ;; If no actual handle was present, create a stream to NUL + (nul-stream name inputp outputp)) + (t + (make-fd-stream + handle + :name name + :input inputp + :output outputp + :buffering :line + :element-type :default + :serve-events inputp + :external-format (stdstream-external-format handle outputp)))))) + (setf *stdin* (stdio-stream in "standard input" t nil) + *stdout* (stdio-stream out "standard output" nil t) + *stderr* (stdio-stream err "standard error" nil t)))) + #!+win32 + (setf *tty* (make-two-way-stream *stdin* *stdout*)) + #!-win32 (let* ((ttyname #.(coerce "/dev/tty" 'simple-base-string)) (tty (sb!unix:unix-open ttyname sb!unix:o_rdwr #o666))) - (if tty - (setf *tty* + (setf *tty* + (if tty (make-fd-stream tty :name "the terminal" - :input t :output t :buffering :line - :external-format (stdstream-external-format t) - :serve-events t - :auto-close t)) - (setf *tty* (make-two-way-stream *stdin* *stdout*)))) + :input t :output t :buffering :line + :external-format (stdstream-external-format + tty t) + :serve-events t + :auto-close t) + (make-two-way-stream *stdin* *stdout*)))) (princ (get-output-stream-string *error-output*) *stderr*)) (values))