X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=c583f17b1700eae8bfc9475e6105d6137f7aa1e2;hb=ced29bbb5c5575ed9f71a4bdd79e222216a63e73;hp=b9731136ca65d54d84d6103a4f03474490bfbb46;hpb=4e7866afc56e4eec4e33dc2d61bd4f0aeed72cfd;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index b973113..c583f17 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 @@ -290,6 +290,8 @@ ((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))))))))))))) @@ -523,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) @@ -550,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) @@ -952,6 +954,9 @@ (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 try an uninterruptible ;; read(). Regular files should never block, so we can elide the check. @@ -984,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 @@ -1020,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) @@ -1079,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) @@ -1579,7 +1585,9 @@ (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)) @@ -1599,7 +1607,9 @@ (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)) @@ -2016,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 @@ -2033,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)) @@ -2042,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)) @@ -2076,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. @@ -2105,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 @@ -2137,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 @@ -2149,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) @@ -2264,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)) @@ -2291,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)) @@ -2302,147 +2327,164 @@ (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 - (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 ((eq if-does-not-exist :create) + (setf mask (logior mask sb!unix:o_creat))) + ((not (member if-exists '(:new-version :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)) + ((sb!unix:unix-stat namestring) + (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) - ;; 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 - (vanilla-open-error))))))))) + (vanilla-open-error)))))))))) ;;;; initialization @@ -2478,9 +2520,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))) @@ -2493,27 +2541,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*))