X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=fe180be124b9a5e37290ddff78c40a33a9c94a45;hb=b3f188843330c56bd4d17a3c930e73f573b1c71f;hp=6df3f9f8de1796cda6442c4b4f4a2e5c7e3502d3;hpb=aa2dc9529460ea0d9c99998dc87283fc1a43e808;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 6df3f9f..fe180be 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -11,14 +11,6 @@ (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) - ;;;; buffer manipulation routines ;;; FIXME: Is it really good to maintain this pool separate from the @@ -39,11 +31,19 @@ (pop *available-buffers*) (allocate-system-memory bytes-per-buffer))) -;;;; 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)) @@ -87,7 +87,7 @@ (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)))) @@ -107,7 +107,7 @@ :format-control "~@<~?: ~2I~_~A~:>" :format-arguments (list note-format (list stream) (strerror errno)))) (defun simple-file-perror (note-format pathname errno) - (error 'simple-stream-error + (error 'simple-file-error :pathname pathname :format-control "~@<~?: ~2I~_~A~:>" :format-arguments @@ -117,7 +117,7 @@ ;;; 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)) @@ -154,9 +154,9 @@ (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))))) @@ -168,8 +168,8 @@ ;;; 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. @@ -194,47 +194,57 @@ (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)))) +(defmacro output-wrapper ((stream size buffering) &body body) + (let ((stream-var (gensym))) + `(let ((,stream-var ,stream)) + ,(unless (eq (car buffering) :none) + `(when (< (fd-stream-obuf-length ,stream-var) + (+ (fd-stream-obuf-tail ,stream-var) + ,size)) + (flush-output-buffer ,stream-var))) + ,(unless (eq (car buffering) :none) + `(when (> (fd-stream-ibuf-tail ,stream-var) + (fd-stream-ibuf-head ,stream-var)) + (file-position ,stream-var (file-position ,stream-var)))) + + ,@body + (incf (fd-stream-obuf-tail ,stream-var) ,size) + ,(ecase (car buffering) + (:none + `(flush-output-buffer ,stream-var)) + (:line + `(when (eq (char-code byte) (char-code #\Newline)) + (flush-output-buffer ,stream-var))) + (:full)) + (values)))) + ;;; 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-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) + (output-wrapper (stream ,size ,buffering) + ,@body)) + (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 @@ -305,6 +315,9 @@ (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)) @@ -316,41 +329,41 @@ ((<= 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 . (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 . (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 @@ -369,6 +382,9 @@ (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 @@ -381,7 +397,7 @@ (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)) @@ -391,7 +407,7 @@ ((: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 @@ -400,9 +416,60 @@ (dolist (entry *output-routines*) (when (and (subtypep type (car entry)) (eq buffering (cadr entry))) - (return (values (symbol-function (caddr entry)) - (car entry) - (cadddr entry)))))) + (return-from pick-output-routine + (values (symbol-function (caddr entry)) + (car entry) + (cadddr entry))))) + ;; KLUDGE: dealing with the buffering here leads to excessive code + ;; explosion. + ;; + ;; KLUDGE: also see comments in PICK-INPUT-ROUTINE + (loop for i from 40 by 8 to 1024 ; ARB (KLUDGE) + if (subtypep type `(unsigned-byte ,i)) + do (return-from pick-output-routine + (values + (ecase buffering + (:none + (lambda (stream byte) + (output-wrapper (stream (/ i 8) (:none)) + (loop for j from 0 below (/ i 8) + do (setf (sap-ref-8 + (fd-stream-obuf-sap stream) + (+ j (fd-stream-obuf-tail stream))) + (ldb (byte 8 (- i 8 (* j 8))) byte)))))) + (:full + (lambda (stream byte) + (output-wrapper (stream (/ i 8) (:full)) + (loop for j from 0 below (/ i 8) + do (setf (sap-ref-8 + (fd-stream-obuf-sap stream) + (+ j (fd-stream-obuf-tail stream))) + (ldb (byte 8 (- i 8 (* j 8))) byte))))))) + `(unsigned-byte ,i) + (/ i 8)))) + (loop for i from 40 by 8 to 1024 ; ARB (KLUDGE) + if (subtypep type `(signed-byte ,i)) + do (return-from pick-output-routine + (values + (ecase buffering + (:none + (lambda (stream byte) + (output-wrapper (stream (/ i 8) (:none)) + (loop for j from 0 below (/ i 8) + do (setf (sap-ref-8 + (fd-stream-obuf-sap stream) + (+ j (fd-stream-obuf-tail stream))) + (ldb (byte 8 (- i 8 (* j 8))) byte)))))) + (:full + (lambda (stream byte) + (output-wrapper (stream (/ i 8) (:full)) + (loop for j from 0 below (/ i 8) + do (setf (sap-ref-8 + (fd-stream-obuf-sap stream) + (+ j (fd-stream-obuf-tail stream))) + (ldb (byte 8 (- i 8 (* j 8))) byte))))))) + `(signed-byte ,i) + (/ i 8))))) ;;;; input routines and related noise @@ -414,7 +481,7 @@ ;;; 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)) @@ -429,8 +496,8 @@ (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)))) @@ -454,10 +521,8 @@ (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" @@ -470,21 +535,20 @@ (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)) + (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))) @@ -495,7 +559,7 @@ (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) @@ -571,50 +635,97 @@ (defun pick-input-routine (type) (dolist (entry *input-routines*) (when (subtypep type (car entry)) - (return (values (symbol-function (cadr entry)) - (car entry) - (caddr entry)))))) - -;;; Returns a string constructed from the sap, start, and end. + (return-from pick-input-routine + (values (symbol-function (cadr entry)) + (car entry) + (caddr entry))))) + ;; FIXME: let's do it the hard way, then (but ignore things like + ;; endianness, efficiency, and the necessary coupling between these + ;; and the output routines). -- CSR, 2004-02-09 + (loop for i from 40 by 8 to 1024 ; ARB (well, KLUDGE really) + if (subtypep type `(unsigned-byte ,i)) + do (return-from pick-input-routine + (values + (lambda (stream eof-error eof-value) + (input-wrapper (stream (/ i 8) eof-error eof-value) + (let ((sap (fd-stream-ibuf-sap stream)) + (head (fd-stream-ibuf-head stream))) + (loop for j from 0 below (/ i 8) + with result = 0 + do (setf result + (+ (* 256 result) + (sap-ref-8 sap (+ head j)))) + finally (return result))))) + `(unsigned-byte ,i) + (/ i 8)))) + (loop for i from 40 by 8 to 1024 ; ARB (well, KLUDGE really) + if (subtypep type `(signed-byte ,i)) + do (return-from pick-input-routine + (values + (lambda (stream eof-error eof-value) + (let ((sap (fd-stream-ibuf-sap stream)) + (head (fd-stream-ibuf-head stream))) + (loop for j from 0 below (/ i 8) + with result = 0 + do (setf result + (+ (* 256 result) + (sap-ref-8 sap (+ head j)))) + finally (return (dpb result (byte i 0) -1))))) + `(signed-byte ,i) + (/ i 8))))) + +;;; 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) @@ -686,9 +797,17 @@ (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))) @@ -836,7 +955,7 @@ 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 @@ -851,13 +970,23 @@ (: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)) @@ -872,23 +1001,23 @@ (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 @@ -909,7 +1038,7 @@ 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. @@ -929,14 +1058,14 @@ (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) @@ -978,7 +1107,7 @@ 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)) @@ -1000,15 +1129,15 @@ (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. @@ -1023,7 +1152,7 @@ ;;; 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 "~@" namestring)) (multiple-value-bind (okay err) (sb!unix:unix-rename namestring original) @@ -1053,17 +1182,9 @@ :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 @@ -1072,10 +1193,12 @@ (: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)) + (unix-namestring pathname nil)) + ((and (eq direction :io) (not if-does-not-exist-given)) (unix-namestring pathname nil))))) ;; Process if-exists argument if we are doing any output. (cond (output @@ -1090,11 +1213,11 @@ :append :supersede nil) :if-exists) (case if-exists - ((:error nil) + ((:new-version :error nil) (setf mask (logior mask sb!unix:o_excl))) ((:rename :rename-and-delete) (setf mask (logior mask sb!unix:o_creat))) - ((:new-version :supersede) + ((:supersede) (setf mask (logior mask sb!unix:o_trunc))) (:append (setf mask (logior mask sb!unix:o_append))))) @@ -1150,7 +1273,7 @@ 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 @@ -1162,7 +1285,7 @@ (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 @@ -1203,7 +1326,7 @@ (open-error "~@" 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))))))))) @@ -1228,14 +1351,7 @@ (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*) @@ -1275,7 +1391,7 @@ ;;; ;;; 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)