X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=03bca62d13b8bf9bbdfe71754b5036c79afa3e1c;hb=f3f677703e37f5a335b3be7fa64f7748ad969517;hp=caa363d9c67893fc13d7c5e40e486cba4a8cb8cd;hpb=637495a7d041887ffe10f6b740574df65ae88c98;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index caa363d..03bca62 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -57,6 +57,11 @@ (fd -1 :type fixnum) ;; controls when the output buffer is flushed (buffering :full :type (member :full :line :none)) + ;; controls whether the input buffer must be cleared before output + ;; (must be done for files, not for sockets, pipes and other data + ;; sources where input and output aren't related). non-NIL means + ;; don't clear input buffer. + (dual-channel-p nil) ;; character position (if known) (char-pos nil :type (or index null)) ;; T if input is waiting on FD. :EOF if we hit EOF. @@ -244,8 +249,9 @@ size)) (flush-output-buffer ,stream-var))) ,(unless (eq (car buffering) :none) - `(when (> (fd-stream-ibuf-tail ,stream-var) - (fd-stream-ibuf-head ,stream-var)) + `(when (and (not (fd-stream-dual-channel-p ,stream-var)) + (> (fd-stream-ibuf-tail ,stream-var) + (fd-stream-ibuf-head ,stream-var))) (file-position ,stream-var (file-position ,stream-var)))) ,(if restart `(catch 'output-nothing @@ -272,8 +278,9 @@ ,size)) (flush-output-buffer ,stream-var))) ,(unless (eq (car buffering) :none) - `(when (> (fd-stream-ibuf-tail ,stream-var) - (fd-stream-ibuf-head ,stream-var)) + `(when (and (not (fd-stream-dual-channel-p ,stream-var)) + (> (fd-stream-ibuf-tail ,stream-var) + (fd-stream-ibuf-head ,stream-var))) (file-position ,stream-var (file-position ,stream-var)))) ,(if restart `(catch 'output-nothing @@ -419,8 +426,9 @@ (let ((start (or start 0)) (end (or end (length (the (simple-array * (*)) thing))))) (declare (type index start end)) - (when (> (fd-stream-ibuf-tail fd-stream) - (fd-stream-ibuf-head fd-stream)) + (when (and (not (fd-stream-dual-channel-p fd-stream)) + (> (fd-stream-ibuf-tail fd-stream) + (fd-stream-ibuf-head fd-stream))) (file-position fd-stream (file-position fd-stream))) (let* ((len (fd-stream-obuf-length fd-stream)) (tail (fd-stream-obuf-tail fd-stream)) @@ -963,8 +971,9 @@ (let ((start (or start 0)) (end (or end (length string)))) (declare (type index start end)) - (when (> (fd-stream-ibuf-tail stream) - (fd-stream-ibuf-head stream)) + (when (and (not (fd-stream-dual-channel-p stream)) + (> (fd-stream-ibuf-tail stream) + (fd-stream-ibuf-head stream))) (file-position stream (file-position stream))) (when (< end start) (error ":END before :START!")) @@ -1065,8 +1074,9 @@ (let ((start (or start 0)) (end (or end (length string)))) (declare (type index start end)) - (when (> (fd-stream-ibuf-tail fd-stream) - (fd-stream-ibuf-head fd-stream)) + (when (and (not (fd-stream-dual-channel-p fd-stream)) + (> (fd-stream-ibuf-tail fd-stream) + (fd-stream-ibuf-head fd-stream))) (file-position fd-stream (file-position fd-stream))) (when (< end start) (error ":END before :START!")) @@ -1335,10 +1345,11 @@ (output-size nil) (character-stream-p (subtypep type 'character))) - (when (fd-stream-obuf-sap fd-stream) + ;; drop buffers when direction changes + (when (and (fd-stream-obuf-sap fd-stream) (not output-p)) (push (fd-stream-obuf-sap fd-stream) *available-buffers*) (setf (fd-stream-obuf-sap fd-stream) nil)) - (when (fd-stream-ibuf-sap fd-stream) + (when (and (fd-stream-ibuf-sap fd-stream) (not input-p)) (push (fd-stream-ibuf-sap fd-stream) *available-buffers*) (setf (fd-stream-ibuf-sap fd-stream) nil)) @@ -1377,9 +1388,6 @@ normalized-external-format)) (unless routine (error "could not find any input routine for ~S" target-type)) - (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 character-stream-p (setf (fd-stream-in fd-stream) routine (fd-stream-bin fd-stream) #'ill-bin) @@ -1424,9 +1432,6 @@ (error "could not find any output routine for ~S buffered ~S" (fd-stream-buffering fd-stream) target-type)) - (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) (when character-stream-p (setf (fd-stream-output-bytes fd-stream) output-bytes)) (if character-stream-p @@ -1440,7 +1445,6 @@ (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 fd-stream) 0) (setf output-size size) (setf output-type type))) @@ -1589,6 +1593,8 @@ (sb!sys:serve-all-events))) (:element-type (fd-stream-element-type fd-stream)) + (:external-format + (fd-stream-external-format fd-stream)) (:interactive-p (= 1 (the (member 0 1) (sb!unix:unix-isatty (fd-stream-fd fd-stream))))) @@ -1617,6 +1623,12 @@ (if (zerop mode) nil (truncate size (fd-stream-element-size fd-stream))))) + ;; FIXME: I doubt this is correct in the presence of Unicode, + ;; since fd-stream FILE-POSITION is measured in bytes. + (:file-string-length + (etypecase arg1 + (character 1) + (string (length arg1)))) (:file-position (fd-stream-file-position fd-stream arg1)))) @@ -1726,6 +1738,7 @@ delete-original pathname input-buffer-p + dual-channel-p (name (if file (format nil "file ~S" file) (format nil "descriptor ~W" fd))) @@ -1743,8 +1756,18 @@ :delete-original delete-original :pathname pathname :buffering buffering + :dual-channel-p dual-channel-p :external-format external-format :timeout timeout))) + (when input + (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)) + (when output + (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-char-pos stream) 0)) (set-fd-stream-routines stream element-type input output input-buffer-p) (when (and auto-close (fboundp 'finalize)) (finalize stream @@ -1936,6 +1959,7 @@ :original original :delete-original delete-original :pathname pathname + :dual-channel-p nil :input-buffer-p t :auto-close t)) (:probe @@ -2027,29 +2051,3 @@ t) (t (fd-stream-pathname stream))))) - -;;;; 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.) - -(defun file-string-length (stream object) - (declare (type (or string character) object) (type fd-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 - international character sets." - (declare (ignore stream)) - (etypecase object - (character 1) - (string (length object)))) - -(defun stream-external-format (stream) - (declare (type fd-stream stream)) - #!+sb-doc - "Return the actual external format for fd-streams, otherwise :DEFAULT." - (if (typep stream 'fd-stream) - (fd-stream-external-format stream) - :default))