X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=69660e8b6e4b5dc4e946e0d652fa7d7e7e1d222f;hb=ad3beba970fab6e451a461c9f9b14faf4ef17718;hp=89bc127d3bb38512a79269d2b6d4f1edf111d6cb;hpb=5cd0fc84df83d1b3321b7fc969843207721de429;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 89bc127..69660e8 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 @@ -299,8 +306,7 @@ (mapcar (lambda (buffering) (let ((function - (intern (let ((*print-case* :upcase)) - (format nil name-fmt (car buffering)))))) + (intern (format nil name-fmt (string (car buffering)))))) `(progn (defun ,function (stream byte) (output-wrapper/variable-width (stream ,size ,buffering ,restart) @@ -326,8 +332,7 @@ (mapcar (lambda (buffering) (let ((function - (intern (let ((*print-case* :upcase)) - (format nil name-fmt (car buffering)))))) + (intern (format nil name-fmt (string (car buffering)))))) `(progn (defun ,function (stream byte) (output-wrapper (stream ,size ,buffering ,restart) @@ -421,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)) @@ -491,15 +497,15 @@ :end end)))) (if (and (typep thing 'base-string) (eq (fd-stream-external-format stream) :latin-1)) - (ecase (fd-stream-buffering stream) - (:full - (output-raw-bytes stream thing start end)) - (:line - (output-raw-bytes stream thing start end) - (when last-newline - (flush-output-buffer stream))) - (:none - (frob-output stream thing start end nil))) + (ecase (fd-stream-buffering stream) + (:full + (output-raw-bytes stream thing start end)) + (:line + (output-raw-bytes stream thing start end) + (when last-newline + (flush-output-buffer stream))) + (:none + (frob-output stream thing start end nil))) (ecase (fd-stream-buffering stream) (:full (funcall (fd-stream-output-bytes stream) stream thing nil start end)) @@ -608,10 +614,10 @@ ;;; per element. (defvar *input-routines* ()) -;;; 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) +;;; Fill the input buffer, and return the number of bytes read. Throw +;;; to EOF-INPUT-CATCHER if the eof was reached. Drop into +;;; SYSTEM:SERVER if necessary. +(defun refill-buffer/fd (stream) (let ((fd (fd-stream-fd stream)) (ibuf-sap (fd-stream-ibuf-sap stream)) (buflen (fd-stream-ibuf-length stream)) @@ -632,22 +638,19 @@ (setf (fd-stream-ibuf-head stream) 0) (setf (fd-stream-ibuf-tail stream) tail)))) (setf (fd-stream-listen stream) nil) - (multiple-value-bind (count errno) - ;; FIXME: Judging from compiler warnings, this WITH-ALIEN form expands - ;; into something which uses the not-yet-defined type - ;; (SB!ALIEN-INTERNALS:ALIEN (* (SB!ALIEN:STRUCT SB!UNIX:FD-SET))). - ;; This is probably inefficient and unsafe and generally bad, so - ;; try to find some way to make that type known before - ;; this is compiled. - (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set))) - (sb!unix:fd-zero read-fds) - (sb!unix:fd-set fd read-fds) - (sb!unix:unix-fast-select (1+ fd) - (sb!alien:addr read-fds) - nil - nil - 0 - 0)) + (sb!unix:with-restarted-syscall (count errno) + ;; FIXME: Judging from compiler warnings, this WITH-ALIEN form expands + ;; into something which uses the not-yet-defined type + ;; (SB!ALIEN-INTERNALS:ALIEN (* (SB!ALIEN:STRUCT SB!UNIX:FD-SET))). + ;; This is probably inefficient and unsafe and generally bad, so + ;; try to find some way to make that type known before + ;; this is compiled. + (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set))) + (sb!unix:fd-zero read-fds) + (sb!unix:fd-set fd read-fds) + (sb!unix:unix-fast-select (1+ fd) + (sb!alien:addr read-fds) + nil nil 0 0)) (case count (1) (0 @@ -668,17 +671,18 @@ (unless (sb!sys:wait-until-fd-usable fd :input (fd-stream-timeout stream)) (error 'io-timeout :stream stream :direction :read)) - (frob-input stream)) + (refill-buffer/fd 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)))))) + (incf (fd-stream-ibuf-tail stream) count) + count))))) ;;; Make sure there are at least BYTES number of bytes in the input -;;; buffer. Keep calling FROB-INPUT until that condition is met. +;;; buffer. Keep calling REFILL-BUFFER/FD until that condition is met. (defmacro input-at-least (stream bytes) (let ((stream-var (gensym)) (bytes-var (gensym))) @@ -689,7 +693,7 @@ (fd-stream-ibuf-head ,stream-var)) ,bytes-var) (return)) - (frob-input ,stream-var))))) + (refill-buffer/fd ,stream-var))))) (defmacro input-wrapper/variable-width ((stream bytes eof-error eof-value) &body read-forms) @@ -937,7 +941,7 @@ (= total-copied requested) (return total-copied)) (;; If EOF, we're done in another way. - (zerop (refill-fd-stream-buffer stream)) + (null (catch 'eof-input-catcher (refill-buffer/fd stream))) (if eof-error-p (error 'end-of-file :stream stream) (return total-copied))) @@ -945,55 +949,28 @@ ;; 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.) -(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. - ;; FIXME: can have three bytes in buffer because of UTF-8 - (let ((new-head 0) - (sap (fd-stream-ibuf-sap stream))) - (do ((head (fd-stream-ibuf-head stream) (1+ head)) - (tail (fd-stream-ibuf-tail stream))) - ((= head tail)) - (setf (sap-ref-8 sap new-head) (sap-ref-8 sap head)) - (incf new-head)) - (multiple-value-bind (count err) - (sb!unix:unix-read (fd-stream-fd stream) - (sap+ sap new-head) - (- (fd-stream-ibuf-length stream) new-head)) - (declare (type (or index null) count)) - (when (null count) - (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 new-head)) - count))) - (defun fd-stream-resync (stream) (dolist (entry *external-formats*) (when (member (fd-stream-external-format stream) (first entry)) (return-from fd-stream-resync (funcall (symbol-function (eighth entry)) stream))))) +;;; FIXME: OAOOM here vrt. *EXTERNAL-FORMAT-FUNCTIONS* in fd-stream.lisp (defmacro define-external-format (external-format size output-restart out-expr in-expr) (let* ((name (first external-format)) - (out-function (intern (let ((*print-case* :upcase)) - (format nil "OUTPUT-BYTES/~A" name)))) - (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" name)) - (in-function (intern (let ((*print-case* :upcase)) - (format nil "FD-STREAM-READ-N-CHARACTERS/~A" - name)))) - (in-char-function (intern (let ((*print-case* :upcase)) - (format nil "INPUT-CHAR/~A" name))))) + (out-function (symbolicate "OUTPUT-BYTES/" name)) + (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" (string name))) + (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" name)) + (in-char-function (symbolicate "INPUT-CHAR/" name))) `(progn (defun ,out-function (stream string flush-p start end) (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!")) @@ -1063,7 +1040,7 @@ (= total-copied requested) (return total-copied)) ( ;; If EOF, we're done in another way. - (zerop (refill-fd-stream-buffer stream)) + (null (catch 'eof-input-catcher (refill-buffer/fd stream))) (if eof-error-p (error 'end-of-file :stream stream) (return total-copied))) @@ -1076,8 +1053,7 @@ (setf *external-formats* (cons '(,external-format ,in-function ,in-char-function ,out-function ,@(mapcar #'(lambda (buffering) - (intern (let ((*print-case* :upcase)) - (format nil format buffering)))) + (intern (format nil format (string buffering)))) '(:none :line :full))) *external-formats*))))) @@ -1085,32 +1061,28 @@ (external-format output-restart out-size-expr out-expr in-size-expr in-expr) (let* ((name (first external-format)) - (out-function (intern (let ((*print-case* :upcase)) - (format nil "OUTPUT-BYTES/~A" name)))) - (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" name)) - (in-function (intern (let ((*print-case* :upcase)) - (format nil "FD-STREAM-READ-N-CHARACTERS/~A" - name)))) - (in-char-function (intern (let ((*print-case* :upcase)) - (format nil "INPUT-CHAR/~A" name)))) - (resync-function (intern (let ((*print-case* :upcase)) - (format nil "RESYNC/~A" name))))) + (out-function (symbolicate "OUTPUT-BYTES/" name)) + (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" (string name))) + (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" name)) + (in-char-function (symbolicate "INPUT-CHAR/" name)) + (resync-function (symbolicate "RESYNC/" name))) `(progn - (defun ,out-function (fd-stream string flush-p start end) + (defun ,out-function (stream string flush-p start end) (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)) - (file-position fd-stream (file-position fd-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!")) (do () ((= end start)) - (setf (fd-stream-obuf-tail fd-stream) - (do* ((len (fd-stream-obuf-length fd-stream)) - (sap (fd-stream-obuf-sap fd-stream)) - (tail (fd-stream-obuf-tail fd-stream))) + (setf (fd-stream-obuf-tail stream) + (do* ((len (fd-stream-obuf-length stream)) + (sap (fd-stream-obuf-sap stream)) + (tail (fd-stream-obuf-tail stream))) ((or (= start end) (< (- len tail) 4)) tail) ,(if output-restart `(catch 'output-nothing @@ -1118,8 +1090,7 @@ (bits (char-code byte)) (size ,out-size-expr)) ,out-expr - (incf tail size) - (incf start))) + (incf tail size))) `(let* ((byte (aref string start)) (bits (char-code byte)) (size ,out-size-expr)) @@ -1127,9 +1098,9 @@ (incf tail size))) (incf start))) (when (< start end) - (flush-output-buffer fd-stream))) + (flush-output-buffer stream))) (when flush-p - (flush-output-buffer fd-stream)))) + (flush-output-buffer stream)))) (def-output-routines/variable-width (,format ,out-size-expr ,output-restart @@ -1194,7 +1165,8 @@ (return total-copied)) ( ;; If EOF, we're done in another way. (or (eq decode-break-reason 'eof) - (zerop (refill-fd-stream-buffer stream))) + (null (catch 'eof-input-catcher + (refill-buffer/fd stream)))) (if eof-error-p (error 'end-of-file :stream stream) (return total-copied))) @@ -1221,8 +1193,7 @@ (setf *external-formats* (cons '(,external-format ,in-function ,in-char-function ,out-function ,@(mapcar #'(lambda (buffering) - (intern (let ((*print-case* :upcase)) - (format nil format buffering)))) + (intern (format nil format (string buffering)))) '(:none :line :full)) ,resync-function) *external-formats*))))) @@ -1234,7 +1205,8 @@ (setf (sap-ref-8 sap tail) bits)) (code-char byte)) -(define-external-format (:ascii :us-ascii :ansi_x3.4-1968) +(define-external-format (:ascii :us-ascii :ansi_x3.4-1968 + :iso-646 :iso-646-us :|646|) 1 t (if (>= bits 128) (stream-encoding-error-and-handle stream bits) @@ -1355,117 +1327,157 @@ ;;; 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)) - (signed-byte - '(signed-byte 8)) - (t - type))) - (input-type nil) - (output-type nil) - (input-size nil) - (output-size nil) - (character-stream-p (subtypep type 'character))) - - (when (fd-stream-obuf-sap fd-stream) +(defun set-fd-stream-routines (fd-stream element-type external-format + input-p output-p buffer-p) + (let* ((target-type (case element-type + (unsigned-byte '(unsigned-byte 8)) + (signed-byte '(signed-byte 8)) + (:default 'character) + (t element-type))) + (character-stream-p (subtypep target-type 'character)) + (bivalent-stream-p (eq element-type :default)) + normalized-external-format + (bin-routine #'ill-bin) + (bin-type nil) + (bin-size nil) + (cin-routine #'ill-in) + (cin-type nil) + (cin-size nil) + (input-type nil) ;calculated from bin-type/cin-type + (input-size nil) ;calculated from bin-size/cin-size + (read-n-characters #'ill-in) + (bout-routine #'ill-bout) + (bout-type nil) + (bout-size nil) + (cout-routine #'ill-out) + (cout-type nil) + (cout-size nil) + (output-type nil) + (output-size nil) + (output-bytes #'ill-bout)) + + ;; 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)) + (when input-p + (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)) + (when output-p + (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) + (setf (fd-stream-char-pos fd-stream) 0)) (when (and character-stream-p - (eq (fd-stream-external-format fd-stream) :default)) - (setf (fd-stream-external-format fd-stream) - (intern (or (alien-funcall - (extern-alien "nl_langinfo" - (function c-string int)) - sb!unix:codeset) - "LATIN-1") - "KEYWORD"))) - (dolist (entry *external-formats* - (setf (fd-stream-external-format fd-stream) :latin-1)) - (when (member (fd-stream-external-format fd-stream) (first entry)) - (return))) - + (eq external-format :default)) + (/show0 "/getting default external format") + (setf external-format (default-external-format)) + (/show0 "cold-printing defaulted external-format:") + #!+sb-show + (cold-print external-format) + (/show0 "matching to known aliases") + (dolist (entry *external-formats* + (restart-case + (error "Invalid external-format ~A" + external-format) + (use-default () + :report "Set external format to LATIN-1" + (setf external-format :latin-1)))) + (/show0 "cold printing known aliases:") + #!+sb-show + (dolist (alias (first entry)) (cold-print alias)) + (/show0 "done cold-printing known aliases") + (when (member external-format (first entry)) + (/show0 "matched") + (return))) + (/show0 "/default external format ok")) + (when input-p - (multiple-value-bind (routine type size read-n-characters - normalized-external-format) - (pick-input-routine target-type - (fd-stream-external-format fd-stream)) - (when normalized-external-format - (setf (fd-stream-external-format fd-stream) - 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) - (setf (fd-stream-in fd-stream) #'ill-in - (fd-stream-bin fd-stream) routine)) - (when (eql size 1) - (setf (fd-stream-n-bin fd-stream) - (if character-stream-p - read-n-characters - #'fd-stream-read-n-bytes)) - (when (and buffer-p - ;; We only create this buffer for streams of type - ;; (unsigned-byte 8). Because there's no buffer, the - ;; other element-types will dispatch to the appropriate - ;; input (output) routine in fast-read-byte. - (or character-stream-p - (equal target-type '(unsigned-byte 8))) - (not output-p) ; temporary disable on :io streams - #+(or) - (or (eq type 'unsigned-byte) - (eq type :default))) - (if character-stream-p - (setf (ansi-stream-cin-buffer fd-stream) - (make-array +ansi-stream-in-buffer-length+ - :element-type 'character)) - (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 (or (not character-stream-p) bivalent-stream-p) + (multiple-value-setq (bin-routine bin-type bin-size read-n-characters + normalized-external-format) + (pick-input-routine (if bivalent-stream-p '(unsigned-byte 8) + target-type) + external-format)) + (unless bin-routine + (error "could not find any input routine for ~S" target-type))) + (when character-stream-p + (multiple-value-setq (cin-routine cin-type cin-size read-n-characters + normalized-external-format) + (pick-input-routine target-type external-format)) + (unless cin-routine + (error "could not find any input routine for ~S" target-type))) + (setf (fd-stream-in fd-stream) cin-routine + (fd-stream-bin fd-stream) bin-routine) + ;; character type gets preferential treatment + (setf input-size (or cin-size bin-size)) + (setf input-type (or cin-type bin-type)) + (when normalized-external-format + (setf (fd-stream-external-format fd-stream) + normalized-external-format)) + (when (= (or cin-size 1) (or bin-size 1) 1) + (setf (fd-stream-n-bin fd-stream) ;XXX + (if (and character-stream-p (not bivalent-stream-p)) + read-n-characters + #'fd-stream-read-n-bytes)) + ;; Sometimes turn on fast-read-char/fast-read-byte. Switch on + ;; for character and (unsigned-byte 8) streams. In these + ;; cases, fast-read-* will read from the + ;; ansi-stream-(c)in-buffer, saving function calls. + ;; Otherwise, the various data-reading functions in the stream + ;; structure will be called. + (when (and buffer-p + (not bivalent-stream-p) + ;; temporary disable on :io streams + (not output-p)) + (cond (character-stream-p + (setf (ansi-stream-cin-buffer fd-stream) + (make-array +ansi-stream-in-buffer-length+ + :element-type 'character))) + ((equal target-type '(unsigned-byte 8)) + (setf (ansi-stream-in-buffer fd-stream) + (make-array +ansi-stream-in-buffer-length+ + :element-type '(unsigned-byte 8)))))))) (when output-p - (multiple-value-bind (routine type size output-bytes - normalized-external-format) + (when (or (not character-stream-p) bivalent-stream-p) + (multiple-value-setq (bout-routine bout-type bout-size output-bytes + normalized-external-format) + (pick-output-routine (if bivalent-stream-p + '(unsigned-byte 8) + target-type) + (fd-stream-buffering fd-stream) + external-format)) + (unless bout-routine + (error "could not find any output routine for ~S buffered ~S" + (fd-stream-buffering fd-stream) + target-type))) + (when character-stream-p + (multiple-value-setq (cout-routine cout-type cout-size output-bytes + normalized-external-format) (pick-output-routine target-type (fd-stream-buffering fd-stream) - (fd-stream-external-format fd-stream)) - (when normalized-external-format - (setf (fd-stream-external-format fd-stream) - normalized-external-format)) - (unless routine + external-format)) + (unless cout-routine (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 - (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 fd-stream))) - #'ill-out) - (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))) + target-type))) + (when normalized-external-format + (setf (fd-stream-external-format fd-stream) + normalized-external-format)) + (when character-stream-p + (setf (fd-stream-output-bytes fd-stream) output-bytes)) + (setf (fd-stream-out fd-stream) cout-routine + (fd-stream-bout fd-stream) bout-routine + (fd-stream-sout fd-stream) (if (eql cout-size 1) + #'fd-sout #'ill-out)) + (setf output-size (or cout-size bout-size)) + (setf output-type (or cout-type bout-type))) (when (and input-size output-size (not (eq input-size output-size))) @@ -1500,13 +1512,14 @@ (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 fd-stream) read-fds) - (sb!unix:unix-fast-select (1+ (fd-stream-fd fd-stream)) - (sb!alien:addr read-fds) - nil nil 0 0)) + (eql (sb!unix:with-restarted-syscall () + (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 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 fd-stream) arg1) @@ -1587,18 +1600,16 @@ (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 fd-stream) read-fds) - (sb!unix:unix-fast-select (1+ (fd-stream-fd fd-stream)) - (sb!alien:addr read-fds) - nil - nil - 0 - 0)))) + (let ((count (sb!unix:with-restarted-syscall () + (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 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) - (frob-input fd-stream) + (refill-buffer/fd fd-stream) (setf (fd-stream-ibuf-head fd-stream) 0) (setf (fd-stream-ibuf-tail fd-stream) 0)) (t @@ -1612,6 +1623,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))))) @@ -1640,6 +1653,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)))) @@ -1749,8 +1768,9 @@ delete-original pathname input-buffer-p + dual-channel-p (name (if file - (format nil "file ~S" file) + (format nil "file ~A" file) (format nil "descriptor ~W" fd))) auto-close) (declare (type index fd) (type (or index null) timeout) @@ -1766,9 +1786,11 @@ :delete-original delete-original :pathname pathname :buffering buffering + :dual-channel-p dual-channel-p :external-format external-format :timeout timeout))) - (set-fd-stream-routines stream element-type input output input-buffer-p) + (set-fd-stream-routines stream element-type external-format + input output input-buffer-p) (when (and auto-close (fboundp 'finalize)) (finalize stream (lambda () @@ -1888,7 +1910,7 @@ (let ((original (case if-exists ((:rename :rename-and-delete) (pick-backup-name namestring)) - ((:append) + ((:append :overwrite) ;; KLUDGE: Provent CLOSE from deleting ;; appending streams when called with :ABORT T namestring))) @@ -1959,6 +1981,7 @@ :original original :delete-original delete-original :pathname pathname + :dual-channel-p nil :input-buffer-p t :auto-close t)) (:probe @@ -2050,29 +2073,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))