(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)
+ ;; 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))))
;;; writes. If so, just queue this one. Otherwise, try to write it. If
;;; this would block, queue it.
(defun frob-output (stream base start end reuse-sap)
- (declare (type fd-stream stream)
+ (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.
(+ (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)
(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))
(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
(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
(simple-stream-perror "couldn't check whether ~S is readable"
(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))
(frob-input stream))
(simple-stream-perror "couldn't read from ~S" stream errno)))
;;; 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))
- (do ((total-copied 0))
+(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))
(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
+ (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)))))
(: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-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.
(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
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)))
(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)
;;; 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.
: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
(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
(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*)
;;;
;;; 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)