(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.
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
,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
(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))
(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
(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!"))
(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
(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))
(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
;;; 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))
+ (eq external-format :default))
(/show0 "/getting default external format")
- (setf (fd-stream-external-format fd-stream)
- (default-external-format))
+ (setf external-format (default-external-format))
(/show0 "cold-printing defaulted external-format:")
#!+sb-show
- (cold-print (fd-stream-external-format fd-stream))
+ (cold-print external-format)
(/show0 "matching to known aliases")
(dolist (entry *external-formats*
(restart-case
(error "Invalid external-format ~A"
- (fd-stream-external-format fd-stream))
+ external-format)
(use-default ()
:report "Set external format to LATIN-1"
- (setf (fd-stream-external-format fd-stream) :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 (fd-stream-external-format fd-stream) (first entry))
+ (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)))
(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)
(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)
(refill-buffer/fd fd-stream)
(setf (fd-stream-ibuf-head fd-stream) 0)
(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)))))
(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))))
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)
: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 ()
:original original
:delete-original delete-original
:pathname pathname
+ :dual-channel-p nil
:input-buffer-p t
:auto-close t))
(:probe
t)
(t
(fd-stream-pathname stream)))))
-\f
-;;;; 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))
projects / sbcl.git / blobdiff