X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=9ba1ec85ee69e80ac8d90172eaa6b62b2e07ea64;hb=550e5afc7ad95ff1e1bbfe932bf8dd81b0c4dce6;hp=3d0e8b7850e44a11aaa2ebda4618d1ea3669fe53;hpb=f0338f6fa732b21daa4405e19465bd460e0526d9;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 3d0e8b7..9ba1ec8 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -43,7 +43,7 @@ (defstruct (fd-stream (:constructor %make-fd-stream) - (:include lisp-stream + (:include ansi-stream (misc #'fd-stream-misc-routine)) (:copier nil)) @@ -100,11 +100,24 @@ 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)) @@ -120,13 +133,11 @@ (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) @@ -143,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))))) @@ -157,7 +168,7 @@ ;;; 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) +(defun frob-output (stream base start end reuse-sap) (declare (type fd-stream stream) (type (or system-area-pointer (simple-array * (*))) base) (type index start end)) @@ -172,11 +183,9 @@ (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))))))) @@ -185,7 +194,7 @@ (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 @@ -194,38 +203,38 @@ (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))) + ,@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 @@ -307,41 +316,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 @@ -372,7 +381,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)) @@ -382,7 +391,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 @@ -405,7 +414,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)) @@ -420,8 +429,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)))) @@ -451,9 +460,9 @@ 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)) @@ -466,18 +475,17 @@ #!+mp (sb!mp:process-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))) @@ -488,7 +496,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) @@ -568,19 +576,22 @@ (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)) @@ -591,23 +602,16 @@ (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) @@ -633,18 +637,10 @@ (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)) ;;;; utility functions (misc routines, etc) @@ -688,8 +684,8 @@ (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+ + (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))) @@ -780,17 +776,20 @@ (sb!unix:unix-rename (fd-stream-original fd-stream) (fd-stream-file fd-stream)) (unless okay - (error "~@" - (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 "~@" - (fd-stream-file fd-stream) - (sb!unix:get-unix-error-msg err))))))) + (error 'simple-file-error + :pathname (fd-stream-file fd-stream) + :format-control + "~@" + :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) @@ -798,11 +797,15 @@ (multiple-value-bind (okay err) (sb!unix:unix-unlink (fd-stream-original fd-stream)) (unless okay - (error "~@" - (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 + "~@" + :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)) @@ -830,7 +833,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 @@ -852,15 +855,23 @@ (: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))))) @@ -872,15 +883,14 @@ (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)) (cond ((fixnump 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)) @@ -902,9 +912,9 @@ 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 @@ -930,7 +940,7 @@ (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) @@ -938,9 +948,9 @@ ((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))))))) ;;;; creation routines (MAKE-FD-STREAM and OPEN) @@ -975,7 +985,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)) @@ -997,7 +1007,7 @@ (lambda () (sb!unix:unix-close fd) #!+sb-show - (format *terminal-io* "** closed file descriptor ~D **~%" + (format *terminal-io* "** closed file descriptor ~W **~%" fd)))) stream)) @@ -1020,17 +1030,17 @@ ;;; 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) - (cond (okay t) - (t - (error "~@" - namestring - original - (sb!unix:get-unix-error-msg err)) - nil)))) + (if okay + t + (error 'simple-file-error + :pathname namestring + :format-control + "~@" + :format-arguments (list namestring original (strerror err)))))) (defun open (filename &key @@ -1069,7 +1079,7 @@ (: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)) @@ -1120,8 +1130,8 @@ (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 @@ -1133,24 +1143,27 @@ (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) @@ -1168,9 +1181,7 @@ :format-control format-control :format-arguments format-arguments)) (vanilla-open-error () - (open-error "~@" - pathname - (sb!unix:get-unix-error-msg errno)))) + (simple-file-perror "error opening ~S" pathname errno))) (cond ((numberp fd) (case direction ((:input :output :io) @@ -1196,9 +1207,8 @@ (case if-does-not-exist (:error (vanilla-open-error)) (:create - (open-error - "~@" - pathname)) + (open-error "~@" + pathname)) (t nil))) ((and (eql errno sb!unix:eexist) if-exists) nil) @@ -1269,6 +1279,8 @@ ;;; 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