(in-package "SB!IMPL")
-;;; FIXME: Wouldn't it be clearer to just have the structure
-;;; definition be DEFSTRUCT FILE-STREAM (instead of DEFSTRUCT
-;;; FD-STREAM)? That way we'd have TYPE-OF and PRINT-OBJECT refer to
-;;; these objects as FILE-STREAMs (the ANSI name) instead of the
-;;; internal implementation name FD-STREAM, and there might be other
-;;; benefits as well.
-(deftype file-stream () 'fd-stream)
-\f
;;;; buffer manipulation routines
;;; FIXME: Is it really good to maintain this pool separate from the
(pop *available-buffers*)
(allocate-system-memory bytes-per-buffer)))
\f
-;;;; the FD-STREAM structure
+;;;; the FILE-STREAM structure
-(defstruct (fd-stream
+(defstruct (file-stream
(:constructor %make-fd-stream)
- (:include lisp-stream
+ ;; KLUDGE: in an ideal world, maybe we'd rewrite
+ ;; everything to use FILE-STREAM rather than simply
+ ;; providing this hack for compatibility with the old
+ ;; code. However, CVS doesn't deal terribly well with
+ ;; file renaming, so for now we use this
+ ;; backward-compatibility feature.
+ (:conc-name fd-stream-)
+ (:predicate fd-stream-p)
+ (:include ansi-stream
(misc #'fd-stream-misc-routine))
(:copier nil))
(timeout nil :type (or index null))
;; pathname of the file this stream is opened to (returned by PATHNAME)
(pathname nil :type (or pathname null)))
-(def!method print-object ((fd-stream fd-stream) stream)
+(def!method print-object ((fd-stream file-stream) stream)
(declare (type stream stream))
(print-unreadable-object (fd-stream stream :type t :identity t)
(format stream "for ~S" (fd-stream-name fd-stream))))
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
;;; is wrong.
-(defun do-output-later (stream)
+(defun frob-output-later (stream)
(let* ((stuff (pop (fd-stream-output-later stream)))
(base (car stuff))
(start (cadr stuff))
(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)
(setf (fd-stream-handler stream)
(sb!sys:add-fd-handler (fd-stream-fd stream)
:output
- #'(lambda (fd)
- (declare (ignore fd))
- (do-output-later stream)))))
+ (lambda (fd)
+ (declare (ignore fd))
+ (frob-output-later stream)))))
(t
(nconc (fd-stream-output-later stream)
(list (list base start end reuse-sap)))))
;;; Output the given noise. Check to see whether there are any pending
;;; writes. If so, just queue this one. Otherwise, try to write it. If
;;; this would block, queue it.
-(defun do-output (stream base start end reuse-sap)
- (declare (type fd-stream stream)
+(defun frob-output (stream base start end reuse-sap)
+ (declare (type file-stream stream)
(type (or system-area-pointer (simple-array * (*))) base)
(type index start end))
(if (not (null (fd-stream-output-later stream))) ; something buffered.
(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)))))))
(defun flush-output-buffer (stream)
(let ((length (fd-stream-obuf-tail stream)))
(unless (= length 0)
- (do-output stream (fd-stream-obuf-sap stream) 0 length t)
+ (frob-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
(declare (optimize (speed 1)))
(cons 'progn
(mapcar
- #'(lambda (buffering)
- (let ((function
- (intern (let ((*print-case* :upcase))
- (format nil name-fmt (car buffering))))))
- `(progn
- (defun ,function (stream byte)
- ,(unless (eq (car buffering) :none)
- `(when (< (fd-stream-obuf-length stream)
- (+ (fd-stream-obuf-tail stream)
- ,size))
- (flush-output-buffer stream)))
- ,@body
- (incf (fd-stream-obuf-tail stream) ,size)
- ,(ecase (car buffering)
- (:none
- `(flush-output-buffer stream))
- (:line
- `(when (eq (char-code byte) (char-code #\Newline))
- (flush-output-buffer stream)))
- (:full
- ))
- (values))
- (setf *output-routines*
- (nconc *output-routines*
- ',(mapcar
- #'(lambda (type)
- (list type
- (car buffering)
- function
- size))
- (cdr buffering)))))))
- bufferings)))
+ (lambda (buffering)
+ (let ((function
+ (intern (let ((*print-case* :upcase))
+ (format nil name-fmt (car buffering))))))
+ `(progn
+ (defun ,function (stream byte)
+ ,(unless (eq (car buffering) :none)
+ `(when (< (fd-stream-obuf-length stream)
+ (+ (fd-stream-obuf-tail stream)
+ ,size))
+ (flush-output-buffer stream)))
+ ,(unless (eq (car buffering) :none)
+ `(when (> (fd-stream-ibuf-tail stream)
+ (fd-stream-ibuf-head stream))
+ (file-position stream (file-position stream))))
+
+ ,@body
+ (incf (fd-stream-obuf-tail stream) ,size)
+ ,(ecase (car buffering)
+ (:none
+ `(flush-output-buffer stream))
+ (:line
+ `(when (eq (char-code byte) (char-code #\Newline))
+ (flush-output-buffer stream)))
+ (:full
+ ))
+ (values))
+ (setf *output-routines*
+ (nconc *output-routines*
+ ',(mapcar
+ (lambda (type)
+ (list type
+ (car buffering)
+ function
+ size))
+ (cdr buffering)))))))
+ bufferings)))
(def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
1
(let ((start (or start 0))
(end (or end (length (the (simple-array * (*)) thing)))))
(declare (type index start end))
+ (when (> (fd-stream-ibuf-tail fd-stream)
+ (fd-stream-ibuf-head fd-stream))
+ (file-position fd-stream (file-position fd-stream)))
(let* ((len (fd-stream-obuf-length fd-stream))
(tail (fd-stream-obuf-tail fd-stream))
(space (- len tail))
((<= 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)
- (do-output fd-stream thing start end nil))))))
+ (frob-output fd-stream thing start end nil))))))
;;; the routine to use to output a string. If the stream is
;;; unbuffered, slam the string down the file descriptor, otherwise
(if (stringp thing)
(let ((last-newline (and (find #\newline (the simple-string thing)
:start start :end end)
+ ;; FIXME why do we need both calls?
+ ;; Is find faster forwards than
+ ;; position is backwards?
(position #\newline (the simple-string thing)
:from-end t
:start start
(when last-newline
(flush-output-buffer stream)))
(:none
- (do-output stream thing start end nil)))
+ (frob-output stream thing start end nil)))
(if last-newline
(setf (fd-stream-char-pos stream)
(- end last-newline 1))
((:line :full)
(output-raw-bytes stream thing start end))
(:none
- (do-output stream thing start end nil))))))
+ (frob-output stream thing start end nil))))))
;;; Find an output routine to use given the type and buffering. Return
;;; as multiple values the routine, the real type transfered, and the
;;; Fill the input buffer, and return the first character. Throw to
;;; EOF-INPUT-CATCHER if the eof was reached. Drop into SYSTEM:SERVER
;;; if necessary.
-(defun do-input (stream)
+(defun frob-input (stream)
(let ((fd (fd-stream-fd stream))
(ibuf-sap (fd-stream-ibuf-sap stream))
(buflen (fd-stream-ibuf-length stream))
(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))))
(case count
(1)
(0
- (unless #!-mp (sb!sys:wait-until-fd-usable
- fd :input (fd-stream-timeout stream))
- #!+mp (sb!mp:process-wait-until-fd-usable
- fd :input (fd-stream-timeout stream))
+ (unless (sb!sys:wait-until-fd-usable
+ 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))
(cond ((null count)
(if (eql errno sb!unix:ewouldblock)
(progn
- (unless #!-mp (sb!sys:wait-until-fd-usable
- fd :input (fd-stream-timeout stream))
- #!+mp (sb!mp:process-wait-until-fd-usable
- fd :input (fd-stream-timeout stream))
+ (unless (sb!sys:wait-until-fd-usable
+ 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))))
+ (frob-input stream))
+ (simple-stream-perror "couldn't read from ~S" stream errno)))
((zerop count)
(setf (fd-stream-listen stream) :eof)
+ (/show0 "THROWing EOF-INPUT-CATCHER")
(throw 'eof-input-catcher nil))
(t
(incf (fd-stream-ibuf-tail stream) count))))))
;;; Make sure there are at least BYTES number of bytes in the input
-;;; buffer. Keep calling DO-INPUT until that condition is met.
+;;; buffer. Keep calling FROB-INPUT until that condition is met.
(defmacro input-at-least (stream bytes)
(let ((stream-var (gensym))
(bytes-var (gensym)))
(fd-stream-ibuf-head ,stream-var))
,bytes-var)
(return))
- (do-input ,stream-var)))))
+ (frob-input ,stream-var)))))
;;; a macro to wrap around all input routines to handle EOF-ERROR noise
(defmacro input-wrapper ((stream bytes eof-error eof-value) &body read-forms)
(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.
-(defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p)
- (declare (type fd-stream stream))
- (declare (type index start requested))
- (do ((total-copied 0))
+;;; 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
+ &aux (total-copied 0))
+ (declare (type file-stream stream))
+ (declare (type index start requested total-copied))
+ (let ((unread (fd-stream-unread stream)))
+ (when unread
+ ;; AVERs designed to fail when we have more complicated
+ ;; character representations.
+ (aver (typep unread 'base-char))
+ (aver (= (fd-stream-element-size stream) 1))
+ ;; KLUDGE: this is a slightly-unrolled-and-inlined version of
+ ;; %BYTE-BLT
+ (etypecase buffer
+ (system-area-pointer
+ (setf (sap-ref-8 buffer start) (char-code unread)))
+ ((simple-unboxed-array (*))
+ (setf (aref buffer start) unread)))
+ (setf (fd-stream-unread stream) nil)
+ (setf (fd-stream-listen stream) nil)
+ (incf total-copied)))
+ (do ()
(nil)
- (declare (type index total-copied))
(let* ((remaining-request (- requested total-copied))
(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)
(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)
(fd-stream-bin fd-stream) routine))
(when (eql size 1)
(setf (fd-stream-n-bin fd-stream) #'fd-stream-read-n-bytes)
- (when buffer-p
- (setf (lisp-stream-in-buffer fd-stream)
- (make-array +in-buffer-length+
+ (when (and buffer-p
+ ;; We only create this buffer for streams of type
+ ;; (unsigned-byte 8). Because there's no buffer, the
+ ;; other element-types will dispatch to the appropriate
+ ;; input (output) routine in fast-read-byte.
+ (equal target-type '(unsigned-byte 8))
+ #+nil
+ (or (eq type 'unsigned-byte)
+ (eq type :default)))
+ (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)))
(sb!unix:unix-rename (fd-stream-original fd-stream)
(fd-stream-file fd-stream))
(unless okay
- (error "~@<could not restore ~S to its original ~
- contents: ~2I~_~A~:>"
- (fd-stream-file fd-stream)
- (sb!unix:get-unix-error-msg err))))
+ (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 fd-stream))
(unless okay
- (error "~@<could not remove ~S: ~2I~_~A~:>"
- (fd-stream-file fd-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 fd-stream :finish-output)
(when (and (fd-stream-original fd-stream)
(multiple-value-bind (okay err)
(sb!unix:unix-unlink (fd-stream-original fd-stream))
(unless okay
- (error "~@<could not delete ~S during close ~
- of ~S: ~2I~_~A~:>"
- (fd-stream-original fd-stream)
- fd-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 fd-stream))
(sb!unix:unix-close (fd-stream-fd fd-stream))
0
0))))
(cond ((eql count 1)
- (do-input fd-stream)
+ (frob-input fd-stream)
(setf (fd-stream-ibuf-head fd-stream) 0)
(setf (fd-stream-ibuf-tail fd-stream) 0))
(t
(:element-type
(fd-stream-element-type fd-stream))
(:interactive-p
- ;; FIXME: sb!unix:unix-isatty is undefined.
- (sb!unix:unix-isatty (fd-stream-fd fd-stream)))
+ (= 1 (the (member 0 1)
+ (sb!unix:unix-isatty (fd-stream-fd fd-stream)))))
(:line-length
80)
(:charpos
(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 fd-stream))
(declare (ignore ino nlink uid gid rdev
atime mtime ctime blksize blocks))
(unless okay
- (error "error in Unix fstat(2) on ~S: ~A"
- fd-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 fd-stream)))))
(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))
+ (declare (type file-stream stream)
+ (type (or (alien sb!unix:off-t) (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))
- (cond ((fixnump posn)
+ (declare (type (or (alien sb!unix:off-t) null) posn))
+ (cond ((integerp posn)
;; Adjust for buffered output: If there is any output
;; buffered, the *real* file position will be larger
- ;; than reported by lseek because lseek obviously
+ ;; than reported by lseek() because lseek() obviously
;; cannot take into account output we have not sent
;; yet.
(dolist (later (fd-stream-output-later stream))
- (incf posn (- (the index (caddr later))
- (the index (cadr later)))))
+ (incf posn (- (caddr later)
+ (cadr later))))
(incf posn (fd-stream-obuf-tail stream))
;; Adjust for unread input: If there is any input
;; read from UNIX but not supplied to the user of the
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))
+ (declare (type (alien sb!unix:off-t) offset))
;; Make sure we don't have any output pending, because if we
;; move the file pointer before writing this stuff, it will be
;; written in the wrong location.
(setf offset 0 origin sb!unix:l_set))
((eq newpos :end)
(setf offset 0 origin sb!unix:l_xtnd))
- ((typep newpos 'index)
+ ((typep newpos '(alien sb!unix:off-t))
(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)
+ (cond ((typep posn '(alien sb!unix:off-t))
t)
((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)
input-buffer-p
(name (if file
(format nil "file ~S" file)
- (format nil "descriptor ~D" fd)))
+ (format nil "descriptor ~W" fd)))
auto-close)
(declare (type index fd) (type (or index null) timeout)
(type (member :none :line :full) buffering))
(lambda ()
(sb!unix:unix-close fd)
#!+sb-show
- (format *terminal-io* "** closed file descriptor ~D **~%"
+ (format *terminal-io* "** closed file descriptor ~W **~%"
fd))))
stream))
;;; 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))
- (concatenate 'simple-string name ".bak"))
+ (declare (type simple-base-string name))
+ (concatenate 'simple-base-string name ".bak"))
;;; Ensure that the given arg is one of the given list of valid
;;; things. Allow the user to fix any problems.
;;; 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)
+(defun rename-the-old-one (namestring original)
(unless (sb!unix:unix-access namestring sb!unix:w_ok)
(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
- (error "~@<could not rename ~2I~_~S ~I~_to ~2I~_~S: ~4I~_~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
: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
+ :IF-DOES-NOT-EXIST - one of :ERROR, :CREATE or NIL
See the manual for details."
- (unless (eq external-format :default)
- (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)
(case direction
(:io (values t t sb!unix:o_rdwr))
(:probe (values t nil sb!unix:o_rdonly)))
(declare (type index mask))
- (let* ((pathname (pathname filename))
+ (let* ((pathname (merge-pathnames filename))
(namestring
(cond ((unix-namestring pathname input))
((and input (eq if-does-not-exist :create))
(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))
+ (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.
+ ;; 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
:format-control format-control
:format-arguments format-arguments))
(vanilla-open-error ()
- (open-error "~@<error opening ~S: ~2I~_~A~:>"
- pathname
- (sb!unix:get-unix-error-msg errno))))
+ (simple-file-perror "error opening ~S" pathname errno)))
(cond ((numberp fd)
(case direction
((:input :output :io)
(case if-does-not-exist
(:error (vanilla-open-error))
(:create
- (open-error
- "~@<The path ~2I~_~S ~I~_does not exist.~:>"
- pathname))
+ (open-error "~@<The path ~2I~_~S ~I~_does not exist.~:>"
+ pathname))
(t nil)))
- ((and (eql errno sb!unix:eexist) if-exists)
+ ((and (eql errno sb!unix:eexist) (null if-exists))
nil)
(t
(vanilla-open-error)))))))))
(stream-reinit)
(setf *terminal-io* (make-synonym-stream '*tty*))
(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.
- make-two-way-stream
- #!+high-security
- %make-two-way-stream (make-synonym-stream '*stdin*)
- *standard-output*))
+ (setf *standard-input* (make-synonym-stream '*stdin*))
(setf *error-output* (make-synonym-stream '*stderr*))
(setf *query-io* (make-synonym-stream '*terminal-io*))
(setf *debug-io* *query-io*)
;;; 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)
+ (when (typep stream 'file-stream)
(cond (new-name
(setf (fd-stream-pathname stream) new-name)
(setf (fd-stream-file stream)