X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=9ba1ec85ee69e80ac8d90172eaa6b62b2e07ea64;hb=550e5afc7ad95ff1e1bbfe932bf8dd81b0c4dce6;hp=41d8d97fd704a3a270725d62abb97da5eb586fa4;hpb=a26fc2e03904bd0dac626a43e169e2e3514344d4;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 41d8d97..9ba1ec8 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -21,7 +21,8 @@ ;;;; buffer manipulation routines -;;; FIXME: Is it really good to maintain this pool separate from the GC? +;;; FIXME: Is it really good to maintain this pool separate from the +;;; GC and the C malloc logic? (defvar *available-buffers* () #!+sb-doc "List of available buffers. Each buffer is an sap pointing to @@ -42,43 +43,49 @@ (defstruct (fd-stream (:constructor %make-fd-stream) - (:include lisp-stream - (misc #'fd-stream-misc-routine))) - - (name nil) ; The name of this stream - (file nil) ; The file this stream is for - ;; The backup file namestring for the old file, for :if-exists :rename or - ;; :rename-and-delete. + (:include ansi-stream + (misc #'fd-stream-misc-routine)) + (:copier nil)) + + ;; the name of this stream + (name nil) + ;; the file this stream is for + (file nil) + ;; the backup file namestring for the old file, for :IF-EXISTS + ;; :RENAME or :RENAME-AND-DELETE. (original nil :type (or simple-string null)) (delete-original nil) ; for :if-exists :rename-and-delete - ;;; Number of bytes per element. + ;;; the number of bytes per element (element-size 1 :type index) - (element-type 'base-char) ; The type of element being transfered. - (fd -1 :type fixnum) ; The file descriptor - ;; Controls when the output buffer is flushed. + ;; the type of element being transfered + (element-type 'base-char) + ;; the Unix file descriptor + (fd -1 :type fixnum) + ;; controls when the output buffer is flushed (buffering :full :type (member :full :line :none)) - ;; Character position if known. + ;; character position (if known) (char-pos nil :type (or index null)) ;; T if input is waiting on FD. :EOF if we hit EOF. (listen nil :type (member nil t :eof)) - ;; The input buffer. + + ;; the input buffer (unread nil) (ibuf-sap nil :type (or system-area-pointer null)) (ibuf-length nil :type (or index null)) (ibuf-head 0 :type index) (ibuf-tail 0 :type index) - ;; The output buffer. + ;; the output buffer (obuf-sap nil :type (or system-area-pointer null)) (obuf-length nil :type (or index null)) (obuf-tail 0 :type index) - ;; Output flushed, but not written due to non-blocking io. + ;; output flushed, but not written due to non-blocking io? (output-later nil) (handler nil) - ;; Timeout specified for this stream, or NIL if none. + ;; timeout specified for this stream, or NIL if none (timeout nil :type (or index null)) - ;; Pathname of the file this stream is opened to (returned by PATHNAME.) + ;; 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) (declare (type stream stream)) @@ -93,10 +100,24 @@ element-type output, the kind of buffering, the function name, and the number of bytes per element.") -;;; 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) +;;; 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 frob-output-later (stream) (let* ((stuff (pop (fd-stream-output-later stream))) (base (car stuff)) (start (cadr stuff)) @@ -112,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) @@ -135,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))))) @@ -146,10 +165,10 @@ (setf (fd-stream-obuf-sap stream) new-buffer) (setf (fd-stream-obuf-length stream) bytes-per-buffer)))) -;;; 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) +;;; 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 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)) @@ -164,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))))))) @@ -177,47 +194,47 @@ (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 -;;; given bufferings. Use body to do the actual output. -(defmacro def-output-routines ((name size &rest bufferings) &body body) +;;; 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 (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 @@ -275,11 +292,12 @@ (fd-stream-obuf-tail stream)) byte)) -;;; Does the actual output. If there is space to buffer the string, buffer -;;; it. If the string would normally fit in the buffer, but doesn't because -;;; of other stuff in the buffer, flush the old noise out of the buffer and -;;; put the string in it. Otherwise we have a very long string, so just -;;; send it directly (after flushing the buffer, of course). +;;; Do the actual output. If there is space to buffer the string, +;;; buffer it. If the string would normally fit in the buffer, but +;;; doesn't because of other stuff in the buffer, flush the old noise +;;; out of the buffer and put the string in it. Otherwise we have a +;;; very long string, so just send it directly (after flushing the +;;; buffer, of course). (defun output-raw-bytes (fd-stream thing &optional start end) #!+sb-doc "Output THING to FD-STREAM. THING can be any kind of vector or a SAP. If @@ -293,57 +311,55 @@ (bytes (- end start)) (newtail (+ tail bytes))) (cond ((minusp bytes) ; error case - (cerror "Just go on as if nothing happened." - "~S called with :END before :START!" - 'output-raw-bytes)) - ((zerop bytes)) ; Easy case + (error ":END before :START!")) + ((zerop bytes)) ; easy case ((<= 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)))))) -;;; Routine to use to output a string. If the stream is unbuffered, slam -;;; the string down the file descriptor, otherwise use OUTPUT-RAW-BYTES to -;;; buffer the string. Update charpos by checking to see where the last newline -;;; was. +;;; the routine to use to output a string. If the stream is +;;; unbuffered, slam the string down the file descriptor, otherwise +;;; use OUTPUT-RAW-BYTES to buffer the string. Update charpos by +;;; checking to see where the last newline was. ;;; -;;; Note: some bozos (the FASL dumper) call write-string with things other -;;; than strings. Therefore, we must make sure we have a string before calling -;;; position on it. +;;; Note: some bozos (the FASL dumper) call write-string with things +;;; other than strings. Therefore, we must make sure we have a string +;;; before calling POSITION on it. ;;; KLUDGE: It would be better to fix the bozos instead of trying to ;;; cover for them here. -- WHN 20000203 (defun fd-sout (stream thing start end) @@ -365,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)) @@ -375,11 +391,11 @@ ((: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 number of -;;; bytes per element. +;;; Find an output routine to use given the type and buffering. Return +;;; as multiple values the routine, the real type transfered, and the +;;; number of bytes per element. (defun pick-output-routine (type buffering) (dolist (entry *output-routines*) (when (and (subtypep type (car entry)) @@ -390,15 +406,15 @@ ;;;; input routines and related noise -(defvar *input-routines* () - #!+sb-doc - "List of all available input routines. Each element is a list of the - element-type input, the function name, and the number of bytes per element.") +;;; a list of all available input routines. Each element is a list of +;;; the element-type input, the function name, and the number of bytes +;;; per element. +(defvar *input-routines* ()) -;;; Fills the input buffer, and returns the first character. Throws to -;;; eof-input-catcher if the eof was reached. Drops into system:server if -;;; necessary. -(defun do-input (stream) +;;; 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 frob-input (stream) (let ((fd (fd-stream-fd stream)) (ibuf-sap (fd-stream-ibuf-sap stream)) (buflen (fd-stream-ibuf-length stream)) @@ -413,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)))) @@ -444,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)) @@ -459,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)))))) -;;; Makes sure there are at least ``bytes'' number of bytes in the input -;;; buffer. Keeps calling do-input until that condition is met. +;;; Make sure there are at least BYTES number of bytes in the input +;;; buffer. Keep calling FROB-INPUT until that condition is met. (defmacro input-at-least (stream bytes) (let ((stream-var (gensym)) (bytes-var (gensym))) @@ -481,11 +496,9 @@ (fd-stream-ibuf-head ,stream-var)) ,bytes-var) (return)) - (do-input ,stream-var))))) + (frob-input ,stream-var))))) -;;; INPUT-WRAPPER -- intenal -;;; -;;; Macro to wrap around all input routines to handle eof-error noise. +;;; 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) (let ((stream-var (gensym)) (element-var (gensym))) @@ -505,7 +518,6 @@ (t (eof-or-lose ,stream-var ,eof-error ,eof-value)))))))) -;;; Defines an input routine. (defmacro def-input-routine (name (type size sap head) &rest body) @@ -519,43 +531,44 @@ (nconc *input-routines* (list (list ',type ',name ',size)))))) -;;; Routine to use in stream-in slot for reading string chars. +;;; STREAM-IN routine for reading a string char (def-input-routine input-character (character 1 sap head) (code-char (sap-ref-8 sap head))) -;;; Routine to read in an unsigned 8 bit number. +;;; STREAM-IN routine for reading an unsigned 8 bit number (def-input-routine input-unsigned-8bit-byte ((unsigned-byte 8) 1 sap head) (sap-ref-8 sap head)) -;;; Routine to read in a signed 8 bit number. +;;; STREAM-IN routine for reading a signed 8 bit number (def-input-routine input-signed-8bit-number ((signed-byte 8) 1 sap head) (signed-sap-ref-8 sap head)) -;;; Routine to read in an unsigned 16 bit number. +;;; STREAM-IN routine for reading an unsigned 16 bit number (def-input-routine input-unsigned-16bit-byte ((unsigned-byte 16) 2 sap head) (sap-ref-16 sap head)) -;;; Routine to read in a signed 16 bit number. +;;; STREAM-IN routine for reading a signed 16 bit number (def-input-routine input-signed-16bit-byte ((signed-byte 16) 2 sap head) (signed-sap-ref-16 sap head)) -;;; Routine to read in a unsigned 32 bit number. +;;; STREAM-IN routine for reading a unsigned 32 bit number (def-input-routine input-unsigned-32bit-byte ((unsigned-byte 32) 4 sap head) (sap-ref-32 sap head)) -;;; Routine to read in a signed 32 bit number. +;;; STREAM-IN routine for reading a signed 32 bit number (def-input-routine input-signed-32bit-byte ((signed-byte 32) 4 sap head) (signed-sap-ref-32 sap head)) -;;; Find an input routine to use given the type. Return as multiple values -;;; the routine, the real type transfered, and the number of bytes per element. +;;; Find an input routine to use given the type. Return as multiple +;;; values the routine, the real type transfered, and the number of +;;; bytes per element. (defun pick-input-routine (type) (dolist (entry *input-routines*) (when (subtypep type (car entry)) @@ -563,118 +576,21 @@ (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)) -;;; old version, not good for implementing READ-SEQUENCE (and just complex) -;;; FIXME: Remove once new FD-STREAM-READ-N-BYTES (below) is stable. -#+nil -(defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p) - (declare (type stream stream) (type index start requested)) - (let* ((sap (fd-stream-ibuf-sap stream)) - (offset start) - (head (fd-stream-ibuf-head stream)) - (tail (fd-stream-ibuf-tail stream)) - (available (- tail head)) - (copy (min requested available))) - (declare (type index offset head tail available copy)) - (unless (zerop copy) - (if (typep buffer 'system-area-pointer) - (system-area-copy sap (* head sb!vm:byte-bits) - buffer (* offset sb!vm:byte-bits) - (* copy sb!vm:byte-bits)) - (copy-from-system-area sap (* head sb!vm:byte-bits) - buffer (+ (* offset sb!vm:byte-bits) - (* sb!vm:vector-data-offset - sb!vm:word-bits)) - (* copy sb!vm:byte-bits))) - (incf (fd-stream-ibuf-head stream) copy)) - (cond - ((or (= copy requested) - (and (not eof-error-p) (/= copy 0))) - copy) - (t - (setf (fd-stream-ibuf-head stream) 0) - (setf (fd-stream-ibuf-tail stream) 0) - (setf (fd-stream-listen stream) nil) - (let ((now-needed (- requested copy)) - (len (fd-stream-ibuf-length stream))) - (declare (type index now-needed len)) - (cond - ((> now-needed len) - ;; If the desired amount is greater than the stream buffer size, then - ;; read directly into the destination, incrementing the start - ;; accordingly. In this case, we never leave anything in the stream - ;; buffer. - (sb!sys:without-gcing - (loop - (multiple-value-bind (count err) - (sb!unix:unix-read (fd-stream-fd stream) - (sap+ (if (typep buffer - 'system-area-pointer) - buffer - (vector-sap buffer)) - (+ offset copy)) - now-needed) - (declare (type (or index null) count)) - (unless count - (error "error reading ~S: ~A" - stream - (sb!unix:get-unix-error-msg err))) - (if eof-error-p - (when (zerop count) - (error 'end-of-file :stream stream)) - (return (- requested now-needed))) - (decf now-needed count) - (when (zerop now-needed) - (return requested)) - (incf offset count))))) - (t - ;; If we want less than the buffer size, then loop trying to fill the - ;; stream buffer and copying what we get into the destination. When - ;; we have enough, we leave what's left in the stream buffer. - (loop - (multiple-value-bind (count err) - (sb!unix:unix-read (fd-stream-fd stream) sap len) - (declare (type (or index null) count)) - (unless count - (error "error reading ~S: ~A" - stream - (sb!unix:get-unix-error-msg err))) - (when (and eof-error-p (zerop count)) - (error 'end-of-file :stream stream)) - - (let* ((copy (min now-needed count)) - (copy-bits (* copy sb!vm:byte-bits)) - (buffer-start-bits - (* (+ offset available) sb!vm:byte-bits))) - (declare (type index copy copy-bits buffer-start-bits)) - (if (typep buffer 'system-area-pointer) - (system-area-copy sap 0 - buffer buffer-start-bits - copy-bits) - (copy-from-system-area sap 0 - buffer (+ buffer-start-bits - (* sb!vm:vector-data-offset - sb!vm:word-bits)) - copy-bits)) - - (decf now-needed copy) - (when (or (zerop now-needed) (not eof-error-p)) - (setf (fd-stream-ibuf-head stream) copy) - (setf (fd-stream-ibuf-tail stream) count) - (return (- requested now-needed))) - (incf offset copy))))))))))) - -;;; 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 +;;; 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)) @@ -686,79 +602,53 @@ (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)) - #+nil - (format t - "/TOTAL-COPIED=~D HEAD=~D TAIL=~D THIS-COPY=~D~%" - total-copied - head - tail - 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) - #+nil - (format t "/enough data~%") (return total-copied)) (;; If EOF, we're done in another way. (zerop (refill-fd-stream-buffer stream)) - #+nil - (format t "/end of file~%") (if eof-error-p (error 'end-of-file :stream stream) (return total-copied))) - ;; Otherwise we refilled the stream buffer, so fall through into - ;; another pass of the loop. + ;; Otherwise we refilled the stream buffer, so fall + ;; through into another pass of the loop. )))) -;;; Try to refill the stream buffer. Return the number of bytes read. (For EOF, -;;; the return value will be zero, otherwise positive.) +;;; Try to refill the stream buffer. Return the number of bytes read. +;;; (For EOF, the return value will be zero, otherwise positive.) (defun refill-fd-stream-buffer (stream) ;; We don't have any logic to preserve leftover bytes in the buffer, ;; so we should only be called when the buffer is empty. - (assert (= (fd-stream-ibuf-head stream) (fd-stream-ibuf-tail stream))) + (aver (= (fd-stream-ibuf-head stream) (fd-stream-ibuf-tail stream))) (multiple-value-bind (count err) (sb!unix:unix-read (fd-stream-fd stream) (fd-stream-ibuf-sap stream) (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) -;;; Fill in the various routine slots for the given type. Input-p and -;;; output-p indicate what slots to fill. The buffering slot must be set prior -;;; to calling this routine. -(defun set-routines (stream type input-p output-p buffer-p) +;;; Fill in the various routine slots for the given type. INPUT-P and +;;; OUTPUT-P indicate what slots to fill. The buffering slot must be +;;; set prior to calling this routine. +(defun set-fd-stream-routines (fd-stream type input-p output-p buffer-p) (let ((target-type (case type ((:default unsigned-byte) '(unsigned-byte 8)) @@ -771,57 +661,57 @@ (input-size nil) (output-size nil)) - (when (fd-stream-obuf-sap stream) - (push (fd-stream-obuf-sap stream) *available-buffers*) - (setf (fd-stream-obuf-sap stream) nil)) - (when (fd-stream-ibuf-sap stream) - (push (fd-stream-ibuf-sap stream) *available-buffers*) - (setf (fd-stream-ibuf-sap stream) nil)) + (when (fd-stream-obuf-sap fd-stream) + (push (fd-stream-obuf-sap fd-stream) *available-buffers*) + (setf (fd-stream-obuf-sap fd-stream) nil)) + (when (fd-stream-ibuf-sap fd-stream) + (push (fd-stream-ibuf-sap fd-stream) *available-buffers*) + (setf (fd-stream-ibuf-sap fd-stream) nil)) (when input-p (multiple-value-bind (routine type size) (pick-input-routine target-type) (unless routine (error "could not find any input routine for ~S" target-type)) - (setf (fd-stream-ibuf-sap stream) (next-available-buffer)) - (setf (fd-stream-ibuf-length stream) bytes-per-buffer) - (setf (fd-stream-ibuf-tail stream) 0) + (setf (fd-stream-ibuf-sap fd-stream) (next-available-buffer)) + (setf (fd-stream-ibuf-length fd-stream) bytes-per-buffer) + (setf (fd-stream-ibuf-tail fd-stream) 0) (if (subtypep type 'character) - (setf (fd-stream-in stream) routine - (fd-stream-bin stream) #'ill-bin) - (setf (fd-stream-in stream) #'ill-in - (fd-stream-bin stream) routine)) + (setf (fd-stream-in fd-stream) routine + (fd-stream-bin fd-stream) #'ill-bin) + (setf (fd-stream-in fd-stream) #'ill-in + (fd-stream-bin fd-stream) routine)) (when (eql size 1) - (setf (fd-stream-n-bin stream) #'fd-stream-read-n-bytes) + (setf (fd-stream-n-bin fd-stream) #'fd-stream-read-n-bytes) (when buffer-p - (setf (lisp-stream-in-buffer 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))) (when output-p (multiple-value-bind (routine type size) - (pick-output-routine target-type (fd-stream-buffering stream)) + (pick-output-routine target-type (fd-stream-buffering fd-stream)) (unless routine (error "could not find any output routine for ~S buffered ~S" - (fd-stream-buffering stream) + (fd-stream-buffering fd-stream) target-type)) - (setf (fd-stream-obuf-sap stream) (next-available-buffer)) - (setf (fd-stream-obuf-length stream) bytes-per-buffer) - (setf (fd-stream-obuf-tail stream) 0) + (setf (fd-stream-obuf-sap fd-stream) (next-available-buffer)) + (setf (fd-stream-obuf-length fd-stream) bytes-per-buffer) + (setf (fd-stream-obuf-tail fd-stream) 0) (if (subtypep type 'character) - (setf (fd-stream-out stream) routine - (fd-stream-bout stream) #'ill-bout) - (setf (fd-stream-out stream) + (setf (fd-stream-out fd-stream) routine + (fd-stream-bout fd-stream) #'ill-bout) + (setf (fd-stream-out fd-stream) (or (if (eql size 1) (pick-output-routine 'base-char - (fd-stream-buffering stream))) + (fd-stream-buffering fd-stream))) #'ill-out) - (fd-stream-bout stream) routine)) - (setf (fd-stream-sout stream) + (fd-stream-bout fd-stream) routine)) + (setf (fd-stream-sout fd-stream) (if (eql size 1) #'fd-sout #'ill-out)) - (setf (fd-stream-char-pos stream) 0) + (setf (fd-stream-char-pos fd-stream) 0) (setf output-size size) (setf output-type type))) @@ -830,10 +720,10 @@ (error "Element sizes for input (~S:~S) and output (~S:~S) differ?" input-type input-size output-type output-size)) - (setf (fd-stream-element-size stream) + (setf (fd-stream-element-size fd-stream) (or input-size output-size)) - (setf (fd-stream-element-type stream) + (setf (fd-stream-element-type fd-stream) (cond ((equal input-type output-type) input-type) ((null output-type) @@ -849,158 +739,169 @@ input-type output-type)))))) -;;; Handle miscellaneous operations on fd-stream. -(defun fd-stream-misc-routine (stream operation &optional arg1 arg2) +;;; Handle miscellaneous operations on FD-STREAM. +(defun fd-stream-misc-routine (fd-stream operation &optional arg1 arg2) (declare (ignore arg2)) - ;; FIXME: Declare TYPE FD-STREAM STREAM? (case operation (:listen - (or (not (eql (fd-stream-ibuf-head stream) - (fd-stream-ibuf-tail stream))) - (fd-stream-listen stream) - (setf (fd-stream-listen stream) + (or (not (eql (fd-stream-ibuf-head fd-stream) + (fd-stream-ibuf-tail fd-stream))) + (fd-stream-listen fd-stream) + (setf (fd-stream-listen fd-stream) (eql (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set))) (sb!unix:fd-zero read-fds) - (sb!unix:fd-set (fd-stream-fd stream) read-fds) - (sb!unix:unix-fast-select (1+ (fd-stream-fd stream)) + (sb!unix:fd-set (fd-stream-fd fd-stream) read-fds) + (sb!unix:unix-fast-select (1+ (fd-stream-fd fd-stream)) (sb!alien:addr read-fds) nil nil 0 0)) 1)))) (:unread - (setf (fd-stream-unread stream) arg1) - (setf (fd-stream-listen stream) t)) + (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. - (when (fd-stream-handler stream) - (sb!sys:remove-fd-handler (fd-stream-handler stream)) - (setf (fd-stream-handler stream) nil)) - (when (and (fd-stream-file stream) - (fd-stream-obuf-sap stream)) - ;; 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 stream) + (when (fd-stream-handler fd-stream) + (sb!sys:remove-fd-handler (fd-stream-handler fd-stream)) + (setf (fd-stream-handler fd-stream) nil)) + (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 stream) - (fd-stream-file stream)) + (sb!unix:unix-rename (fd-stream-original fd-stream) + (fd-stream-file fd-stream)) (unless okay - (cerror "Go on as if nothing bad happened." - "could not restore ~S to its original contents: ~A" - (fd-stream-file stream) - (sb!unix:get-unix-error-msg err)))) - ;; Can't restore the orignal, so nuke that puppy. + (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 stream)) + (sb!unix:unix-unlink (fd-stream-file fd-stream)) (unless okay - (cerror "Go on as if nothing bad happened." - "Could not remove ~S: ~A" - (fd-stream-file 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 stream :finish-output) - (when (and (fd-stream-original stream) - (fd-stream-delete-original stream)) + (fd-stream-misc-routine fd-stream :finish-output) + (when (and (fd-stream-original fd-stream) + (fd-stream-delete-original fd-stream)) (multiple-value-bind (okay err) - (sb!unix:unix-unlink (fd-stream-original stream)) + (sb!unix:unix-unlink (fd-stream-original fd-stream)) (unless okay - (cerror "Go on as if nothing bad happened." - "could not delete ~S during close of ~S: ~A" - (fd-stream-original stream) - 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 stream)) - (sb!unix:unix-close (fd-stream-fd stream)) - (when (fd-stream-obuf-sap stream) - (push (fd-stream-obuf-sap stream) *available-buffers*) - (setf (fd-stream-obuf-sap stream) nil)) - (when (fd-stream-ibuf-sap stream) - (push (fd-stream-ibuf-sap stream) *available-buffers*) - (setf (fd-stream-ibuf-sap stream) nil)) - (sb!impl::set-closed-flame stream)) + (cancel-finalization fd-stream)) + (sb!unix:unix-close (fd-stream-fd fd-stream)) + (when (fd-stream-obuf-sap fd-stream) + (push (fd-stream-obuf-sap fd-stream) *available-buffers*) + (setf (fd-stream-obuf-sap fd-stream) nil)) + (when (fd-stream-ibuf-sap fd-stream) + (push (fd-stream-ibuf-sap fd-stream) *available-buffers*) + (setf (fd-stream-ibuf-sap fd-stream) nil)) + (sb!impl::set-closed-flame fd-stream)) (:clear-input - (setf (fd-stream-unread stream) nil) - (setf (fd-stream-ibuf-head stream) 0) - (setf (fd-stream-ibuf-tail stream) 0) + (setf (fd-stream-unread fd-stream) nil) + (setf (fd-stream-ibuf-head fd-stream) 0) + (setf (fd-stream-ibuf-tail fd-stream) 0) (catch 'eof-input-catcher (loop (let ((count (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set))) (sb!unix:fd-zero read-fds) - (sb!unix:fd-set (fd-stream-fd stream) read-fds) - (sb!unix:unix-fast-select (1+ (fd-stream-fd stream)) - (sb!alien:addr read-fds) - nil - nil - 0 - 0)))) + (sb!unix:fd-set (fd-stream-fd fd-stream) read-fds) + (sb!unix:unix-fast-select (1+ (fd-stream-fd fd-stream)) + (sb!alien:addr read-fds) + nil + nil + 0 + 0)))) (cond ((eql count 1) - (do-input stream) - (setf (fd-stream-ibuf-head stream) 0) - (setf (fd-stream-ibuf-tail stream) 0)) + (frob-input fd-stream) + (setf (fd-stream-ibuf-head fd-stream) 0) + (setf (fd-stream-ibuf-tail fd-stream) 0)) (t (return t))))))) (:force-output - (flush-output-buffer stream)) + (flush-output-buffer fd-stream)) (:finish-output - (flush-output-buffer stream) + (flush-output-buffer fd-stream) (do () - ((null (fd-stream-output-later stream))) + ((null (fd-stream-output-later fd-stream))) (sb!sys:serve-all-events))) (:element-type - (fd-stream-element-type stream)) + (fd-stream-element-type fd-stream)) (:interactive-p - (sb!unix:unix-isatty (fd-stream-fd stream))) + ;; FIXME: sb!unix:unix-isatty is undefined. + (sb!unix:unix-isatty (fd-stream-fd fd-stream))) (:line-length 80) (:charpos - (fd-stream-char-pos stream)) + (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 stream)) + (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 fstat'ing ~S: ~A" - stream - (sb!unix:get-unix-error-msg dev))) - (if (zerop (the index mode)) + (simple-stream-perror "failed Unix fstat(2) on ~S" fd-stream dev)) + (if (zerop mode) nil - ;; FIXME: It's not safe to assume that SIZE is an INDEX, there - ;; are files bigger than that. - (truncate (the index size) (fd-stream-element-size stream))))) + (truncate size (fd-stream-element-size fd-stream))))) (:file-position - (fd-stream-file-position stream arg1)))) + (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)) (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 cannot take into account output we have not - ;; sent yet. + ;; 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 (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, the *real* file position will - ;; smaller than reported, because we want to look like the - ;; unread stuff is still available. + ;; Adjust for unread input: If there is any input + ;; read from UNIX but not supplied to the user of the + ;; stream, the *real* file position will smaller than + ;; reported, because we want to look like the unread + ;; stuff is still available. (decf posn (- (fd-stream-ibuf-tail stream) (fd-stream-ibuf-head stream))) (when (fd-stream-unread stream) @@ -1011,20 +912,20 @@ 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 move the - ;; file pointer before writing this stuff, it will be written in the - ;; wrong location. + ;; 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. (flush-output-buffer stream) (do () ((null (fd-stream-output-later stream))) (sb!sys:serve-all-events)) - ;; Clear out any pending input to force the next read to go to the - ;; disk. + ;; Clear out any pending input to force the next read to go to + ;; the disk. (setf (fd-stream-unread stream) nil) (setf (fd-stream-ibuf-head stream) 0) (setf (fd-stream-ibuf-tail stream) 0) @@ -1039,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) @@ -1047,13 +948,29 @@ ((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) -;;; Returns a FD-STREAM on the given file. +;;; Create a stream for the given Unix file descriptor. +;;; +;;; If INPUT is non-NIL, allow input operations. If OUTPUT is non-nil, +;;; allow output operations. If neither INPUT nor OUTPUT is specified, +;;; default to allowing input. +;;; +;;; ELEMENT-TYPE indicates the element type to use (as for OPEN). +;;; +;;; BUFFERING indicates the kind of buffering to use. +;;; +;;; TIMEOUT (if true) is the number of seconds to wait for input. If +;;; NIL (the default), then wait forever. When we time out, we signal +;;; IO-TIMEOUT. +;;; +;;; FILE is the name of the file (will be returned by PATHNAME). +;;; +;;; NAME is used to identify the stream when printed. (defun make-fd-stream (fd &key (input nil input-p) @@ -1068,21 +985,10 @@ 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)) - #!+sb-doc - "Create a stream for the given unix file descriptor. - If input is non-nil, allow input operations. - If output is non-nil, allow output operations. - If neither input nor output are specified, default to allowing input. - Element-type indicates the element type to use (as for open). - Buffering indicates the kind of buffering to use. - Timeout (if true) is the number of seconds to wait for input. If NIL (the - default), then wait forever. When we time out, we signal IO-TIMEOUT. - File is the name of the file (will be returned by PATHNAME). - Name is used to identify the stream when printed." (cond ((not (or input-p output-p)) (setf input t)) ((not (or input output)) @@ -1095,65 +1001,46 @@ :pathname pathname :buffering buffering :timeout timeout))) - (set-routines stream element-type input output input-buffer-p) + (set-fd-stream-routines stream element-type input output input-buffer-p) (when (and auto-close (fboundp 'finalize)) (finalize stream (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. -(defvar *backup-extension* ".BAK" - #!+sb-doc - "This is a string that OPEN tacks on the end of a file namestring to produce - a name for the :if-exists :rename-and-delete and :rename options. Also, - this can be a function that takes a namestring and returns a complete - namestring.") +;;; 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)) - (let ((ext *backup-extension*)) - (etypecase ext - (simple-string (concatenate 'simple-string name ext)) - (function (funcall ext name))))) - -;;; Ensure that the given arg is one of the given list of valid things. -;;; Allow the user to fix any problems. -;;; FIXME: Why let the user fix any problems? + (concatenate 'simple-string name ".bak")) + +;;; Ensure that the given arg is one of the given list of valid +;;; things. Allow the user to fix any problems. (defun ensure-one-of (item list what) (unless (member item list) - (loop - (cerror "Enter new value for ~*~S" - "~S is invalid for ~S. Must be one of~{ ~S~}" - item - what - list) - (format (the stream *query-io*) "Enter new value for ~S: " what) - (force-output *query-io*) - (setf item (read *query-io*)) - (when (member item list) - (return)))) - item) - -;;; 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) + (error 'simple-type-error + :datum item + :expected-type `(member ,@list) + :format-control "~@<~S is ~_invalid for ~S; ~_need one of~{ ~S~}~:>" + :format-arguments (list item what list)))) + +;;; 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 rename-the-old-one (namestring original) (unless (sb!unix:unix-access namestring sb!unix:w_ok) - (cerror "Try to rename it anyway." - "File ~S is not writable." - namestring)) + (error "~@" namestring)) (multiple-value-bind (okay err) (sb!unix:unix-rename namestring original) - (cond (okay t) - (t - (cerror "Use :SUPERSEDE instead." - "Could not rename ~S to ~S: ~A." - 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 @@ -1167,28 +1054,22 @@ (if-does-not-exist if-does-not-exist) (if-exists if-exists)) #!+sb-doc - "Return a stream which reads from or writes to Filename. + "Return a stream which reads from or writes to FILENAME. Defined keywords: - :direction - one of :input, :output, :io, or :probe - :element-type - 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 + :DIRECTION - one of :INPUT, :OUTPUT, :IO, or :PROBE + :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 See the manual for details." (unless (eq external-format :default) - (error 'simple-error - :format-control - "Any external format other than :DEFAULT isn't recognized.")) - - ;; First, make sure that DIRECTION is valid. Allow it to be changed - ;; if not. - ;; - ;; FIXME: Why allow it to be changed if not? - (setf direction - (ensure-one-of direction - '(:input :output :io :probe) - :direction)) + (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) @@ -1198,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)) @@ -1210,12 +1091,11 @@ (if (eq (pathname-version pathname) :newest) :new-version :error))) - (setf if-exists ; FIXME: should just die, not allow resetting - (ensure-one-of if-exists - '(:error :new-version :rename - :rename-and-delete :overwrite - :append :supersede nil) - :if-exists)) + (ensure-one-of if-exists + '(:error :new-version :rename + :rename-and-delete :overwrite + :append :supersede nil) + :if-exists) (case if-exists ((:error nil) (setf mask (logior mask sb!unix:o_excl))) @@ -1238,10 +1118,9 @@ nil) (t :create)))) - (setf if-does-not-exist ; FIXME: should just die, not allow resetting - (ensure-one-of if-does-not-exist - '(:error :create nil) - :if-does-not-exist)) + (ensure-one-of if-does-not-exist + '(:error :create nil) + :if-does-not-exist) (if (eq if-does-not-exist :create) (setf mask (logior mask sb!unix:o_creat))) @@ -1251,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 @@ -1264,111 +1143,91 @@ (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)))) - ;; Okay, now we can try the actual open. - (loop - (multiple-value-bind (fd errno) - (if namestring - (sb!unix:unix-open namestring mask mode) - (values nil sb!unix:enoent)) + ;; Now we can try the actual Unix open(2). + (multiple-value-bind (fd errno) + (if namestring + (sb!unix:unix-open namestring mask mode) + (values nil sb!unix:enoent)) + (labels ((open-error (format-control &rest format-arguments) + (error 'simple-file-error + :pathname pathname + :format-control format-control + :format-arguments format-arguments)) + (vanilla-open-error () + (simple-file-perror "error opening ~S" pathname errno))) (cond ((numberp fd) - (return - (case direction - ((:input :output :io) - (make-fd-stream fd - :input input - :output output - :element-type element-type - :file namestring - :original original - :delete-original delete-original - :pathname pathname - :input-buffer-p t - :auto-close t)) - (:probe - (let ((stream - (%make-fd-stream :name namestring :fd fd - :pathname pathname - :element-type element-type))) - (close stream) - stream))))) + (case direction + ((:input :output :io) + (make-fd-stream fd + :input input + :output output + :element-type element-type + :file namestring + :original original + :delete-original delete-original + :pathname pathname + :input-buffer-p t + :auto-close t)) + (:probe + (let ((stream + (%make-fd-stream :name namestring + :fd fd + :pathname pathname + :element-type element-type))) + (close stream) + stream)))) ((eql errno sb!unix:enoent) (case if-does-not-exist - (:error - (cerror "Return NIL." - 'simple-file-error - :pathname pathname - :format-control "error opening ~S: ~A" - :format-arguments - (list pathname - (sb!unix:get-unix-error-msg errno)))) + (:error (vanilla-open-error)) (:create - (cerror "Return NIL." - 'simple-error - :format-control - "error creating ~S: Path does not exist." - :format-arguments - (list pathname)))) - (return nil)) - ((eql errno sb!unix:eexist) - (unless (eq nil if-exists) - (cerror "Return NIL." - 'simple-file-error - :pathname pathname - :format-control "error opening ~S: ~A" - :format-arguments - (list pathname - (sb!unix:get-unix-error-msg errno)))) - (return nil)) - ((eql errno sb!unix:eacces) - (cerror "Try again." - "error opening ~S: ~A" - pathname - (sb!unix:get-unix-error-msg errno))) + (open-error "~@" + pathname)) + (t nil))) + ((and (eql errno sb!unix:eexist) if-exists) + nil) (t - (cerror "Return NIL." - "error opening ~S: ~A" - pathname - (sb!unix:get-unix-error-msg errno)) - (return nil))))))))) + (vanilla-open-error))))))))) ;;;; initialization -(defvar *tty* nil - #!+sb-doc - "The stream connected to the controlling terminal or NIL if there is none.") -(defvar *stdin* nil - #!+sb-doc - "The stream connected to the standard input (file descriptor 0).") -(defvar *stdout* nil - #!+sb-doc - "The stream connected to the standard output (file descriptor 1).") -(defvar *stderr* nil - #!+sb-doc - "The stream connected to the standard error output (file descriptor 2).") +;;; the stream connected to the controlling terminal, or NIL if there is none +(defvar *tty*) + +;;; the stream connected to the standard input (file descriptor 0) +(defvar *stdin*) + +;;; the stream connected to the standard output (file descriptor 1) +(defvar *stdout*) + +;;; the stream connected to the standard error output (file descriptor 2) +(defvar *stderr*) ;;; This is called when the cold load is first started up, and may also ;;; be called in an attempt to recover from nested errors. @@ -1378,8 +1237,8 @@ (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. + ;; 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*) @@ -1388,7 +1247,7 @@ (setf *query-io* (make-synonym-stream '*terminal-io*)) (setf *debug-io* *query-io*) (setf *trace-output* *standard-output*) - nil) + (values)) ;;; This is called whenever a saved core is restarted. (defun stream-reinit () @@ -1409,23 +1268,19 @@ :buffering :line :auto-close t)) (setf *tty* (make-two-way-stream *stdin* *stdout*)))) - nil) + (values)) -;;;; beeping +;;;; miscellany -(defun default-beep-function (stream) +;;; the Unix way to beep +(defun beep (stream) (write-char (code-char bell-char-code) stream) (finish-output stream)) -(defvar *beep-function* #'default-beep-function - #!+sb-doc - "This is called in BEEP to feep the user. It takes a stream.") - -(defun beep (&optional (stream *terminal-io*)) - (funcall *beep-function* stream)) - -;;; Kind of like FILE-POSITION, but is an internal hack used by the filesys -;;; stuff to get and set the file name. +;;; 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 @@ -1439,14 +1294,15 @@ ;;;; international character support (which is trivial for our simple ;;;; character sets) -;;;; (Those who do Lisp only in English might not remember that ANSI requires -;;;; these functions to be exported from package COMMON-LISP.) +;;;; (Those who do Lisp only in English might not remember that ANSI +;;;; requires these functions to be exported from package +;;;; COMMON-LISP.) (defun file-string-length (stream object) (declare (type (or string character) object) (type file-stream stream)) #!+sb-doc "Return the delta in STREAM's FILE-POSITION that would be caused by writing - Object to Stream. Non-trivial only in implementations that support + OBJECT to STREAM. Non-trivial only in implementations that support international character sets." (declare (ignore stream)) (etypecase object