(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.
:stream stream
:code code))
+;;; Returning true goes into end of file handling, false will enter another
+;;; round of input buffer filling followed by re-entering character decode.
+(defun stream-decoding-error-and-handle (stream octet-count)
+ (restart-case
+ (stream-decoding-error stream
+ (let ((sap (fd-stream-ibuf-sap stream))
+ (head (fd-stream-ibuf-head stream)))
+ (loop for i from 0 below octet-count
+ collect (sap-ref-8 sap (+ head i)))))
+ (attempt-resync ()
+ :report (lambda (stream)
+ (format stream
+ "~@<Attempt to resync the stream at a character ~
+ character boundary and continue.~@:>"))
+ (fd-stream-resync stream)
+ nil)
+ (force-end-of-file ()
+ :report (lambda (stream)
+ (format stream "~@<Force an end of file.~@:>"))
+ t)))
+
+(defun stream-encoding-error-and-handle (stream code)
+ (restart-case
+ (stream-encoding-error stream code)
+ (output-nothing ()
+ :report (lambda (stream)
+ (format stream "~@<Skip output of this character.~@:>"))
+ (throw 'output-nothing nil))))
+
;;; This is called by the server when we can write to the given file
;;; descriptor. Attempt to write the data again. If it worked, remove
;;; the data from the OUTPUT-LATER list. If it didn't work, something
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
-
- `(with-simple-restart (output-nothing
- "~@<Skip output of this character.~@:>")
- ,@body
- (incf (fd-stream-obuf-tail ,stream-var) size))
+ `(catch 'output-nothing
+ ,@body
+ (incf (fd-stream-obuf-tail ,stream-var) size))
`(progn
,@body
(incf (fd-stream-obuf-tail ,stream-var) size)))
,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
- `(with-simple-restart (output-nothing
- "~@<Skip output of this character.~@:>")
- ,@body
- (incf (fd-stream-obuf-tail ,stream-var) ,size))
+ `(catch 'output-nothing
+ ,@body
+ (incf (fd-stream-obuf-tail ,stream-var) ,size))
`(progn
,@body
(incf (fd-stream-obuf-tail ,stream-var) ,size)))
(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)
(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)
(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))
((zerop bytes)) ; easy case
((<= bytes space)
(if (system-area-pointer-p thing)
- (system-area-copy thing
- (* start sb!vm:n-byte-bits)
- (fd-stream-obuf-sap fd-stream)
- (* tail sb!vm:n-byte-bits)
- (* bytes sb!vm:n-byte-bits))
+ (system-area-ub8-copy thing start
+ (fd-stream-obuf-sap fd-stream)
+ tail
+ bytes)
;; FIXME: There should be some type checking somewhere to
;; verify that THING here is a vector, not just <not a SAP>.
- (copy-to-system-area thing
- (+ (* start sb!vm:n-byte-bits)
- (* sb!vm:vector-data-offset
- sb!vm:n-word-bits))
- (fd-stream-obuf-sap fd-stream)
- (* tail sb!vm:n-byte-bits)
- (* bytes sb!vm:n-byte-bits)))
+ (copy-ub8-to-system-area thing start
+ (fd-stream-obuf-sap fd-stream)
+ tail
+ bytes))
(setf (fd-stream-obuf-tail fd-stream) newtail))
((<= bytes len)
(flush-output-buffer fd-stream)
(if (system-area-pointer-p thing)
- (system-area-copy thing
- (* start sb!vm:n-byte-bits)
- (fd-stream-obuf-sap fd-stream)
- 0
- (* bytes sb!vm:n-byte-bits))
+ (system-area-ub8-copy thing
+ start
+ (fd-stream-obuf-sap fd-stream)
+ 0
+ bytes)
;; FIXME: There should be some type checking somewhere to
;; verify that THING here is a vector, not just <not a SAP>.
- (copy-to-system-area thing
- (+ (* start sb!vm:n-byte-bits)
- (* sb!vm:vector-data-offset
- sb!vm:n-word-bits))
- (fd-stream-obuf-sap fd-stream)
- 0
- (* bytes sb!vm:n-byte-bits)))
+ (copy-ub8-to-system-area thing
+ start
+ (fd-stream-obuf-sap fd-stream)
+ 0
+ bytes))
(setf (fd-stream-obuf-tail fd-stream) bytes))
(t
(flush-output-buffer fd-stream)
: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))
;;; 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))
(setf (fd-stream-ibuf-tail stream) 0))
(t
(decf tail head)
- (system-area-copy ibuf-sap (* head sb!vm:n-byte-bits)
- ibuf-sap 0 (* tail sb!vm:n-byte-bits))
+ (system-area-ub8-copy ibuf-sap head
+ ibuf-sap 0 tail)
(setf head 0)
(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
(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)))
(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
- resync-function)
+(defmacro input-wrapper/variable-width ((stream bytes eof-error eof-value)
&body read-forms)
(let ((stream-var (gensym))
(retry-var (gensym))
(fd-stream-unread ,stream-var)
(setf (fd-stream-unread ,stream-var) nil)
(setf (fd-stream-listen ,stream-var) nil))
- (let ((,element-var nil))
+ (let ((,element-var nil)
+ (decode-break-reason nil))
(do ((,retry-var t))
((not ,retry-var))
- (setq ,retry-var nil)
- (restart-case
+ (unless
(catch 'eof-input-catcher
- (unless
- (block character-decode
- (input-at-least ,stream-var 1)
- (let* ((byte (sap-ref-8 (fd-stream-ibuf-sap
- ,stream-var)
- (fd-stream-ibuf-head
- ,stream-var))))
- (setq size ,bytes)
- (input-at-least ,stream-var size)
- (setq ,element-var (locally ,@read-forms))))
- (stream-decoding-error
- ,stream-var
- (if size
- (loop for i from 0 below size
- collect (sap-ref-8 (fd-stream-ibuf-sap
+ (setf decode-break-reason
+ (block decode-break-reason
+ (input-at-least ,stream-var 1)
+ (let* ((byte (sap-ref-8 (fd-stream-ibuf-sap
,stream-var)
- (+ (fd-stream-ibuf-head
- ,stream-var)
- i)))
- (list (sap-ref-8 (fd-stream-ibuf-sap
- ,stream-var)
- (fd-stream-ibuf-head
- ,stream-var)))))))
- (attempt-resync ()
- :report (lambda (stream)
- (format stream
- "~@<Attempt to resync the stream at a ~
- character boundary and continue.~@:>"))
- (,resync-function ,stream-var)
- (setq ,retry-var t))
- (force-end-of-file ()
- :report (lambda (stream)
- (format stream
- "~@<Force an end of file.~@:>"))
- nil)))
+ (fd-stream-ibuf-head
+ ,stream-var))))
+ (setq size ,bytes)
+ (input-at-least ,stream-var size)
+ (setq ,element-var (locally ,@read-forms))
+ (setq ,retry-var nil))
+ nil))
+ (when decode-break-reason
+ (stream-decoding-error-and-handle stream
+ decode-break-reason))
+ t)
+ (let ((octet-count (- (fd-stream-ibuf-tail ,stream-var)
+ (fd-stream-ibuf-head ,stream-var))))
+ (when (or (zerop octet-count)
+ (and (not ,element-var)
+ (not decode-break-reason)
+ (stream-decoding-error-and-handle
+ stream octet-count)))
+ (setq ,retry-var nil)))))
(cond (,element-var
(incf (fd-stream-ibuf-head ,stream-var) size)
,element-var)
(eof-or-lose ,stream-var ,eof-error ,eof-value))))))))
(defmacro def-input-routine/variable-width (name
- (type external-format size sap head
- resync-function)
+ (type external-format size sap head)
&rest body)
`(progn
(defun ,name (stream eof-error eof-value)
- (input-wrapper/variable-width (stream ,size eof-error eof-value
- ,resync-function)
+ (input-wrapper/variable-width (stream ,size eof-error eof-value)
(let ((,sap (fd-stream-ibuf-sap stream))
(,head (fd-stream-ibuf-head stream)))
,@body)))
(declare (type index start end))
(let* ((length (- end start))
(string (make-string length)))
- (copy-from-system-area sap (* start sb!vm:n-byte-bits)
- string (* sb!vm:vector-data-offset
- sb!vm:n-word-bits)
- (* length sb!vm:n-byte-bits))
+ (copy-ub8-from-system-area sap start
+ string 0
+ length)
string))
;;; the N-BIN method for FD-STREAMs
(= 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)))
;; 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!"))
(tail (fd-stream-obuf-tail stream)))
((or (= start end) (< (- len tail) 4)) tail)
,(if output-restart
- `(with-simple-restart (output-nothing
- "~@<Skip output of this character.~@:>")
- (let* ((byte (aref string start))
- (bits (char-code byte)))
- ,out-expr
- (incf tail ,size)))
+ `(catch 'output-nothing
+ (let* ((byte (aref string start))
+ (bits (char-code byte)))
+ ,out-expr
+ (incf tail ,size)))
`(let* ((byte (aref string start))
(bits (char-code byte)))
,out-expr
(= 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)))
(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*)))))
(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)
- (let* ((byte (aref string start))
- (bits (char-code byte))
- (size ,out-size-expr))
- ,out-expr
- (incf tail size)
- (incf start))))
+ ,(if output-restart
+ `(catch 'output-nothing
+ (let* ((byte (aref string start))
+ (bits (char-code byte))
+ (size ,out-size-expr))
+ ,out-expr
+ (incf tail size)))
+ `(let* ((byte (aref string start))
+ (bits (char-code byte))
+ (size ,out-size-expr))
+ ,out-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
(nil)
(let* ((head (fd-stream-ibuf-head stream))
(tail (fd-stream-ibuf-tail stream))
- (sap (fd-stream-ibuf-sap stream)))
+ (sap (fd-stream-ibuf-sap stream))
+ (head-start head)
+ (decode-break-reason nil))
(declare (type index head tail))
;; Copy data from stream buffer into user's buffer.
(do ((size nil nil))
((or (= tail head) (= requested total-copied)))
- (restart-case
- (unless (block character-decode
- (let ((byte (sap-ref-8 sap head)))
- (setq size ,in-size-expr)
- (when (> size (- tail head))
- (return))
- (setf (aref buffer (+ start total-copied))
- ,in-expr)
- (incf total-copied)
- (incf head size)))
- (setf (fd-stream-ibuf-head stream) head)
- (if (plusp total-copied)
- (return-from ,in-function total-copied)
- (stream-decoding-error
- stream
- (if size
- (loop for i from 0 below size
- collect (sap-ref-8 (fd-stream-ibuf-sap
- stream)
- (+ (fd-stream-ibuf-head
- stream)
- i)))
- (list (sap-ref-8 (fd-stream-ibuf-sap stream)
- (fd-stream-ibuf-head stream)))))))
- (attempt-resync ()
- :report (lambda (stream)
- (format stream
- "~@<Attempt to resync the stream at a ~
- character boundary and continue.~@:>"))
- (,resync-function stream)
- (setf head (fd-stream-ibuf-head stream)))
- (force-end-of-file ()
- :report (lambda (stream)
- (format stream "~@<Force an end of file.~@:>"))
+ (setf decode-break-reason
+ (block decode-break-reason
+ (let ((byte (sap-ref-8 sap head)))
+ (setq size ,in-size-expr)
+ (when (> size (- tail head))
+ (return))
+ (setf (aref buffer (+ start total-copied)) ,in-expr)
+ (incf total-copied)
+ (incf head size))
+ nil))
+ (setf (fd-stream-ibuf-head stream) head)
+ (when (and decode-break-reason
+ (= head head-start))
+ (when (stream-decoding-error-and-handle
+ stream decode-break-reason)
(if eof-error-p
(error 'end-of-file :stream stream)
- (return-from ,in-function total-copied)))))
+ (return-from ,in-function total-copied)))
+ (setf head (fd-stream-ibuf-head stream))
+ (setf tail (fd-stream-ibuf-tail stream)))
+ (when (plusp total-copied)
+ (return-from ,in-function total-copied)))
(setf (fd-stream-ibuf-head stream) head)
;; Maybe we need to refill the stream buffer.
(cond ( ;; If there were enough data in the stream buffer, we're done.
(= total-copied requested)
(return total-copied))
( ;; If EOF, we're done in another way.
- (zerop (refill-fd-stream-buffer stream))
+ (or (eq decode-break-reason 'eof)
+ (null (catch 'eof-input-catcher
+ (refill-buffer/fd stream))))
(if eof-error-p
(error 'end-of-file :stream stream)
(return total-copied)))
(def-input-routine/variable-width ,in-char-function (character
,external-format
,in-size-expr
- sap head
- ,resync-function)
+ sap head)
(let ((byte (sap-ref-8 sap head)))
,in-expr))
(defun ,resync-function (stream)
(loop (input-at-least stream 1)
(incf (fd-stream-ibuf-head stream))
- (when (block character-decode
- (let* ((sap (fd-stream-ibuf-sap stream))
- (head (fd-stream-ibuf-head stream))
- (byte (sap-ref-8 sap head))
- (size ,in-size-expr))
- ,in-expr))
+ (unless (block decode-break-reason
+ (let* ((sap (fd-stream-ibuf-sap stream))
+ (head (fd-stream-ibuf-head stream))
+ (byte (sap-ref-8 sap head))
+ (size ,in-size-expr))
+ ,in-expr)
+ nil)
(return))))
(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*)))))
(define-external-format (:latin-1 :latin1 :iso-8859-1)
1 t
(if (>= bits 256)
- (stream-encoding-error stream bits)
+ (stream-encoding-error-and-handle stream bits)
(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 stream bits)
+ (stream-encoding-error-and-handle stream bits)
(setf (sap-ref-8 sap tail) bits))
(code-char byte))
+(let* ((table (let ((s (make-string 256)))
+ (map-into s #'code-char
+ '(#x00 #x01 #x02 #x03 #x9c #x09 #x86 #x7f #x97 #x8d #x8e #x0b #x0c #x0d #x0e #x0f
+ #x10 #x11 #x12 #x13 #x9d #x85 #x08 #x87 #x18 #x19 #x92 #x8f #x1c #x1d #x1e #x1f
+ #x80 #x81 #x82 #x83 #x84 #x0a #x17 #x1b #x88 #x89 #x8a #x8b #x8c #x05 #x06 #x07
+ #x90 #x91 #x16 #x93 #x94 #x95 #x96 #x04 #x98 #x99 #x9a #x9b #x14 #x15 #x9e #x1a
+ #x20 #xa0 #xe2 #xe4 #xe0 #xe1 #xe3 #xe5 #xe7 #xf1 #xa2 #x2e #x3c #x28 #x2b #x7c
+ #x26 #xe9 #xea #xeb #xe8 #xed #xee #xef #xec #xdf #x21 #x24 #x2a #x29 #x3b #xac
+ #x2d #x2f #xc2 #xc4 #xc0 #xc1 #xc3 #xc5 #xc7 #xd1 #xa6 #x2c #x25 #x5f #x3e #x3f
+ #xf8 #xc9 #xca #xcb #xc8 #xcd #xce #xcf #xcc #x60 #x3a #x23 #x40 #x27 #x3d #x22
+ #xd8 #x61 #x62 #x63 #x64 #x65 #x66 #x67 #x68 #x69 #xab #xbb #xf0 #xfd #xfe #xb1
+ #xb0 #x6a #x6b #x6c #x6d #x6e #x6f #x70 #x71 #x72 #xaa #xba #xe6 #xb8 #xc6 #xa4
+ #xb5 #x7e #x73 #x74 #x75 #x76 #x77 #x78 #x79 #x7a #xa1 #xbf #xd0 #xdd #xde #xae
+ #x5e #xa3 #xa5 #xb7 #xa9 #xa7 #xb6 #xbc #xbd #xbe #x5b #x5d #xaf #xa8 #xb4 #xd7
+ #x7b #x41 #x42 #x43 #x44 #x45 #x46 #x47 #x48 #x49 #xad #xf4 #xf6 #xf2 #xf3 #xf5
+ #x7d #x4a #x4b #x4c #x4d #x4e #x4f #x50 #x51 #x52 #xb9 #xfb #xfc #xf9 #xfa #xff
+ #x5c #xf7 #x53 #x54 #x55 #x56 #x57 #x58 #x59 #x5a #xb2 #xd4 #xd6 #xd2 #xd3 #xd5
+ #x30 #x31 #x32 #x33 #x34 #x35 #x36 #x37 #x38 #x39 #xb3 #xdb #xdc #xd9 #xda #x9f))
+ s))
+ (reverse-table (let ((rt (make-array 256 :element-type '(unsigned-byte 8) :initial-element 0)))
+ (loop for char across table for i from 0
+ do (aver (= 0 (aref rt (char-code char))))
+ do (setf (aref rt (char-code char)) i))
+ rt)))
+ (define-external-format (:ebcdic-us :ibm-037 :ibm037)
+ 1 t
+ (if (>= bits 256)
+ (stream-encoding-error-and-handle stream bits)
+ (setf (sap-ref-8 sap tail) (aref reverse-table bits)))
+ (aref table byte)))
+
+
#!+sb-unicode
(let ((latin-9-table (let ((table (make-string 256)))
(do ((i 0 (1+ i)))
(if (< bits 256)
(if (= bits (char-code (aref latin-9-table bits)))
bits
- (stream-encoding-error stream byte))
+ (stream-encoding-error-and-handle stream byte))
(if (= (aref latin-9-reverse-1 (logand bits 15)) bits)
(aref latin-9-reverse-2 (logand bits 15))
- (stream-encoding-error stream byte))))
+ (stream-encoding-error-and-handle stream byte))))
(aref latin-9-table byte)))
(define-external-format/variable-width (:utf-8 :utf8) nil
(sap-ref-8 sap (+ 2 tail)) (logior #x80 (ldb (byte 6 6) bits))
(sap-ref-8 sap (+ 3 tail)) (logior #x80 (ldb (byte 6 0) bits)))))
(cond ((< byte #x80) 1)
- ((< byte #xc2) (return-from character-decode))
+ ((< byte #xc2) (return-from decode-break-reason 1))
((< byte #xe0) 2)
((< byte #xf0) 3)
(t 4))
(1 byte)
(2 (let ((byte2 (sap-ref-8 sap (1+ head))))
(unless (<= #x80 byte2 #xbf)
- (return-from character-decode))
+ (return-from decode-break-reason 2))
(dpb byte (byte 5 6) byte2)))
(3 (let ((byte2 (sap-ref-8 sap (1+ head)))
(byte3 (sap-ref-8 sap (+ 2 head))))
(unless (and (<= #x80 byte2 #xbf)
(<= #x80 byte3 #xbf))
- (return-from character-decode))
+ (return-from decode-break-reason 3))
(dpb byte (byte 4 12) (dpb byte2 (byte 6 6) byte3))))
(4 (let ((byte2 (sap-ref-8 sap (1+ head)))
(byte3 (sap-ref-8 sap (+ 2 head)))
(unless (and (<= #x80 byte2 #xbf)
(<= #x80 byte3 #xbf)
(<= #x80 byte4 #xbf))
- (return-from character-decode))
+ (return-from decode-break-reason 4))
(dpb byte (byte 3 18)
(dpb byte2 (byte 6 12)
(dpb byte3 (byte 6 6) byte4))))))))
;;; 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)))
(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)
- (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
(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 ()
(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)))
: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