(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)
(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
(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))))
+ (labels (#!+win32
+ (nul-stream (name inputp outputp)
+ (let* ((nul-name #.(coerce "NUL" 'simple-base-string))
+ (nul-handle
+ (cond
+ ((and inputp outputp)
+ (sb!win32:unixlike-open nul-name sb!unix:o_rdwr 0))
+ (inputp
+ (sb!win32:unixlike-open nul-name sb!unix:o_rdonly 0))
+ (outputp
+ (sb!win32:unixlike-open nul-name sb!unix:o_wronly 0))
+ (t
+ ;; Not quite sure what to do in this case.
+ nil))))
+ (make-fd-stream
+ nul-handle
+ :name name
+ :input inputp
+ :output outputp
+ :buffering :line
+ :element-type :default
+ :serve-events inputp
+ :auto-close t
+ :external-format (stdstream-external-format nul-handle outputp))))
+ (stdio-stream (handle name inputp outputp)
+ (cond
+ #!+win32
+ ((null handle)
+ ;; If no actual handle was present, create a stream to NUL
+ (nul-stream name inputp outputp))
+ (t
+ (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)
+ *stdout* (stdio-stream out "standard output" nil t)
+ *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*
+ (setf *tty*
+ (if tty
(make-fd-stream tty :name "the terminal"
- :input t :output t :buffering :line
- :external-format (stdstream-external-format
- tty t)
- :serve-events (or #!-win32 t)
- :auto-close t))
- (setf *tty* (make-two-way-stream *stdin* *stdout*))))
+ :input t :output t :buffering :line
+ :external-format (stdstream-external-format
+ tty t)
+ :serve-events t
+ :auto-close t)
+ (make-two-way-stream *stdin* *stdout*))))
(princ (get-output-stream-string *error-output*) *stderr*))
(values))
\f