#!+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)
;; 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)))))))))))))
: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
(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 "~@<Skip output of this character.~@:>"))
(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)
(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)
(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)))
(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)
(: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)
(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
(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*))
projects / sbcl.git / blobdiff