;; 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
(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)
`(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)
: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)
(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))
(: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))
(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 "~@<The path ~2I~_~S ~I~_does not exist.~:>"
+ 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 "~@<The path ~2I~_~S ~I~_does not exist.~:>"
- pathname))
- (t nil)))
- ((and (eql errno sb!unix:eexist) (null if-exists))
- nil)
- (t
- (vanilla-open-error)))))))))
+ (vanilla-open-error))))))))))
\f
;;;; initialization
(defun stdstream-external-format (fd outputp)
#!-win32 (declare (ignore fd outputp))
- (let* ((keyword #!+win32 (let ((handle (sb!win32:get-osfhandle fd)))
- (if (and (/= handle -1)
- (logbitp 0 handle)
- (logbitp 1 handle))
- :ucs-2
- (if outputp
- (sb!win32::console-output-codepage)
- (sb!win32::console-input-codepage))))
+ (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 0 nil)))
- (setf *stdout*
- (make-fd-stream 1 :name "standard output" :output t :buffering :line
- :element-type :default
- :external-format (stdstream-external-format 1 t)))
- (setf *stderr*
- (make-fd-stream 2 :name "standard error" :output t :buffering :line
- :element-type :default
- :external-format (stdstream-external-format 2 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
projects / sbcl.git / blobdiff