X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=789e9621c8e4c96aa4000f6f08c444f5e5ff5917;hb=b38f10027f48f657f77b290719da4fec30064e25;hp=d6c9b4c3968f4e2fc7c7d739eae4aa820cf58459;hpb=7572e0506af331534e6f97b027d56e8bea09410c;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index d6c9b4c..789e962 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -147,7 +147,7 @@ ;; 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 @@ -2026,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 @@ -2043,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)) @@ -2052,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)) @@ -2086,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. @@ -2115,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 @@ -2147,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 @@ -2159,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) @@ -2488,9 +2503,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))) @@ -2503,27 +2524,34 @@ (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) + (flet ((stdio-stream (handle name inputp outputp) + (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)) + (setf *stdout* (stdio-stream out "standard output" nil t)) + (setf *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* (make-fd-stream tty :name "the terminal" :input t :output t :buffering :line - :external-format (stdstream-external-format t) - :serve-events t + :external-format (stdstream-external-format + tty t) + :serve-events (or #!-win32 t) :auto-close t)) (setf *tty* (make-two-way-stream *stdin* *stdout*)))) (princ (get-output-stream-string *error-output*) *stderr*))