X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=91b8f86e96373ce3e6ea6ebe5d38978545df83ff;hb=f1407e424f1063203af07d2e61ceef58515a4797;hp=aea8b57c015f38dc96d0a6f5079baef93385889b;hpb=1bfc464c657a8f4ad24ef612f76a38d8f6f1bbad;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index aea8b57..91b8f86 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -11,14 +11,6 @@ (in-package "SB!IMPL") -;;; FIXME: Wouldn't it be clearer to just have the structure -;;; definition be DEFSTRUCT FILE-STREAM (instead of DEFSTRUCT -;;; FD-STREAM)? That way we'd have TYPE-OF and PRINT-OBJECT refer to -;;; these objects as FILE-STREAMs (the ANSI name) instead of the -;;; internal implementation name FD-STREAM, and there might be other -;;; benefits as well. -(deftype file-stream () 'fd-stream) - ;;;; buffer manipulation routines ;;; FIXME: Is it really good to maintain this pool separate from the @@ -39,10 +31,18 @@ (pop *available-buffers*) (allocate-system-memory bytes-per-buffer))) -;;;; the FD-STREAM structure +;;;; the FILE-STREAM structure -(defstruct (fd-stream +(defstruct (file-stream (:constructor %make-fd-stream) + ;; KLUDGE: in an ideal world, maybe we'd rewrite + ;; everything to use FILE-STREAM rather than simply + ;; providing this hack for compatibility with the old + ;; code. However, CVS doesn't deal terribly well with + ;; file renaming, so for now we use this + ;; backward-compatibility feature. + (:conc-name fd-stream-) + (:predicate fd-stream-p) (:include ansi-stream (misc #'fd-stream-misc-routine)) (:copier nil)) @@ -87,7 +87,7 @@ (timeout nil :type (or index null)) ;; pathname of the file this stream is opened to (returned by PATHNAME) (pathname nil :type (or pathname null))) -(def!method print-object ((fd-stream fd-stream) stream) +(def!method print-object ((fd-stream file-stream) stream) (declare (type stream stream)) (print-unreadable-object (fd-stream stream :type t :identity t) (format stream "for ~S" (fd-stream-name fd-stream)))) @@ -117,7 +117,7 @@ ;;; descriptor. Attempt to write the data again. If it worked, remove ;;; the data from the OUTPUT-LATER list. If it didn't work, something ;;; is wrong. -(defun do-output-later (stream) +(defun frob-output-later (stream) (let* ((stuff (pop (fd-stream-output-later stream))) (base (car stuff)) (start (cadr stuff)) @@ -154,9 +154,9 @@ (setf (fd-stream-handler stream) (sb!sys:add-fd-handler (fd-stream-fd stream) :output - #'(lambda (fd) - (declare (ignore fd)) - (do-output-later stream))))) + (lambda (fd) + (declare (ignore fd)) + (frob-output-later stream))))) (t (nconc (fd-stream-output-later stream) (list (list base start end reuse-sap))))) @@ -168,8 +168,8 @@ ;;; Output the given noise. Check to see whether there are any pending ;;; writes. If so, just queue this one. Otherwise, try to write it. If ;;; this would block, queue it. -(defun do-output (stream base start end reuse-sap) - (declare (type fd-stream stream) +(defun frob-output (stream base start end reuse-sap) + (declare (type file-stream stream) (type (or system-area-pointer (simple-array * (*))) base) (type index start end)) (if (not (null (fd-stream-output-later stream))) ; something buffered. @@ -194,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 @@ -203,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 @@ -350,7 +350,7 @@ (setf (fd-stream-obuf-tail fd-stream) bytes)) (t (flush-output-buffer fd-stream) - (do-output fd-stream thing start end nil)))))) + (frob-output fd-stream thing start end nil)))))) ;;; the routine to use to output a string. If the stream is ;;; unbuffered, slam the string down the file descriptor, otherwise @@ -369,6 +369,9 @@ (if (stringp thing) (let ((last-newline (and (find #\newline (the simple-string thing) :start start :end end) + ;; FIXME why do we need both calls? + ;; Is find faster forwards than + ;; position is backwards? (position #\newline (the simple-string thing) :from-end t :start start @@ -381,7 +384,7 @@ (when last-newline (flush-output-buffer stream))) (:none - (do-output stream thing start end nil))) + (frob-output stream thing start end nil))) (if last-newline (setf (fd-stream-char-pos stream) (- end last-newline 1)) @@ -391,7 +394,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 @@ -414,7 +417,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)) @@ -454,10 +457,8 @@ (case count (1) (0 - (unless #!-mp (sb!sys:wait-until-fd-usable - fd :input (fd-stream-timeout stream)) - #!+mp (sb!mp:process-wait-until-fd-usable - fd :input (fd-stream-timeout stream)) + (unless (sb!sys:wait-until-fd-usable + fd :input (fd-stream-timeout stream)) (error 'io-timeout :stream stream :direction :read))) (t (simple-stream-perror "couldn't check whether ~S is readable" @@ -470,12 +471,10 @@ (cond ((null count) (if (eql errno sb!unix:ewouldblock) (progn - (unless #!-mp (sb!sys:wait-until-fd-usable - fd :input (fd-stream-timeout stream)) - #!+mp (sb!mp:process-wait-until-fd-usable - fd :input (fd-stream-timeout stream)) + (unless (sb!sys:wait-until-fd-usable + fd :input (fd-stream-timeout stream)) (error 'io-timeout :stream stream :direction :read)) - (do-input stream)) + (frob-input stream)) (simple-stream-perror "couldn't read from ~S" stream errno))) ((zerop count) (setf (fd-stream-listen stream) :eof) @@ -485,7 +484,7 @@ (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))) @@ -496,7 +495,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) @@ -593,7 +592,7 @@ ;;; 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 file-stream stream)) (declare (type index start requested)) (do ((total-copied 0)) (nil) @@ -833,7 +832,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 @@ -849,7 +848,8 @@ (fd-stream-element-type fd-stream)) (:interactive-p ;; FIXME: sb!unix:unix-isatty is undefined. - (sb!unix:unix-isatty (fd-stream-fd fd-stream))) + (= 1 (the (member 0 1) + (sb!unix:unix-isatty (fd-stream-fd fd-stream))))) (:line-length 80) (:charpos @@ -879,7 +879,7 @@ (fd-stream-file-position fd-stream arg1)))) (defun fd-stream-file-position (stream &optional newpos) - (declare (type fd-stream stream) + (declare (type file-stream stream) (type (or index (member nil :start :end)) newpos)) (if (null newpos) (sb!sys:without-interrupts @@ -890,7 +890,7 @@ (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)) @@ -1014,8 +1014,8 @@ ;;; Pick a name to use for the backup file for the :IF-EXISTS ;;; :RENAME-AND-DELETE and :RENAME options. (defun pick-backup-name (name) - (declare (type simple-string name)) - (concatenate 'simple-string name ".bak")) + (declare (type simple-base-string name)) + (concatenate 'simple-base-string name ".bak")) ;;; Ensure that the given arg is one of the given list of valid ;;; things. Allow the user to fix any problems. @@ -1030,7 +1030,7 @@ ;;; Rename NAMESTRING to ORIGINAL. First, check whether we have write ;;; access, since we don't want to trash unwritable files even if we ;;; technically can. We return true if we succeed in renaming. -(defun do-old-rename (namestring original) +(defun rename-the-old-one (namestring original) (unless (sb!unix:unix-access namestring sb!unix:w_ok) (error "~@" namestring)) (multiple-value-bind (okay err) (sb!unix:unix-rename namestring original) @@ -1060,17 +1060,9 @@ :ELEMENT-TYPE - the type of object to read or write, default BASE-CHAR :IF-EXISTS - one of :ERROR, :NEW-VERSION, :RENAME, :RENAME-AND-DELETE, :OVERWRITE, :APPEND, :SUPERSEDE or NIL - :IF-DOES-NOT-EXIST - one of :ERROR, :CREATE or nil + :IF-DOES-NOT-EXIST - one of :ERROR, :CREATE or NIL See the manual for details." - (unless (eq external-format :default) - (error "Any external format other than :DEFAULT isn't recognized.")) - - ;; First, make sure that DIRECTION is valid. - (ensure-one-of direction - '(:input :output :io :probe) - :direction) - ;; Calculate useful stuff. (multiple-value-bind (input output mask) (case direction @@ -1079,7 +1071,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)) @@ -1157,7 +1149,7 @@ namestring err/dev))))))) (unless (and exists - (do-old-rename namestring original)) + (rename-the-old-one namestring original)) (setf original nil) (setf delete-original nil) ;; In order to use :SUPERSEDE instead, we have to make @@ -1169,7 +1161,7 @@ (logior (logandc2 mask sb!unix:o_creat) sb!unix:o_trunc))) (setf if-exists :supersede)))) - + ;; Now we can try the actual Unix open(2). (multiple-value-bind (fd errno) (if namestring @@ -1235,14 +1227,7 @@ (stream-reinit) (setf *terminal-io* (make-synonym-stream '*tty*)) (setf *standard-output* (make-synonym-stream '*stdout*)) - (setf *standard-input* - (#!-high-security - ;; FIXME: Why is *STANDARD-INPUT* a TWO-WAY-STREAM? ANSI says - ;; it's an input stream. - make-two-way-stream - #!+high-security - %make-two-way-stream (make-synonym-stream '*stdin*) - *standard-output*)) + (setf *standard-input* (make-synonym-stream '*stdin*)) (setf *error-output* (make-synonym-stream '*stderr*)) (setf *query-io* (make-synonym-stream '*terminal-io*)) (setf *debug-io* *query-io*) @@ -1282,7 +1267,7 @@ ;;; ;;; FIXME: misleading name, screwy interface (defun file-name (stream &optional new-name) - (when (typep stream 'fd-stream) + (when (typep stream 'file-stream) (cond (new-name (setf (fd-stream-pathname stream) new-name) (setf (fd-stream-file stream)