(defstruct (fd-stream
(:constructor %make-fd-stream)
- (:include lisp-stream
- (misc #'fd-stream-misc-routine)))
+ (:include ansi-stream
+ (misc #'fd-stream-misc-routine))
+ (:copier nil))
;; the name of this stream
(name nil)
element-type output, the kind of buffering, the function name, and the number
of bytes per element.")
+;;; common idioms for reporting low-level stream and file problems
+(defun simple-stream-perror (note-format stream errno)
+ (error 'simple-stream-error
+ :stream stream
+ :format-control "~@<~?: ~2I~_~A~:>"
+ :format-arguments (list note-format (list stream) (strerror errno))))
+(defun simple-file-perror (note-format pathname errno)
+ (error 'simple-file-error
+ :pathname pathname
+ :format-control "~@<~?: ~2I~_~A~:>"
+ :format-arguments
+ (list note-format (list pathname) (strerror errno))))
+
;;; This is called by the server when we can write to the given file
;;; descriptor. Attempt to write the data again. If it worked, remove
;;; the data from the OUTPUT-LATER list. If it didn't work, something
(cond ((not count)
(if (= errno sb!unix:ewouldblock)
(error "Write would have blocked, but SERVER told us to go.")
- (error "while writing ~S: ~A"
- stream
- (sb!unix:get-unix-error-msg errno))))
+ (simple-stream-perror "couldn't write to ~S" stream errno)))
((eql count length) ; Hot damn, it worked.
(when reuse-sap
(push base *available-buffers*)))
- ((not (null count)) ; Sorta worked.
+ ((not (null count)) ; sorta worked..
(push (list base
(the index (+ start count))
end)
(cond ((not count)
(if (= errno sb!unix:ewouldblock)
(output-later stream base start end reuse-sap)
- ;; FIXME: This and various other errors in this file
- ;; should probably be STREAM-ERROR.
- (error "while writing ~S: ~A"
- stream
- (sb!unix:get-unix-error-msg errno))))
+ (simple-stream-perror "couldn't write to ~S"
+ stream
+ errno)))
((not (eql count length))
(output-later stream base (the index (+ start count))
end reuse-sap)))))))
(do-output stream (fd-stream-obuf-sap stream) 0 length t)
(setf (fd-stream-obuf-tail stream) 0))))
-;;; Define output routines that output numbers size bytes long for the
-;;; given bufferings. Use body to do the actual output.
-(defmacro def-output-routines ((name size &rest bufferings) &body body)
+;;; Define output routines that output numbers SIZE bytes long for the
+;;; given bufferings. Use BODY to do the actual output.
+(defmacro def-output-routines ((name-fmt size &rest bufferings) &body body)
(declare (optimize (speed 1)))
(cons 'progn
(mapcar
#'(lambda (buffering)
(let ((function
(intern (let ((*print-case* :upcase))
- (format nil name (car buffering))))))
+ (format nil name-fmt (car buffering))))))
`(progn
(defun ,function (stream byte)
,(unless (eq (car buffering) :none)
(bytes (- end start))
(newtail (+ tail bytes)))
(cond ((minusp bytes) ; error case
- (cerror "Just go on as if nothing happened."
- "~S called with :END before :START!"
- 'output-raw-bytes))
- ((zerop bytes)) ; Easy case
+ (error ":END before :START!"))
+ ((zerop bytes)) ; easy case
((<= bytes space)
(if (system-area-pointer-p thing)
(system-area-copy thing
- (* start sb!vm:byte-bits)
+ (* start sb!vm:n-byte-bits)
(fd-stream-obuf-sap fd-stream)
- (* tail sb!vm:byte-bits)
- (* bytes sb!vm:byte-bits))
+ (* tail sb!vm:n-byte-bits)
+ (* bytes sb!vm:n-byte-bits))
;; FIXME: There should be some type checking somewhere to
;; verify that THING here is a vector, not just <not a SAP>.
(copy-to-system-area thing
- (+ (* start sb!vm:byte-bits)
+ (+ (* start sb!vm:n-byte-bits)
(* sb!vm:vector-data-offset
- sb!vm:word-bits))
+ sb!vm:n-word-bits))
(fd-stream-obuf-sap fd-stream)
- (* tail sb!vm:byte-bits)
- (* bytes sb!vm:byte-bits)))
+ (* tail sb!vm:n-byte-bits)
+ (* bytes sb!vm:n-byte-bits)))
(setf (fd-stream-obuf-tail fd-stream) newtail))
((<= bytes len)
(flush-output-buffer fd-stream)
(if (system-area-pointer-p thing)
(system-area-copy thing
- (* start sb!vm:byte-bits)
+ (* start sb!vm:n-byte-bits)
(fd-stream-obuf-sap fd-stream)
0
- (* bytes sb!vm:byte-bits))
+ (* bytes sb!vm:n-byte-bits))
;; FIXME: There should be some type checking somewhere to
;; verify that THING here is a vector, not just <not a SAP>.
(copy-to-system-area thing
- (+ (* start sb!vm:byte-bits)
+ (+ (* start sb!vm:n-byte-bits)
(* sb!vm:vector-data-offset
- sb!vm:word-bits))
+ sb!vm:n-word-bits))
(fd-stream-obuf-sap fd-stream)
0
- (* bytes sb!vm:byte-bits)))
+ (* bytes sb!vm:n-byte-bits)))
(setf (fd-stream-obuf-tail fd-stream) bytes))
(t
(flush-output-buffer fd-stream)
\f
;;;; input routines and related noise
-(defvar *input-routines* ()
- #!+sb-doc
- "List of all available input routines. Each element is a list of the
- element-type input, the function name, and the number of bytes per element.")
+;;; a list of all available input routines. Each element is a list of
+;;; the element-type input, the function name, and the number of bytes
+;;; per element.
+(defvar *input-routines* ())
;;; Fill the input buffer, and return the first character. Throw to
;;; EOF-INPUT-CATCHER if the eof was reached. Drop into SYSTEM:SERVER
(setf (fd-stream-ibuf-tail stream) 0))
(t
(decf tail head)
- (system-area-copy ibuf-sap (* head sb!vm:byte-bits)
- ibuf-sap 0 (* tail sb!vm:byte-bits))
+ (system-area-copy ibuf-sap (* head sb!vm:n-byte-bits)
+ ibuf-sap 0 (* tail sb!vm:n-byte-bits))
(setf head 0)
(setf (fd-stream-ibuf-head stream) 0)
(setf (fd-stream-ibuf-tail stream) tail))))
fd :input (fd-stream-timeout stream))
(error 'io-timeout :stream stream :direction :read)))
(t
- (error "problem checking to see whether ~S is readable: ~A"
- stream
- (sb!unix:get-unix-error-msg errno)))))
+ (simple-stream-perror "couldn't check whether ~S is readable"
+ stream
+ errno))))
(multiple-value-bind (count errno)
(sb!unix:unix-read fd
(sb!sys:int-sap (+ (sb!sys:sap-int ibuf-sap) tail))
fd :input (fd-stream-timeout stream))
(error 'io-timeout :stream stream :direction :read))
(do-input stream))
- (error "error reading ~S: ~A"
- stream
- (sb!unix:get-unix-error-msg errno))))
+ (simple-stream-perror "couldn't read from ~S" stream errno)))
((zerop count)
(setf (fd-stream-listen stream) :eof)
(throw 'eof-input-catcher nil))
(car entry)
(caddr entry))))))
-;;; Returns a string constructed from the sap, start, and end.
+;;; Return a string constructed from SAP, START, and END.
(defun string-from-sap (sap start end)
(declare (type index start end))
(let* ((length (- end start))
(string (make-string length)))
- (copy-from-system-area sap (* start sb!vm:byte-bits)
- string (* sb!vm:vector-data-offset sb!vm:word-bits)
- (* length sb!vm:byte-bits))
+ (copy-from-system-area sap (* start sb!vm:n-byte-bits)
+ string (* sb!vm:vector-data-offset
+ sb!vm:n-word-bits)
+ (* length sb!vm:n-byte-bits))
string))
-;;; the N-BIN method for FD-STREAMs. This blocks in UNIX-READ. It is
-;;; generally used where there is a definite amount of reading to be
-;;; done, so blocking isn't too problematical.
+;;; the N-BIN method for FD-STREAMs
+;;;
+;;; Note that this blocks in UNIX-READ. It is generally used where
+;;; there is a definite amount of reading to be done, so blocking
+;;; isn't too problematical.
(defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p)
(declare (type fd-stream stream))
(declare (type index start requested))
(head (fd-stream-ibuf-head stream))
(tail (fd-stream-ibuf-tail stream))
(available (- tail head))
- (this-copy (min remaining-request available))
+ (n-this-copy (min remaining-request available))
(this-start (+ start total-copied))
+ (this-end (+ this-start n-this-copy))
(sap (fd-stream-ibuf-sap stream)))
(declare (type index remaining-request head tail available))
- (declare (type index this-copy))
+ (declare (type index n-this-copy))
;; Copy data from stream buffer into user's buffer.
- (if (typep buffer 'system-area-pointer)
- (system-area-copy sap (* head sb!vm:byte-bits)
- buffer (* this-start sb!vm:byte-bits)
- (* this-copy sb!vm:byte-bits))
- (copy-from-system-area sap (* head sb!vm:byte-bits)
- buffer (+ (* this-start sb!vm:byte-bits)
- (* sb!vm:vector-data-offset
- sb!vm:word-bits))
- (* this-copy sb!vm:byte-bits)))
- (incf (fd-stream-ibuf-head stream) this-copy)
- (incf total-copied this-copy)
+ (%byte-blt sap head buffer this-start this-end)
+ (incf (fd-stream-ibuf-head stream) n-this-copy)
+ (incf total-copied n-this-copy)
;; Maybe we need to refill the stream buffer.
(cond (;; If there were enough data in the stream buffer, we're done.
(= total-copied requested)
(defun refill-fd-stream-buffer (stream)
;; We don't have any logic to preserve leftover bytes in the buffer,
;; so we should only be called when the buffer is empty.
- (assert (= (fd-stream-ibuf-head stream) (fd-stream-ibuf-tail stream)))
+ (aver (= (fd-stream-ibuf-head stream) (fd-stream-ibuf-tail stream)))
(multiple-value-bind (count err)
(sb!unix:unix-read (fd-stream-fd stream)
(fd-stream-ibuf-sap stream)
(fd-stream-ibuf-length stream))
(declare (type (or index null) count))
(when (null count)
- (error "error reading ~S: ~A"
- stream
- (sb!unix:get-unix-error-msg err)))
+ (simple-stream-perror "couldn't read from ~S" stream err))
(setf (fd-stream-listen stream) nil
(fd-stream-ibuf-head stream) 0
(fd-stream-ibuf-tail stream) count)
-; (format t "~%buffer=~%--~%")
-; (dotimes (i count)
-; (write-char (code-char (sap-ref-8 (fd-stream-ibuf-sap stream) i))))
-; (format t "~%--~%")
- #+nil
- (format t "/REFILL-FD-STREAM-BUFFER = ~D~%" count)
count))
\f
;;;; utility functions (misc routines, etc)
;;; Fill in the various routine slots for the given type. INPUT-P and
;;; OUTPUT-P indicate what slots to fill. The buffering slot must be
;;; set prior to calling this routine.
-(defun set-routines (stream type input-p output-p buffer-p)
+(defun set-fd-stream-routines (fd-stream type input-p output-p buffer-p)
(let ((target-type (case type
((:default unsigned-byte)
'(unsigned-byte 8))
(input-size nil)
(output-size nil))
- (when (fd-stream-obuf-sap stream)
- (push (fd-stream-obuf-sap stream) *available-buffers*)
- (setf (fd-stream-obuf-sap stream) nil))
- (when (fd-stream-ibuf-sap stream)
- (push (fd-stream-ibuf-sap stream) *available-buffers*)
- (setf (fd-stream-ibuf-sap stream) nil))
+ (when (fd-stream-obuf-sap fd-stream)
+ (push (fd-stream-obuf-sap fd-stream) *available-buffers*)
+ (setf (fd-stream-obuf-sap fd-stream) nil))
+ (when (fd-stream-ibuf-sap fd-stream)
+ (push (fd-stream-ibuf-sap fd-stream) *available-buffers*)
+ (setf (fd-stream-ibuf-sap fd-stream) nil))
(when input-p
(multiple-value-bind (routine type size)
(pick-input-routine target-type)
(unless routine
(error "could not find any input routine for ~S" target-type))
- (setf (fd-stream-ibuf-sap stream) (next-available-buffer))
- (setf (fd-stream-ibuf-length stream) bytes-per-buffer)
- (setf (fd-stream-ibuf-tail stream) 0)
+ (setf (fd-stream-ibuf-sap fd-stream) (next-available-buffer))
+ (setf (fd-stream-ibuf-length fd-stream) bytes-per-buffer)
+ (setf (fd-stream-ibuf-tail fd-stream) 0)
(if (subtypep type 'character)
- (setf (fd-stream-in stream) routine
- (fd-stream-bin stream) #'ill-bin)
- (setf (fd-stream-in stream) #'ill-in
- (fd-stream-bin stream) routine))
+ (setf (fd-stream-in fd-stream) routine
+ (fd-stream-bin fd-stream) #'ill-bin)
+ (setf (fd-stream-in fd-stream) #'ill-in
+ (fd-stream-bin fd-stream) routine))
(when (eql size 1)
- (setf (fd-stream-n-bin stream) #'fd-stream-read-n-bytes)
+ (setf (fd-stream-n-bin fd-stream) #'fd-stream-read-n-bytes)
(when buffer-p
- (setf (lisp-stream-in-buffer stream)
- (make-array in-buffer-length
+ (setf (ansi-stream-in-buffer fd-stream)
+ (make-array +ansi-stream-in-buffer-length+
:element-type '(unsigned-byte 8)))))
(setf input-size size)
(setf input-type type)))
(when output-p
(multiple-value-bind (routine type size)
- (pick-output-routine target-type (fd-stream-buffering stream))
+ (pick-output-routine target-type (fd-stream-buffering fd-stream))
(unless routine
(error "could not find any output routine for ~S buffered ~S"
- (fd-stream-buffering stream)
+ (fd-stream-buffering fd-stream)
target-type))
- (setf (fd-stream-obuf-sap stream) (next-available-buffer))
- (setf (fd-stream-obuf-length stream) bytes-per-buffer)
- (setf (fd-stream-obuf-tail stream) 0)
+ (setf (fd-stream-obuf-sap fd-stream) (next-available-buffer))
+ (setf (fd-stream-obuf-length fd-stream) bytes-per-buffer)
+ (setf (fd-stream-obuf-tail fd-stream) 0)
(if (subtypep type 'character)
- (setf (fd-stream-out stream) routine
- (fd-stream-bout stream) #'ill-bout)
- (setf (fd-stream-out stream)
+ (setf (fd-stream-out fd-stream) routine
+ (fd-stream-bout fd-stream) #'ill-bout)
+ (setf (fd-stream-out fd-stream)
(or (if (eql size 1)
(pick-output-routine 'base-char
- (fd-stream-buffering stream)))
+ (fd-stream-buffering fd-stream)))
#'ill-out)
- (fd-stream-bout stream) routine))
- (setf (fd-stream-sout stream)
+ (fd-stream-bout fd-stream) routine))
+ (setf (fd-stream-sout fd-stream)
(if (eql size 1) #'fd-sout #'ill-out))
- (setf (fd-stream-char-pos stream) 0)
+ (setf (fd-stream-char-pos fd-stream) 0)
(setf output-size size)
(setf output-type type)))
(error "Element sizes for input (~S:~S) and output (~S:~S) differ?"
input-type input-size
output-type output-size))
- (setf (fd-stream-element-size stream)
+ (setf (fd-stream-element-size fd-stream)
(or input-size output-size))
- (setf (fd-stream-element-type stream)
+ (setf (fd-stream-element-type fd-stream)
(cond ((equal input-type output-type)
input-type)
((null output-type)
input-type
output-type))))))
-;;; Handle miscellaneous operations on fd-stream.
-(defun fd-stream-misc-routine (stream operation &optional arg1 arg2)
+;;; Handle miscellaneous operations on FD-STREAM.
+(defun fd-stream-misc-routine (fd-stream operation &optional arg1 arg2)
(declare (ignore arg2))
- ;; FIXME: Declare TYPE FD-STREAM STREAM?
(case operation
(:listen
- (or (not (eql (fd-stream-ibuf-head stream)
- (fd-stream-ibuf-tail stream)))
- (fd-stream-listen stream)
- (setf (fd-stream-listen stream)
+ (or (not (eql (fd-stream-ibuf-head fd-stream)
+ (fd-stream-ibuf-tail fd-stream)))
+ (fd-stream-listen fd-stream)
+ (setf (fd-stream-listen fd-stream)
(eql (sb!alien:with-alien ((read-fds (sb!alien:struct
sb!unix:fd-set)))
(sb!unix:fd-zero read-fds)
- (sb!unix:fd-set (fd-stream-fd stream) read-fds)
- (sb!unix:unix-fast-select (1+ (fd-stream-fd stream))
+ (sb!unix:fd-set (fd-stream-fd fd-stream) read-fds)
+ (sb!unix:unix-fast-select (1+ (fd-stream-fd fd-stream))
(sb!alien:addr read-fds)
nil nil 0 0))
1))))
(:unread
- (setf (fd-stream-unread stream) arg1)
- (setf (fd-stream-listen stream) t))
+ (setf (fd-stream-unread fd-stream) arg1)
+ (setf (fd-stream-listen fd-stream) t))
(:close
(cond (arg1
;; We got us an abort on our hands.
- (when (fd-stream-handler stream)
- (sb!sys:remove-fd-handler (fd-stream-handler stream))
- (setf (fd-stream-handler stream) nil))
- (when (and (fd-stream-file stream)
- (fd-stream-obuf-sap stream))
+ (when (fd-stream-handler fd-stream)
+ (sb!sys:remove-fd-handler (fd-stream-handler fd-stream))
+ (setf (fd-stream-handler fd-stream) nil))
+ (when (and (fd-stream-file fd-stream)
+ (fd-stream-obuf-sap fd-stream))
;; We can't do anything unless we know what file were
;; dealing with, and we don't want to do anything
;; strange unless we were writing to the file.
- (if (fd-stream-original stream)
+ (if (fd-stream-original fd-stream)
;; We have a handle on the original, just revert.
(multiple-value-bind (okay err)
- (sb!unix:unix-rename (fd-stream-original stream)
- (fd-stream-file stream))
+ (sb!unix:unix-rename (fd-stream-original fd-stream)
+ (fd-stream-file fd-stream))
(unless okay
- (cerror "Go on as if nothing bad happened."
- "could not restore ~S to its original contents: ~A"
- (fd-stream-file stream)
- (sb!unix:get-unix-error-msg err))))
- ;; We can't restore the orignal, so nuke that puppy.
+ (simple-stream-perror
+ "couldn't restore ~S to its original contents"
+ fd-stream
+ err)))
+ ;; We can't restore the original, so nuke that puppy.
(multiple-value-bind (okay err)
- (sb!unix:unix-unlink (fd-stream-file stream))
+ (sb!unix:unix-unlink (fd-stream-file fd-stream))
(unless okay
- (cerror "Go on as if nothing bad happened."
- "Could not remove ~S: ~A"
- (fd-stream-file stream)
- (sb!unix:get-unix-error-msg err)))))))
+ (error 'simple-file-error
+ :pathname (fd-stream-file fd-stream)
+ :format-control
+ "~@<couldn't remove ~S: ~2I~_~A~:>"
+ :format-arguments (list (fd-stream-file fd-stream)
+ (strerror err))))))))
(t
- (fd-stream-misc-routine stream :finish-output)
- (when (and (fd-stream-original stream)
- (fd-stream-delete-original stream))
+ (fd-stream-misc-routine fd-stream :finish-output)
+ (when (and (fd-stream-original fd-stream)
+ (fd-stream-delete-original fd-stream))
(multiple-value-bind (okay err)
- (sb!unix:unix-unlink (fd-stream-original stream))
+ (sb!unix:unix-unlink (fd-stream-original fd-stream))
(unless okay
- (cerror "Go on as if nothing bad happened."
- "could not delete ~S during close of ~S: ~A"
- (fd-stream-original stream)
- stream
- (sb!unix:get-unix-error-msg err)))))))
+ (error 'simple-file-error
+ :pathname (fd-stream-original fd-stream)
+ :format-control
+ "~@<couldn't delete ~S during close of ~S: ~
+ ~2I~_~A~:>"
+ :format-arguments
+ (list (fd-stream-original fd-stream)
+ fd-stream
+ (strerror err))))))))
(when (fboundp 'cancel-finalization)
- (cancel-finalization stream))
- (sb!unix:unix-close (fd-stream-fd stream))
- (when (fd-stream-obuf-sap stream)
- (push (fd-stream-obuf-sap stream) *available-buffers*)
- (setf (fd-stream-obuf-sap stream) nil))
- (when (fd-stream-ibuf-sap stream)
- (push (fd-stream-ibuf-sap stream) *available-buffers*)
- (setf (fd-stream-ibuf-sap stream) nil))
- (sb!impl::set-closed-flame stream))
+ (cancel-finalization fd-stream))
+ (sb!unix:unix-close (fd-stream-fd fd-stream))
+ (when (fd-stream-obuf-sap fd-stream)
+ (push (fd-stream-obuf-sap fd-stream) *available-buffers*)
+ (setf (fd-stream-obuf-sap fd-stream) nil))
+ (when (fd-stream-ibuf-sap fd-stream)
+ (push (fd-stream-ibuf-sap fd-stream) *available-buffers*)
+ (setf (fd-stream-ibuf-sap fd-stream) nil))
+ (sb!impl::set-closed-flame fd-stream))
(:clear-input
- (setf (fd-stream-unread stream) nil)
- (setf (fd-stream-ibuf-head stream) 0)
- (setf (fd-stream-ibuf-tail stream) 0)
+ (setf (fd-stream-unread fd-stream) nil)
+ (setf (fd-stream-ibuf-head fd-stream) 0)
+ (setf (fd-stream-ibuf-tail fd-stream) 0)
(catch 'eof-input-catcher
(loop
(let ((count (sb!alien:with-alien ((read-fds (sb!alien:struct
sb!unix:fd-set)))
(sb!unix:fd-zero read-fds)
- (sb!unix:fd-set (fd-stream-fd stream) read-fds)
- (sb!unix:unix-fast-select (1+ (fd-stream-fd stream))
- (sb!alien:addr read-fds)
- nil
- nil
- 0
- 0))))
+ (sb!unix:fd-set (fd-stream-fd fd-stream) read-fds)
+ (sb!unix:unix-fast-select (1+ (fd-stream-fd fd-stream))
+ (sb!alien:addr read-fds)
+ nil
+ nil
+ 0
+ 0))))
(cond ((eql count 1)
- (do-input stream)
- (setf (fd-stream-ibuf-head stream) 0)
- (setf (fd-stream-ibuf-tail stream) 0))
+ (do-input fd-stream)
+ (setf (fd-stream-ibuf-head fd-stream) 0)
+ (setf (fd-stream-ibuf-tail fd-stream) 0))
(t
(return t)))))))
(:force-output
- (flush-output-buffer stream))
+ (flush-output-buffer fd-stream))
(:finish-output
- (flush-output-buffer stream)
+ (flush-output-buffer fd-stream)
(do ()
- ((null (fd-stream-output-later stream)))
+ ((null (fd-stream-output-later fd-stream)))
(sb!sys:serve-all-events)))
(:element-type
- (fd-stream-element-type stream))
+ (fd-stream-element-type fd-stream))
(:interactive-p
;; FIXME: sb!unix:unix-isatty is undefined.
- (sb!unix:unix-isatty (fd-stream-fd stream)))
+ (sb!unix:unix-isatty (fd-stream-fd fd-stream)))
(:line-length
80)
(:charpos
- (fd-stream-char-pos stream))
+ (fd-stream-char-pos fd-stream))
(:file-length
+ (unless (fd-stream-file fd-stream)
+ ;; This is a TYPE-ERROR because ANSI's species FILE-LENGTH
+ ;; "should signal an error of type TYPE-ERROR if stream is not
+ ;; a stream associated with a file". Too bad there's no very
+ ;; appropriate value for the EXPECTED-TYPE slot..
+ (error 'simple-type-error
+ :datum fd-stream
+ :expected-type 'file-stream
+ :format-control "~S is not a stream associated with a file."
+ :format-arguments (list fd-stream)))
(multiple-value-bind (okay dev ino mode nlink uid gid rdev size
atime mtime ctime blksize blocks)
- (sb!unix:unix-fstat (fd-stream-fd stream))
+ (sb!unix:unix-fstat (fd-stream-fd fd-stream))
(declare (ignore ino nlink uid gid rdev
atime mtime ctime blksize blocks))
(unless okay
- (error "error fstat'ing ~S: ~A"
- stream
- (sb!unix:get-unix-error-msg dev)))
+ (simple-stream-perror "failed Unix fstat(2) on ~S" fd-stream dev))
(if (zerop mode)
nil
- (truncate size (fd-stream-element-size stream)))))
+ (truncate size (fd-stream-element-size fd-stream)))))
(:file-position
- (fd-stream-file-position stream arg1))))
+ (fd-stream-file-position fd-stream arg1))))
(defun fd-stream-file-position (stream &optional newpos)
(declare (type fd-stream stream)
(type (or index (member nil :start :end)) newpos))
(if (null newpos)
(sb!sys:without-interrupts
- ;; First, find the position of the UNIX file descriptor in the
- ;; file.
+ ;; First, find the position of the UNIX file descriptor in the file.
(multiple-value-bind (posn errno)
(sb!unix:unix-lseek (fd-stream-fd stream) 0 sb!unix:l_incr)
(declare (type (or index null) posn))
nil)
(t
(sb!sys:with-interrupts
- (error "error LSEEK'ing ~S: ~A"
- stream
- (sb!unix:get-unix-error-msg errno)))))))
+ (simple-stream-perror "failure in Unix lseek() on ~S"
+ stream
+ errno))))))
(let ((offset 0) origin)
(declare (type index offset))
;; Make sure we don't have any output pending, because if we
(setf offset (* newpos (fd-stream-element-size stream))
origin sb!unix:l_set))
(t
- (error "invalid position given to file-position: ~S" newpos)))
+ (error "invalid position given to FILE-POSITION: ~S" newpos)))
(multiple-value-bind (posn errno)
(sb!unix:unix-lseek (fd-stream-fd stream) offset origin)
(cond ((typep posn 'fixnum)
((eq errno sb!unix:espipe)
nil)
(t
- (error "error lseek'ing ~S: ~A"
- stream
- (sb!unix:get-unix-error-msg errno))))))))
+ (simple-stream-perror "error in Unix lseek() on ~S"
+ stream
+ errno)))))))
\f
;;;; creation routines (MAKE-FD-STREAM and OPEN)
-;;; Returns a FD-STREAM on the given file.
+;;; Create a stream for the given Unix file descriptor.
+;;;
+;;; If INPUT is non-NIL, allow input operations. If OUTPUT is non-nil,
+;;; allow output operations. If neither INPUT nor OUTPUT is specified,
+;;; default to allowing input.
+;;;
+;;; ELEMENT-TYPE indicates the element type to use (as for OPEN).
+;;;
+;;; BUFFERING indicates the kind of buffering to use.
+;;;
+;;; TIMEOUT (if true) is the number of seconds to wait for input. If
+;;; NIL (the default), then wait forever. When we time out, we signal
+;;; IO-TIMEOUT.
+;;;
+;;; FILE is the name of the file (will be returned by PATHNAME).
+;;;
+;;; NAME is used to identify the stream when printed.
(defun make-fd-stream (fd
&key
(input nil input-p)
auto-close)
(declare (type index fd) (type (or index null) timeout)
(type (member :none :line :full) buffering))
- #!+sb-doc
- "Create a stream for the given unix file descriptor.
- If input is non-nil, allow input operations.
- If output is non-nil, allow output operations.
- If neither input nor output are specified, default to allowing input.
- Element-type indicates the element type to use (as for open).
- Buffering indicates the kind of buffering to use.
- Timeout (if true) is the number of seconds to wait for input. If NIL (the
- default), then wait forever. When we time out, we signal IO-TIMEOUT.
- File is the name of the file (will be returned by PATHNAME).
- Name is used to identify the stream when printed."
(cond ((not (or input-p output-p))
(setf input t))
((not (or input output))
:pathname pathname
:buffering buffering
:timeout timeout)))
- (set-routines stream element-type input output input-buffer-p)
+ (set-fd-stream-routines stream element-type input output input-buffer-p)
(when (and auto-close (fboundp 'finalize))
(finalize stream
(lambda ()
fd))))
stream))
-;;; Pick a name to use for the backup file.
-(defvar *backup-extension* ".BAK"
- #!+sb-doc
- "This is a string that OPEN tacks on the end of a file namestring to produce
- a name for the :if-exists :rename-and-delete and :rename options. Also,
- this can be a function that takes a namestring and returns a complete
- namestring.")
+;;; Pick a name to use for the backup file for the :IF-EXISTS
+;;; :RENAME-AND-DELETE and :RENAME options.
(defun pick-backup-name (name)
(declare (type simple-string name))
- (let ((ext *backup-extension*))
- (etypecase ext
- (simple-string (concatenate 'simple-string name ext))
- (function (funcall ext name)))))
-
-;;; Ensure that the given arg is one of the given list of valid things.
-;;; Allow the user to fix any problems.
-;;; FIXME: Why let the user fix any problems?
+ (concatenate 'simple-string name ".bak"))
+
+;;; Ensure that the given arg is one of the given list of valid
+;;; things. Allow the user to fix any problems.
(defun ensure-one-of (item list what)
(unless (member item list)
- (loop
- (cerror "Enter new value for ~*~S"
- "~S is invalid for ~S. Must be one of~{ ~S~}"
- item
- what
- list)
- (format (the stream *query-io*) "Enter new value for ~S: " what)
- (force-output *query-io*)
- (setf item (read *query-io*))
- (when (member item list)
- (return))))
- item)
+ (error 'simple-type-error
+ :datum item
+ :expected-type `(member ,@list)
+ :format-control "~@<~S is ~_invalid for ~S; ~_need one of~{ ~S~}~:>"
+ :format-arguments (list item what list))))
;;; Rename NAMESTRING to ORIGINAL. First, check whether we have write
;;; access, since we don't want to trash unwritable files even if we
;;; technically can. We return true if we succeed in renaming.
(defun do-old-rename (namestring original)
(unless (sb!unix:unix-access namestring sb!unix:w_ok)
- (cerror "Try to rename it anyway."
- "File ~S is not writable."
- namestring))
+ (error "~@<The file ~2I~_~S ~I~_is not writable.~:>" namestring))
(multiple-value-bind (okay err) (sb!unix:unix-rename namestring original)
- (cond (okay t)
- (t
- (cerror "Use :SUPERSEDE instead."
- "Could not rename ~S to ~S: ~A."
- namestring
- original
- (sb!unix:get-unix-error-msg err))
- nil))))
+ (if okay
+ t
+ (error 'simple-file-error
+ :pathname namestring
+ :format-control
+ "~@<couldn't rename ~2I~_~S ~I~_to ~2I~_~S: ~4I~_~A~:>"
+ :format-arguments (list namestring original (strerror err))))))
(defun open (filename
&key
(if-does-not-exist if-does-not-exist)
(if-exists if-exists))
#!+sb-doc
- "Return a stream which reads from or writes to Filename.
+ "Return a stream which reads from or writes to FILENAME.
Defined keywords:
- :direction - one of :input, :output, :io, or :probe
- :element-type - Type of object to read or write, default BASE-CHAR
- :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
- :overwrite, :append, :supersede or nil
- :if-does-not-exist - one of :error, :create or nil
+ :DIRECTION - one of :INPUT, :OUTPUT, :IO, or :PROBE
+ :ELEMENT-TYPE - the type of object to read or write, default BASE-CHAR
+ :IF-EXISTS - one of :ERROR, :NEW-VERSION, :RENAME, :RENAME-AND-DELETE,
+ :OVERWRITE, :APPEND, :SUPERSEDE or NIL
+ :IF-DOES-NOT-EXIST - one of :ERROR, :CREATE or nil
See the manual for details."
(unless (eq external-format :default)
- (error 'simple-error
- :format-control
- "Any external format other than :DEFAULT isn't recognized."))
-
- ;; First, make sure that DIRECTION is valid. Allow it to be changed
- ;; if not.
- ;;
- ;; FIXME: Why allow it to be changed if not?
- (setf direction
- (ensure-one-of direction
- '(:input :output :io :probe)
- :direction))
+ (error "Any external format other than :DEFAULT isn't recognized."))
+
+ ;; First, make sure that DIRECTION is valid.
+ (ensure-one-of direction
+ '(:input :output :io :probe)
+ :direction)
;; Calculate useful stuff.
(multiple-value-bind (input output mask)
(if (eq (pathname-version pathname) :newest)
:new-version
:error)))
- (setf if-exists ; FIXME: should just die, not allow resetting
- (ensure-one-of if-exists
- '(:error :new-version :rename
- :rename-and-delete :overwrite
- :append :supersede nil)
- :if-exists))
+ (ensure-one-of if-exists
+ '(:error :new-version :rename
+ :rename-and-delete :overwrite
+ :append :supersede nil)
+ :if-exists)
(case if-exists
((:error nil)
(setf mask (logior mask sb!unix:o_excl)))
nil)
(t
:create))))
- (setf if-does-not-exist ; FIXME: should just die, not allow resetting
- (ensure-one-of if-does-not-exist
- '(:error :create nil)
- :if-does-not-exist))
+ (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)))
(delete-original (eq if-exists :rename-and-delete))
(mode #o666))
(when original
- ;; We are doing a :RENAME or :RENAME-AND-DELETE.
- ;; Determine whether the file already exists, make sure the original
+ ;; 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
(okay
(when (and output (= (logand orig-mode #o170000)
#o40000))
- (error "cannot open ~S for output: is a directory"
- namestring))
+ (error 'simple-file-error
+ :pathname namestring
+ :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
- (error "cannot find ~S: ~A"
- namestring
- (sb!unix:get-unix-error-msg err/dev))))))))
+ (simple-file-perror "can't find ~S"
+ namestring
+ err/dev)))))))
(unless (and exists
(do-old-rename 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.
+ ;; 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))))
- ;; Okay, now we can try the actual open.
- (loop
- (multiple-value-bind (fd errno)
- (if namestring
- (sb!unix:unix-open namestring mask mode)
- (values nil sb!unix:enoent))
+ ;; 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)
- (return
- (case direction
- ((:input :output :io)
- (make-fd-stream fd
- :input input
- :output output
- :element-type element-type
- :file namestring
- :original original
- :delete-original delete-original
- :pathname pathname
- :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)))))
+ (case direction
+ ((:input :output :io)
+ (make-fd-stream fd
+ :input input
+ :output output
+ :element-type element-type
+ :file namestring
+ :original original
+ :delete-original delete-original
+ :pathname pathname
+ :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
- (cerror "Return NIL."
- 'simple-file-error
- :pathname pathname
- :format-control "error opening ~S: ~A"
- :format-arguments
- (list pathname
- (sb!unix:get-unix-error-msg errno))))
+ (:error (vanilla-open-error))
(:create
- (cerror "Return NIL."
- 'simple-error
- :format-control
- "error creating ~S: Path does not exist."
- :format-arguments
- (list pathname))))
- (return nil))
- ((eql errno sb!unix:eexist)
- (unless (eq nil if-exists)
- (cerror "Return NIL."
- 'simple-file-error
- :pathname pathname
- :format-control "error opening ~S: ~A"
- :format-arguments
- (list pathname
- (sb!unix:get-unix-error-msg errno))))
- (return nil))
- ((eql errno sb!unix:eacces)
- (cerror "Try again."
- "error opening ~S: ~A"
- pathname
- (sb!unix:get-unix-error-msg errno)))
+ (open-error "~@<The path ~2I~_~S ~I~_does not exist.~:>"
+ pathname))
+ (t nil)))
+ ((and (eql errno sb!unix:eexist) if-exists)
+ nil)
(t
- (cerror "Return NIL."
- "error opening ~S: ~A"
- pathname
- (sb!unix:get-unix-error-msg errno))
- (return nil)))))))))
+ (vanilla-open-error)))))))))
\f
;;;; initialization
-(defvar *tty* nil
- #!+sb-doc
- "The stream connected to the controlling terminal or NIL if there is none.")
-(defvar *stdin* nil
- #!+sb-doc
- "The stream connected to the standard input (file descriptor 0).")
-(defvar *stdout* nil
- #!+sb-doc
- "The stream connected to the standard output (file descriptor 1).")
-(defvar *stderr* nil
- #!+sb-doc
- "The stream connected to the standard error output (file descriptor 2).")
+;;; the stream connected to the controlling terminal, or NIL if there is none
+(defvar *tty*)
+
+;;; the stream connected to the standard input (file descriptor 0)
+(defvar *stdin*)
+
+;;; the stream connected to the standard output (file descriptor 1)
+(defvar *stdout*)
+
+;;; the stream connected to the standard error output (file descriptor 2)
+(defvar *stderr*)
;;; This is called when the cold load is first started up, and may also
;;; be called in an attempt to recover from nested errors.
(setf *standard-output* (make-synonym-stream '*stdout*))
(setf *standard-input*
(#!-high-security
- ;; FIXME: Why is *STANDARD-INPUT* a TWO-WAY-STREAM? ANSI says it's
- ;; an input stream.
+ ;; FIXME: Why is *STANDARD-INPUT* a TWO-WAY-STREAM? ANSI says
+ ;; it's an input stream.
make-two-way-stream
#!+high-security
%make-two-way-stream (make-synonym-stream '*stdin*)
(setf *query-io* (make-synonym-stream '*terminal-io*))
(setf *debug-io* *query-io*)
(setf *trace-output* *standard-output*)
- nil)
+ (values))
;;; This is called whenever a saved core is restarted.
(defun stream-reinit ()
:buffering :line
:auto-close t))
(setf *tty* (make-two-way-stream *stdin* *stdout*))))
- nil)
+ (values))
\f
-;;;; beeping
+;;;; miscellany
-(defun default-beep-function (stream)
+;;; the Unix way to beep
+(defun beep (stream)
(write-char (code-char bell-char-code) stream)
(finish-output stream))
-(defvar *beep-function* #'default-beep-function
- #!+sb-doc
- "This is called in BEEP to feep the user. It takes a stream.")
-
-(defun beep (&optional (stream *terminal-io*))
- (funcall *beep-function* stream))
-\f
;;; This is kind of like FILE-POSITION, but is an internal hack used
;;; by the filesys stuff to get and set the file name.
+;;;
+;;; FIXME: misleading name, screwy interface
(defun file-name (stream &optional new-name)
(when (typep stream 'fd-stream)
(cond (new-name
(declare (type (or string character) object) (type file-stream stream))
#!+sb-doc
"Return the delta in STREAM's FILE-POSITION that would be caused by writing
- Object to Stream. Non-trivial only in implementations that support
+ OBJECT to STREAM. Non-trivial only in implementations that support
international character sets."
(declare (ignore stream))
(etypecase object
projects / sbcl.git / blobdiff