;; 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
((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)))))))))))))
(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.
((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
(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)
(: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
: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))
(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))
(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.
(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
(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
;; 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))))))))
\f
;;;; creation routines (MAKE-FD-STREAM and OPEN)
(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)))
(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*))