From b7985f33189fbedb60c6cbb547b2adc1bc3ff100 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Tue, 21 May 1991 22:22:34 +0000 Subject: [PATCH] Added many declarations indicated by efficiency notes. Also, now in OPEN, we don't rename files that aren't writable. --- code/fd-stream.lisp | 185 ++++++++++++++++++++++++++------------------ 1 file changed, 108 insertions(+), 77 deletions(-) diff --git a/code/fd-stream.lisp b/code/fd-stream.lisp index b424a8d01..bfcb05ecc 100644 --- a/code/fd-stream.lisp +++ b/code/fd-stream.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.13 1991/05/21 18:37:34 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.14 1991/05/21 22:22:34 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -67,31 +67,39 @@ (file nil) ; The file this stream is for (original nil) ; The original file (for :if-exists :rename) (delete-original nil) ; for :if-exists :rename-and-delete - (element-size 1) ; Number of bytes per element. + ;; + ;;; Number of bytes per element. + (element-size 1 :type index) (element-type 'base-character) ; The type of element being transfered. (fd -1 :type fixnum) ; The file descriptor - (buffering :full) ; One of :none, :line, or :full - (char-pos nil) ; Character position if known. - (listen nil) ; T if we don't need to listen. :EOF if we hit - ; EOF. + ;; + ;; Controls when the output buffer is flushed. + (buffering :full :type (member :full :line :none)) + ;; + ;; 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. (unread nil) - (ibuf-sap nil) - (ibuf-length nil) - (ibuf-head 0 :type fixnum) - (ibuf-tail 0 :type fixnum) + (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. - (obuf-sap nil) - (obuf-length nil) - (obuf-tail 0 :type fixnum) + (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-later nil) (handler nil)) (defun %print-fd-stream (fd-stream stream depth) - (declare (ignore depth)) + (declare (ignore depth) (stream stream)) (format stream "#<Stream for ~A>" (fd-stream-name fd-stream))) @@ -117,26 +125,26 @@ (end (caddr stuff)) (reuse-sap (cadddr stuff)) (length (- end start))) + (declare (type index start end length)) (multiple-value-bind (count errno) (mach:unix-write (fd-stream-fd stream) base start length) - (cond ((eql count length) ; Hot damn, it workded. + (cond ((not count) + (if (= errno mach:ewouldblock) + (error "Write would have blocked, but SERVER told us to go.") + (error "While writing ~S: ~A" + stream (mach:get-unix-error-msg errno)))) + ((eql count length) ; Hot damn, it workded. (when reuse-sap (push base *available-buffers*))) ((not (null count)) ; Sorta worked. (push (list base (+ start count) end) - (fd-stream-output-later stream))) - ((= errno mach:ewouldblock) - (error "Write would have blocked, but SERVER told us to go.")) - (t - (error "While writing ~S: ~A" - stream - (mach:get-unix-error-msg errno)))))) + (fd-stream-output-later stream)))))) (unless (fd-stream-output-later stream) (system:remove-fd-handler (fd-stream-handler stream)) (setf (fd-stream-handler stream) nil))) @@ -161,7 +169,7 @@ (when reuse-sap (let ((new-buffer (next-available-buffer))) (setf (fd-stream-obuf-sap stream) new-buffer) - (setf (fd-stream-obuf-length stream) bytes-per-buffer)))) + (setf (fd-stream-obuf-length stream) bytes-per-buffer)))) ;;; DO-OUTPUT -- internal ;;; @@ -170,24 +178,26 @@ ;;; queue it. ;;; (defun do-output (stream base start end reuse-sap) + (declare (type fd-stream stream) + (type (or system-area-pointer (simple-array * (*))) base) + (type index start end)) (if (not (null (fd-stream-output-later stream))) ; something buffered. - (progn - (output-later stream base start end reuse-sap) - ;; ### check to see if any of this noise can be output - ) - (let ((length (- end start))) - (multiple-value-bind - (count errno) - (mach:unix-write (fd-stream-fd stream) base start length) - (cond ((eql count length)) ; Hot damn, it worked. - ((not (null count)) - (output-later stream base (+ start count) end reuse-sap)) - ((= errno mach:ewouldblock) - (output-later stream base start end reuse-sap)) - (t - (error "While writing ~S: ~A" - stream - (mach:get-unix-error-msg errno)))))))) + (progn + (output-later stream base start end reuse-sap) + ;; ### check to see if any of this noise can be output + ) + (let ((length (- end start))) + (multiple-value-bind + (count errno) + (mach:unix-write (fd-stream-fd stream) base start length) + (cond ((not count) + (if (= errno mach:ewouldblock) + (output-later stream base start end reuse-sap) + (error "While writing ~S: ~A" + stream (mach:get-unix-error-msg errno)))) + ((not (eql count length)) + (output-later stream base (+ start count) end reuse-sap))))))) + ;;; FLUSH-OUTPUT-BUFFER -- internal ;;; @@ -292,8 +302,8 @@ "Output THING to stream. THING can be any kind of vector or a sap. If THING is a SAP, END must be supplied (as length won't work)." (let ((start (or start 0)) - (end (or end (length thing)))) - (declare (fixnum start end)) + (end (or end (length (the (simple-array * (*)) thing))))) + (declare (type index start end)) (let* ((len (fd-stream-obuf-length stream)) (tail (fd-stream-obuf-tail stream)) (space (- len tail)) @@ -350,7 +360,7 @@ ;;; (defun fd-sout (stream thing start end) (let ((start (or start 0)) - (end (or end (length thing)))) + (end (or end (length (the vector thing))))) (declare (fixnum start end)) (if (stringp thing) (let ((last-newline (and (find #\newline (the simple-string thing) @@ -412,8 +422,9 @@ (buflen (fd-stream-ibuf-length stream)) (head (fd-stream-ibuf-head stream)) (tail (fd-stream-ibuf-tail stream))) + (declare (type index head tail)) (unless (zerop head) - (cond ((eq head tail) + (cond ((eql head tail) (setf head 0) (setf tail 0) (setf (fd-stream-ibuf-head stream) 0) @@ -591,6 +602,7 @@ ;;; Returns a string constructed from the 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 vm:byte-bits) @@ -698,7 +710,7 @@ non-server method is also significantly more efficient for large reads. ;;; The N-Bin method for FD-STREAMs. This doesn't using SERVER; it blocks ;;; in UNIX-READ. This allows the method to be used to implementing reading ;;; for CLX. It is generally used where there is a definite amount of reading -;;; to be done, so it blocking isn't too problematical. +;;; to be done, so blocking isn't too problematical. ;;; ;;; We copy buffered data into the buffer. If there is enough, just return. ;;; Otherwise, we see if the amount of additional data needed will fit in the @@ -761,7 +773,7 @@ non-server method is also significantly more efficient for large reads. (when (zerop count) (if eof-error-p (error "Unexpected eof on ~S." stream) - (return (- requested (/ now-needed elsize))))) + (return (- requested (truncate now-needed elsize))))) (decf now-needed count) (when (zerop now-needed) (return requested)) (incf offset count))))) @@ -778,7 +790,7 @@ non-server method is also significantly more efficient for large reads. (when (zerop count) (if eof-error-p (error "Unexpected eof on ~S." stream) - (return (- requested (/ now-needed elsize))))) + (return (- requested (truncate now-needed elsize))))) (let* ((copy (min now-needed count)) (copy-bits (* copy vm:byte-bits)) (buffer-start-bits @@ -839,12 +851,12 @@ non-server method is also significantly more efficient for large reads. (setf (fd-stream-ibuf-length stream) bytes-per-buffer) (setf (fd-stream-ibuf-tail stream) 0) (if (subtypep type 'character) - (setf (fd-stream-in stream) routine - (fd-stream-bin stream) #'ill-bin - (fd-stream-n-bin stream) #'ill-bin) - (setf (fd-stream-in stream) #'ill-in - (fd-stream-bin stream) routine - (fd-stream-n-bin stream) #'fd-stream-read-n-bytes)) + (setf (fd-stream-in stream) routine + (fd-stream-bin stream) #'ill-bin + (fd-stream-n-bin stream) #'ill-bin) + (setf (fd-stream-in stream) #'ill-in + (fd-stream-bin stream) routine + (fd-stream-n-bin stream) #'fd-stream-read-n-bytes)) (setf input-size size) (setf input-type type))) @@ -1005,7 +1017,7 @@ non-server method is also significantly more efficient for large reads. (mach:get-unix-error-msg dev))) (if (zerop mode) nil - (/ size (fd-stream-element-size stream))))) + (truncate size (fd-stream-element-size stream))))) (:file-position (fd-stream-file-position stream arg1)) (:file-name @@ -1014,6 +1026,8 @@ non-server method is also significantly more efficient for large reads. ;;; FD-STREAM-FILE-POSITION -- internal. ;;; (defun fd-stream-file-position (stream &optional newpos) + (declare (type fd-stream stream) + (type (or index (member nil :start :end)) newpos)) (if (null newpos) (system:without-interrupts ;; First, find the position of the UNIX file descriptor in the @@ -1021,14 +1035,16 @@ non-server method is also significantly more efficient for large reads. (multiple-value-bind (posn errno) (mach:unix-lseek (fd-stream-fd stream) 0 mach:l_incr) - (cond ((numberp posn) + (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. (dolist (later (fd-stream-output-later stream)) - (incf posn (- (caddr later) (cadr later)))) + (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 @@ -1040,7 +1056,7 @@ non-server method is also significantly more efficient for large reads. (when (fd-stream-unread stream) (decf posn)) ;; Divide bytes by element size. - (/ posn (fd-stream-element-size stream))) + (truncate posn (fd-stream-element-size stream))) ((eq errno mach:espipe) nil) (t @@ -1068,7 +1084,7 @@ non-server method is also significantly more efficient for large reads. (setf offset 0 origin mach:l_set)) ((eq newpos :end) (setf offset 0 origin mach:l_xtnd)) - ((numberp newpos) + ((typep newpos 'index) (setf offset (* newpos (fd-stream-element-size stream)) origin mach:l_set)) (t @@ -1076,7 +1092,7 @@ non-server method is also significantly more efficient for large reads. (multiple-value-bind (posn errno) (mach:unix-lseek (fd-stream-fd stream) offset origin) - (cond ((numberp posn) + (cond ((typep posn 'fixnum) t) ((eq errno mach:espipe) nil) @@ -1136,9 +1152,11 @@ non-server method is also significantly more efficient for large reads. namestring.") ;;; (defun pick-backup-name (name) - (etypecase *backup-extension* - (string (concatenate 'simple-string name *backup-extension*)) - (function (funcall *backup-extension* name)))) + (declare (type simple-string name)) + (let ((ext *backup-extension*)) + (etypecase ext + (simple-string (concatenate 'simple-string name ext)) + (function (funcall ext name))))) ;;; ASSURE-ONE-OF -- internal ;;; @@ -1153,13 +1171,35 @@ non-server method is also significantly more efficient for large reads. item what list) - (format *query-io* "Enter new value for ~S: " what) + (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) +;;; DO-OLD-RENAME -- Internal +;;; +;;; Rename Namestring to Original. First, check if we have write access, +;;; since we don't want to trash unwritable files even if we technically can. +;;; We return true if we suceed in renaming. +;;; +(defun do-old-rename (namestring original) + (unless (mach:unix-access namestring mach:w_ok) + (cerror "Try to rename it anyway." "File ~S is not writable." namestring)) + (multiple-value-bind + (okay err) + (mach:unix-rename namestring original) + (cond (okay t) + (t + (cerror "Use :SUPERSEDE instead." + "Could not rename ~S to ~S: ~A." + namestring + original + (mach:get-unix-error-msg err)) + nil)))) + + ;;; OPEN -- public ;;; ;;; Open the given file. @@ -1192,6 +1232,7 @@ non-server method is also significantly more efficient for large reads. (:output (values nil t mach:o_wronly)) (:io (values t t mach:o_rdwr)) (:probe (values t nil mach:o_rdonly))) + (declare (type index mask)) (let* ((pathname (pathname filename)) (namestring (unix-namestring pathname input))) ;; Process if-exists argument if we are doing any output. @@ -1238,7 +1279,7 @@ non-server method is also significantly more efficient for large reads. (let ((original (if (member if-exists '(:rename :rename-and-delete)) - (pick-backup-name namestring))) + (pick-backup-name namestring))) (delete-original (eq if-exists :rename-and-delete)) (mode #o666)) (when original @@ -1249,7 +1290,7 @@ non-server method is also significantly more efficient for large reads. (multiple-value-bind (okay err/dev inode orig-mode) (mach:unix-stat namestring) - (declare (ignore inode)) + (declare (ignore inode) (type (or index null) orig-mode)) (cond (okay (when (and output (= (logand orig-mode #o170000) #o40000)) @@ -1263,18 +1304,8 @@ non-server method is also significantly more efficient for large reads. (error "Cannot find ~S: ~A" namestring (mach:get-unix-error-msg err/dev))))))) - (when (or (not exists) - ;; Do the rename. - (multiple-value-bind - (okay err) - (mach:unix-rename namestring original) - (unless okay - (cerror "Use :SUPERSEDE instead." - "Could not rename ~S to ~S: ~A." - namestring - original - (mach:get-unix-error-msg err)) - t))) + (unless (and exists + (do-old-rename namestring original)) (setf original nil) (setf delete-original nil) ;; In order to use SUPERSEDE instead, we have -- GitLab