X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=753012881470e66e50042b9d7a57e03c82e8b3ce;hb=791e9d15abba835457b308121668a0ce75386a03;hp=61781f065dec8345b25572ffc88a5e5547d71e3f;hpb=26341a4b638f5480993e9715bfb637e560592819;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 61781f0..7530128 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -197,6 +197,30 @@ (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) @@ -209,22 +233,8 @@ (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)) + (output-wrapper (stream ,size ,buffering) + ,@body)) (setf *output-routines* (nconc *output-routines* ',(mapcar @@ -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)) @@ -403,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 @@ -510,7 +574,7 @@ (let ((,element-var (catch 'eof-input-catcher (input-at-least ,stream-var ,bytes) - ,@read-forms))) + (locally ,@read-forms)))) (cond (,element-var (incf (fd-stream-ibuf-head ,stream-var) ,bytes) ,element-var) @@ -571,9 +635,47 @@ (defun pick-input-routine (type) (dolist (entry *input-routines*) (when (subtypep type (car entry)) - (return (values (symbol-function (cadr entry)) - (car entry) - (caddr entry)))))) + (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) + (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 (if (logbitp (1- i) result) + (dpb result (byte i 0) -1) + result)))))) + `(signed-byte ,i) + (/ i 8))))) ;;; Return a string constructed from SAP, START, and END. (defun string-from-sap (sap start end) @@ -591,12 +693,28 @@ ;;; 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) +(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)) - (do ((total-copied 0)) + (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)) @@ -767,27 +885,40 @@ (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. + (cond (arg1 ; We got us an abort on our hands. (when (fd-stream-handler fd-stream) - (sb!sys:remove-fd-handler (fd-stream-handler fd-stream)) - (setf (fd-stream-handler fd-stream) nil)) + (sb!sys:remove-fd-handler (fd-stream-handler fd-stream)) + (setf (fd-stream-handler fd-stream) nil)) + ;; 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. (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 fd-stream) - ;; We have a handle on the original, just revert. - (multiple-value-bind (okay err) - (sb!unix:unix-rename (fd-stream-original fd-stream) - (fd-stream-file fd-stream)) - (unless okay - (simple-stream-perror - "couldn't restore ~S to its original contents" - fd-stream - err))) - ;; We can't restore the original, so nuke that puppy. + ;; If the original is EQ to file we are appending + ;; and can just close the file without renaming. + (unless (eq (fd-stream-original fd-stream) + (fd-stream-file fd-stream)) + ;; We have a handle on the original, just revert. + (multiple-value-bind (okay err) + (sb!unix:unix-rename (fd-stream-original fd-stream) + (fd-stream-file fd-stream)) + (unless okay + (simple-stream-perror + "couldn't restore ~S to its original contents" + fd-stream + err)))) + ;; We can't restore the original, and aren't + ;; appending, so nuke that puppy. + ;; + ;; FIXME: This is currently the fate of superseded + ;; files, and according to the CLOSE spec this is + ;; wrong. However, there seems to be no clean way to + ;; do that that doesn't involve either copying the + ;; data (bad if the :abort resulted from a full + ;; disk), or renaming the old file temporarily + ;; (probably bad because stream opening becomes more + ;; racy). (multiple-value-bind (okay err) (sb!unix:unix-unlink (fd-stream-file fd-stream)) (unless okay @@ -855,7 +986,6 @@ (:element-type (fd-stream-element-type fd-stream)) (:interactive-p - ;; FIXME: sb!unix:unix-isatty is undefined. (= 1 (the (member 0 1) (sb!unix:unix-isatty (fd-stream-fd fd-stream))))) (:line-length @@ -888,22 +1018,22 @@ (defun fd-stream-file-position (stream &optional newpos) (declare (type file-stream stream) - (type (or index (member nil :start :end)) newpos)) + (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 ;; 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 @@ -924,7 +1054,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. @@ -944,14 +1074,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) @@ -1071,6 +1201,8 @@ :IF-DOES-NOT-EXIST - one of :ERROR, :CREATE or NIL See the manual for details." + (declare (ignore external-format)) ; FIXME: CHECK-TYPE? WARN-if-not? + ;; Calculate useful stuff. (multiple-value-bind (input output mask) (case direction @@ -1083,6 +1215,8 @@ (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 @@ -1097,11 +1231,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))))) @@ -1124,12 +1258,16 @@ (if (eq if-does-not-exist :create) (setf mask (logior mask sb!unix:o_creat))) - (let ((original (if (member if-exists - '(:rename :rename-and-delete)) - (pick-backup-name namestring))) + (let ((original (case if-exists + ((:rename :rename-and-delete) + (pick-backup-name namestring)) + ((:append) + ;; KLUDGE: Provent CLOSE from deleting + ;; appending streams when called with :ABORT T + namestring))) (delete-original (eq if-exists :rename-and-delete)) (mode #o666)) - (when original + (when (and original (not (eq original namestring))) ;; We are doing a :RENAME or :RENAME-AND-DELETE. Determine ;; whether the file already exists, make sure the original ;; file is not a directory, and keep the mode. @@ -1210,7 +1348,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)))))))))