:stream stream
:code code))
+(defun c-string-encoding-error (external-format code)
+ (error 'c-string-encoding-error
+ :external-format external-format
+ :code code))
+
+(defun c-string-decoding-error (external-format octets)
+ (error 'c-string-decoding-error
+ :external-format external-format
+ :octets octets))
+
;;; 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)
(format stream "~@<Skip output of this character.~@:>"))
(throw 'output-nothing nil))))
+(defun external-format-encoding-error (stream code)
+ (if (streamp stream)
+ (stream-encoding-error-and-handle stream code)
+ (c-string-encoding-error stream code)))
+
+(defun external-format-decoding-error (stream octet-count)
+ (if (streamp stream)
+ (stream-decoding-error stream octet-count)
+ (c-string-decoding-error stream octet-count)))
+
;;; 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
start
length)
(cond ((not count)
- (if (= errno sb!unix:ewouldblock)
+ (if #!-win32 (= errno sb!unix:ewouldblock) #!+win32 t #!-win32
(error "Write would have blocked, but SERVER told us to go.")
(simple-stream-perror "couldn't write to ~S" stream errno)))
((eql count length) ; Hot damn, it worked.
(multiple-value-bind (count errno)
(sb!unix:unix-write (fd-stream-fd stream) base start length)
(cond ((not count)
- (if (= errno sb!unix:ewouldblock)
+ (if #!-win32 (= errno sb!unix:ewouldblock) #!+win32 t #!-win32
(output-later stream base start end reuse-sap)
(simple-stream-perror "couldn't write to ~S"
stream
(intern (format nil name-fmt (string (car buffering))))))
`(progn
(defun ,function (stream byte)
+ (declare (ignorable byte))
(output-wrapper/variable-width (stream ,size ,buffering ,restart)
,@body))
(setf *output-routines*
(end (or end (length (the vector thing)))))
(declare (fixnum start end))
(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
- :end end))))
+ (let ((last-newline
+ (string-dispatch (simple-base-string
+ #!+sb-unicode
+ (simple-array character)
+ string)
+ thing
+ (and (find #\newline thing :start start :end end)
+ ;; FIXME why do we need both calls?
+ ;; Is find faster forwards than
+ ;; position is backwards?
+ (position #\newline thing
+ :from-end t
+ :start start
+ :end end)))))
(if (and (typep thing 'base-string)
(eq (fd-stream-external-format stream) :latin-1))
(ecase (fd-stream-buffering stream)
element-type, string input function name, character input function name,
and string output function name.")
+(defun get-external-format (external-format)
+ (dolist (entry *external-formats*)
+ (when (member external-format (first entry))
+ (return entry))))
+
+(defun get-external-format-function (external-format index)
+ (let ((entry (get-external-format external-format)))
+ (when entry (nth index entry))))
+
;;; Find an output routine to use given the type and buffering. Return
;;; as multiple values the routine, the real type transfered, and the
;;; number of bytes per element.
(defun pick-output-routine (type buffering &optional external-format)
(when (subtypep type 'character)
- (dolist (entry *external-formats*)
- (when (member external-format (first entry))
+ (let ((entry (get-external-format external-format)))
+ (when entry
(return-from pick-output-routine
(values (symbol-function (nth (ecase buffering
(:none 4)
;;; per element.
(defvar *input-routines* ())
+;;; Return whether a primitive partial read operation on STREAM's FD
+;;; would (probably) block. Signal a `simple-stream-error' if the
+;;; system call implementing this operation fails.
+;;;
+;;; It is "may" instead of "would" because "would" is not quite
+;;; correct on win32. However, none of the places that use it require
+;;; further assurance than "may" versus "will definitely not".
+(defun sysread-may-block-p (stream)
+ #+win32
+ ;; This answers T at EOF on win32, I think.
+ (not (sb!win32:fd-listen (fd-stream-fd stream)))
+ #-win32
+ (sb!unix:with-restarted-syscall (count errno)
+ (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 stream) read-fds)
+ (sb!unix:unix-fast-select (1+ (fd-stream-fd stream))
+ (sb!alien:addr read-fds)
+ nil nil 0 0))
+ (case count
+ ((1) nil)
+ ((0) t)
+ (otherwise
+ (simple-stream-perror "couldn't check whether ~S is readable"
+ stream
+ errno)))))
+
;;; 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.
(setf (fd-stream-ibuf-head stream) 0)
(setf (fd-stream-ibuf-tail stream) tail))))
(setf (fd-stream-listen stream) nil)
- (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)))
- (t
- (simple-stream-perror "couldn't check whether ~S is readable"
- stream
- errno))))
+ ;;This isn't quite the same on win32. Then again, neither was
+ ;;(not (sb!win32:fd-listen fd)), as was originally here. See
+ ;;comment in `sysread-may-block-p'.
+ (when (sysread-may-block-p stream)
+ (unless (sb!sys:wait-until-fd-usable
+ fd :input (fd-stream-timeout stream))
+ (error 'io-timeout :stream stream :direction :read)))
(multiple-value-bind (count errno)
(sb!unix:unix-read fd
(sb!sys:int-sap (+ (sb!sys:sap-int ibuf-sap) tail))
(- buflen tail))
(cond ((null count)
- (if (eql errno sb!unix:ewouldblock)
+ (if #!-win32 (eql errno sb!unix:ewouldblock) #!+win32 t #!-win32
(progn
(unless (sb!sys:wait-until-fd-usable
fd :input (fd-stream-timeout stream))
,stream-var)
(fd-stream-ibuf-head
,stream-var))))
+ (declare (ignorable byte))
(setq size ,bytes)
(input-at-least ,stream-var size)
(setq ,element-var (locally ,@read-forms))
(return-from fd-stream-resync
(funcall (symbol-function (eighth entry)) stream)))))
+(defun get-fd-stream-character-sizer (stream)
+ (dolist (entry *external-formats*)
+ (when (member (fd-stream-external-format stream) (first entry))
+ (return-from get-fd-stream-character-sizer (ninth entry)))))
+
+(defun fd-stream-character-size (stream char)
+ (let ((sizer (get-fd-stream-character-sizer stream)))
+ (when sizer (funcall sizer char))))
+
+(defun fd-stream-string-size (stream string)
+ (let ((sizer (get-fd-stream-character-sizer stream)))
+ (when sizer
+ (loop for char across string summing (funcall sizer char)))))
+
+(defun find-external-format (external-format)
+ (when external-format
+ (find external-format *external-formats* :test #'member :key #'car)))
+
+(defun variable-width-external-format-p (ef-entry)
+ (when (eighth ef-entry) t))
+
+(defun bytes-for-char-fun (ef-entry)
+ (if ef-entry (symbol-function (ninth ef-entry)) (constantly 1)))
+
;;; FIXME: OAOOM here vrt. *EXTERNAL-FORMAT-FUNCTIONS* in fd-stream.lisp
(defmacro define-external-format (external-format size output-restart
out-expr in-expr)
(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)))
+ (in-char-function (symbolicate "INPUT-CHAR/" name))
+ (size-function (symbolicate "BYTES-FOR-CHAR/" name))
+ (read-c-string-function (symbolicate "READ-FROM-C-STRING/" name))
+ (output-c-string-function (symbolicate "OUTPUT-TO-C-STRING/" name)))
`(progn
+ (defun ,size-function (byte)
+ (declare (ignore byte))
+ ,size)
(defun ,out-function (stream string flush-p start end)
(let ((start (or start 0))
(end (or end (length string))))
(> (fd-stream-ibuf-tail stream)
(fd-stream-ibuf-head stream)))
(file-position stream (file-position stream)))
- (when (< end start)
- (error ":END before :START!"))
+ (unless (<= 0 start end (length string))
+ (signal-bounding-indices-bad-error string start end))
(do ()
((= end start))
(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
- (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
- (incf tail ,size)))
- (incf start)))
+ (string-dispatch (simple-base-string
+ #!+sb-unicode
+ (simple-array character)
+ string)
+ string
+ (let ((len (fd-stream-obuf-length stream))
+ (sap (fd-stream-obuf-sap stream))
+ (tail (fd-stream-obuf-tail stream)))
+ (declare (type index tail)
+ ;; STRING bounds have already been checked.
+ (optimize (safety 0)))
+ (loop
+ (,@(if output-restart
+ `(catch 'output-nothing)
+ `(progn))
+ (do* ()
+ ((or (= start end) (< (- len tail) 4)))
+ (let* ((byte (aref string start))
+ (bits (char-code byte)))
+ ,out-expr
+ (incf tail ,size)
+ (incf start)))
+ ;; Exited from the loop normally
+ (return tail))
+ ;; Exited via CATCH. Skip the current character
+ ;; and try the inner loop again.
+ (incf start)))))
(when (< start end)
(flush-output-buffer stream)))
(when flush-p
(tail (fd-stream-obuf-tail stream)))
,out-expr))
(defun ,in-function (stream buffer start requested eof-error-p
- &aux (total-copied 0))
+ &aux (index start) (end (+ start requested)))
(declare (type fd-stream stream))
- (declare (type index start requested total-copied))
+ (declare (type index start requested index end))
(declare (type (simple-array character (#.+ansi-stream-in-buffer-length+)) buffer))
(let ((unread (fd-stream-unread stream)))
(when unread
- (setf (aref buffer start) unread)
+ (setf (aref buffer index) unread)
(setf (fd-stream-unread stream) nil)
(setf (fd-stream-listen stream) nil)
- (incf total-copied)))
+ (incf index)))
(do ()
(nil)
(let* ((head (fd-stream-ibuf-head stream))
(tail (fd-stream-ibuf-tail stream))
(sap (fd-stream-ibuf-sap stream)))
- (declare (type index head tail))
+ (declare (type index head tail)
+ (type system-area-pointer sap))
;; Copy data from stream buffer into user's buffer.
- (do ()
- ((or (= tail head) (= requested total-copied)))
+ (dotimes (i (min (truncate (- tail head) ,size)
+ (- end index)))
+ (declare (optimize speed))
(let* ((byte (sap-ref-8 sap head)))
- (when (> ,size (- tail head))
- (return))
- (setf (aref buffer (+ start total-copied)) ,in-expr)
- (incf total-copied)
+ (setf (aref buffer index) ,in-expr)
+ (incf index)
(incf head ,size)))
(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))
+ (cond ( ;; If there was enough data in the stream buffer, we're done.
+ (= index end)
+ (return (- index start)))
( ;; If EOF, we're done in another way.
(null (catch 'eof-input-catcher (refill-buffer/fd stream)))
(if eof-error-p
(error 'end-of-file :stream stream)
- (return total-copied)))
+ (return (- index start))))
;; Otherwise we refilled the stream buffer, so fall
;; through into another pass of the loop.
))))
(def-input-routine ,in-char-function (character ,size sap head)
(let ((byte (sap-ref-8 sap head)))
,in-expr))
+ (defun ,read-c-string-function (sap element-type)
+ (declare (type system-area-pointer sap)
+ (type (member character base-char) element-type))
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (let* ((stream ,name)
+ (length (loop for head of-type index upfrom 0 by ,size
+ for count of-type index upto (1- ARRAY-DIMENSION-LIMIT)
+ for byte = (sap-ref-8 sap head)
+ for char of-type character = ,in-expr
+ until (zerop (char-code char))
+ finally (return count)))
+ (string (make-string length :element-type element-type)))
+ (declare (ignorable stream)
+ (type index length)
+ (type string string))
+ (/show0 before-copy-loop)
+ (loop for head of-type index upfrom 0 by ,size
+ for index of-type index below length
+ for byte = (sap-ref-8 sap head)
+ for char of-type character = ,in-expr
+ do (setf (aref string index) char))
+ string))) ;; last loop rewrite to dotimes?
+ (defun ,output-c-string-function (string)
+ (declare (type simple-string string))
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (let* ((length (length string))
+ (buffer (make-array (* (1+ length) ,size) :element-type '(unsigned-byte 8)))
+ (sap (sb!sys:vector-sap buffer))
+ (tail 0)
+ (stream ,name))
+ (declare (type index length tail)
+ (type system-area-pointer sap))
+ (dotimes (i length)
+ (let* ((byte (aref string i))
+ (bits (char-code byte)))
+ (declare (ignorable byte bits))
+ ,out-expr)
+ (incf tail ,size))
+ (let* ((bits 0)
+ (byte (code-char bits)))
+ (declare (ignorable bits byte))
+ ,out-expr)
+ buffer)))
(setf *external-formats*
(cons '(,external-format ,in-function ,in-char-function ,out-function
,@(mapcar #'(lambda (buffering)
(intern (format nil format (string buffering))))
- '(:none :line :full)))
+ '(:none :line :full))
+ nil ; no resync-function
+ ,size-function ,read-c-string-function ,output-c-string-function)
*external-formats*)))))
(defmacro define-external-format/variable-width
(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)))
+ (resync-function (symbolicate "RESYNC/" name))
+ (size-function (symbolicate "BYTES-FOR-CHAR/" name))
+ (read-c-string-function (symbolicate "READ-FROM-C-STRING/" name))
+ (output-c-string-function (symbolicate "OUTPUT-TO-C-STRING/" name)))
`(progn
+ (defun ,size-function (byte)
+ (declare (ignorable byte))
+ ,out-size-expr)
(defun ,out-function (stream string flush-p start end)
(let ((start (or start 0))
(end (or end (length string))))
(> (fd-stream-ibuf-tail stream)
(fd-stream-ibuf-head stream)))
(file-position stream (file-position stream)))
- (when (< end start)
- (error ":END before :START!"))
+ (unless (<= 0 start end (length string))
+ (signal-bounding-indices-bad-error string start end))
(do ()
((= end start))
(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
- (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)))
+ (string-dispatch (simple-base-string
+ #!+sb-unicode
+ (simple-array character)
+ string)
+ string
+ (let ((len (fd-stream-obuf-length stream))
+ (sap (fd-stream-obuf-sap stream))
+ (tail (fd-stream-obuf-tail stream)))
+ (declare (type index tail)
+ ;; STRING bounds have already been checked.
+ (optimize (safety 0)))
+ (loop
+ (,@(if output-restart
+ `(catch 'output-nothing)
+ `(progn))
+ (do* ()
+ ((or (= start end) (< (- len tail) 4)))
+ (let* ((byte (aref string start))
+ (bits (char-code byte))
+ (size ,out-size-expr))
+ ,out-expr
+ (incf tail size)
+ (incf start)))
+ ;; Exited from the loop normally
+ (return tail))
+ ;; Exited via CATCH. Skip the current character
+ ;; and try the inner loop again.
+ (incf start)))))
(when (< start end)
(flush-output-buffer stream)))
(when flush-p
(let* ((head (fd-stream-ibuf-head stream))
(tail (fd-stream-ibuf-tail 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.
(setf decode-break-reason
(block decode-break-reason
(let ((byte (sap-ref-8 sap head)))
+ (declare (ignorable byte))
(setq size ,in-size-expr)
(when (> size (- tail head))
(return))
(incf head size))
nil))
(setf (fd-stream-ibuf-head stream) head)
- (when (and decode-break-reason
- (= head head-start))
+ (when decode-break-reason
+ ;; If we've already read some characters on when the invalid
+ ;; code sequence is detected, we return immediately. The
+ ;; handling of the error is deferred until the next call
+ ;; (where this check will be false). This allows establishing
+ ;; high-level handlers for decode errors (for example
+ ;; automatically resyncing in Lisp comments).
+ (when (plusp total-copied)
+ (return-from ,in-function total-copied))
(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)))
(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 tail (fd-stream-ibuf-tail stream))))
(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.
,in-size-expr
sap head)
(let ((byte (sap-ref-8 sap head)))
+ (declare (ignorable byte))
,in-expr))
(defun ,resync-function (stream)
- (loop (input-at-least stream 1)
+ (loop (input-at-least stream 2)
(incf (fd-stream-ibuf-head stream))
(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)
+ (declare (ignorable byte))
+ (input-at-least stream size)
+ (let ((sap (fd-stream-ibuf-sap stream))
+ (head (fd-stream-ibuf-head stream)))
+ ,in-expr))
nil)
(return))))
+ (defun ,read-c-string-function (sap element-type)
+ (declare (type system-area-pointer sap))
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (let* ((stream ,name)
+ (size 0) (head 0) (byte 0) (char nil)
+ (decode-break-reason nil)
+ (length (dotimes (count (1- ARRAY-DIMENSION-LIMIT) count)
+ (setf decode-break-reason
+ (block decode-break-reason
+ (setf byte (sap-ref-8 sap head)
+ size ,in-size-expr
+ char ,in-expr)
+ (incf head size)
+ nil))
+ (when decode-break-reason
+ (c-string-decoding-error ,name decode-break-reason))
+ (when (zerop (char-code char))
+ (return count))))
+ (string (make-string length :element-type element-type)))
+ (declare (ignorable stream)
+ (type index head length) ;; size
+ (type (unsigned-byte 8) byte)
+ (type (or null character) char)
+ (type string string))
+ (setf head 0)
+ (dotimes (index length string)
+ (setf decode-break-reason
+ (block decode-break-reason
+ (setf byte (sap-ref-8 sap head)
+ size ,in-size-expr
+ char ,in-expr)
+ (incf head size)
+ nil))
+ (when decode-break-reason
+ (c-string-decoding-error ,name decode-break-reason))
+ (setf (aref string index) char)))))
+
+ (defun ,output-c-string-function (string)
+ (declare (type simple-string string))
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (let* ((length (length string))
+ (char-length (make-array (1+ length) :element-type 'index))
+ (buffer-length
+ (+ (loop for i of-type index below length
+ for byte of-type character = (aref string i)
+ for bits = (char-code byte)
+ sum (setf (aref char-length i)
+ (the index ,out-size-expr)))
+ (let* ((byte (code-char 0))
+ (bits (char-code byte)))
+ (declare (ignorable byte bits))
+ (setf (aref char-length length)
+ (the index ,out-size-expr)))))
+ (tail 0)
+ (buffer (make-array buffer-length :element-type '(unsigned-byte 8)))
+ (sap (sb!sys:vector-sap buffer))
+ stream)
+ (declare (type index length buffer-length tail)
+ (type system-area-pointer sap)
+ (type null stream)
+ (ignorable stream))
+ (loop for i of-type index below length
+ for byte of-type character = (aref string i)
+ for bits = (char-code byte)
+ for size of-type index = (aref char-length i)
+ do (prog1
+ ,out-expr
+ (incf tail size)))
+ (let* ((bits 0)
+ (byte (code-char bits))
+ (size (aref char-length length)))
+ (declare (ignorable bits byte size))
+ ,out-expr)
+ buffer)))
+
(setf *external-formats*
(cons '(,external-format ,in-function ,in-char-function ,out-function
,@(mapcar #'(lambda (buffering)
(intern (format nil format (string buffering))))
'(:none :line :full))
- ,resync-function)
+ ,resync-function
+ ,size-function ,read-c-string-function ,output-c-string-function)
*external-formats*)))))
-(define-external-format (:latin-1 :latin1 :iso-8859-1)
+;;; Multiple names for the :ISO{,-}8859-* families are needed because on
+;;; FreeBSD (and maybe other BSD systems), nl_langinfo("LATIN-1") will
+;;; return "ISO8859-1" instead of "ISO-8859-1".
+(define-external-format (:latin-1 :latin1 :iso-8859-1 :iso8859-1)
1 t
(if (>= bits 256)
- (stream-encoding-error-and-handle stream bits)
+ (external-format-encoding-error stream bits)
(setf (sap-ref-8 sap tail) bits))
(code-char byte))
:iso-646 :iso-646-us :|646|)
1 t
(if (>= bits 128)
- (stream-encoding-error-and-handle stream bits)
+ (external-format-encoding-error stream bits)
(setf (sap-ref-8 sap tail) bits))
(code-char byte))
(define-external-format (:ebcdic-us :ibm-037 :ibm037)
1 t
(if (>= bits 256)
- (stream-encoding-error-and-handle stream bits)
+ (external-format-encoding-error stream bits)
(setf (sap-ref-8 sap tail) (aref reverse-table bits)))
(aref table byte)))
(latin-9-reverse-2 (make-array 16
:element-type '(unsigned-byte 8)
:initial-contents '(#xa6 #xa8 #xbc #xbd 0 0 0 0 #xbe 0 0 0 #xa4 #xb4 #xb8 0))))
- (define-external-format (:latin-9 :latin9 :iso-8859-15)
+ (define-external-format (:latin-9 :latin9 :iso-8859-15 :iso8859-15)
1 t
(setf (sap-ref-8 sap tail)
(if (< bits 256)
(if (= bits (char-code (aref latin-9-table bits)))
bits
- (stream-encoding-error-and-handle stream byte))
+ (external-format-encoding-error stream byte))
(if (= (aref latin-9-reverse-1 (logand bits 15)) bits)
(aref latin-9-reverse-2 (logand bits 15))
- (stream-encoding-error-and-handle stream byte))))
+ (external-format-encoding-error stream byte))))
(aref latin-9-table byte)))
(define-external-format/variable-width (:utf-8 :utf8) nil
(declare (ignore arg2))
(case operation
(:listen
- (or (not (eql (fd-stream-ibuf-head fd-stream)
- (fd-stream-ibuf-tail fd-stream)))
- (fd-stream-listen fd-stream)
- (setf (fd-stream-listen fd-stream)
- (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))))
+ (labels ((do-listen ()
+ (or (not (eql (fd-stream-ibuf-head fd-stream)
+ (fd-stream-ibuf-tail fd-stream)))
+ (fd-stream-listen fd-stream)
+ #!+win32
+ (sb!win32:fd-listen (fd-stream-fd fd-stream))
+ #!-win32
+ ;; If the read can block, LISTEN will certainly return NIL.
+ (if (sysread-may-block-p fd-stream)
+ nil
+ ;; Otherwise select(2) and CL:LISTEN have slightly
+ ;; different semantics. The former returns that an FD
+ ;; is readable when a read operation wouldn't block.
+ ;; That includes EOF. However, LISTEN must return NIL
+ ;; at EOF.
+ (progn (catch 'eof-input-catcher
+ ;; r-b/f too calls select, but it shouldn't
+ ;; block as long as read can return once w/o
+ ;; blocking
+ (refill-buffer/fd fd-stream))
+ ;; At this point either IBUF-HEAD != IBUF-TAIL
+ ;; and FD-STREAM-LISTEN is NIL, in which case
+ ;; we should return T, or IBUF-HEAD ==
+ ;; IBUF-TAIL and FD-STREAM-LISTEN is :EOF, in
+ ;; which case we should return :EOF for this
+ ;; call and all future LISTEN call on this stream.
+ ;; Call ourselves again to determine which case
+ ;; applies.
+ (do-listen))))))
+ (do-listen)))
(:unread
(setf (fd-stream-unread fd-stream) arg1)
(setf (fd-stream-listen fd-stream) t))
(:close
- (cond (arg1 ; We got us an abort on our hands.
+ (cond (arg1 ; We got us an abort on our hands.
(when (fd-stream-handler fd-stream)
(sb!sys:remove-fd-handler (fd-stream-handler fd-stream))
(setf (fd-stream-handler fd-stream) nil))
(setf (fd-stream-unread fd-stream) nil)
(setf (fd-stream-ibuf-head fd-stream) 0)
(setf (fd-stream-ibuf-tail fd-stream) 0)
+ #!+win32
+ (progn
+ (sb!win32:fd-clear-input (fd-stream-fd fd-stream))
+ (setf (fd-stream-listen fd-stream) nil))
+ #!-win32
(catch 'eof-input-catcher
- (loop
- (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)
- (setf (fd-stream-ibuf-tail fd-stream) 0))
- (t
- (return t)))))))
+ (loop until (sysread-may-block-p fd-stream)
+ do
+ (refill-buffer/fd fd-stream)
+ (setf (fd-stream-ibuf-head fd-stream) 0)
+ (setf (fd-stream-ibuf-tail fd-stream) 0))
+ t))
(:force-output
(flush-output-buffer fd-stream))
(:finish-output
:format-control "~S is not a stream associated with a file."
:format-arguments (list fd-stream)))
(multiple-value-bind (okay dev ino mode nlink uid gid rdev size
- atime mtime ctime blksize blocks)
+ atime mtime ctime blksize blocks)
(sb!unix:unix-fstat (fd-stream-fd fd-stream))
(declare (ignore ino nlink uid gid rdev
atime mtime ctime blksize blocks))
(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))))
+ (character (fd-stream-character-size fd-stream arg1))
+ (string (fd-stream-string-size fd-stream arg1))))
(:file-position
(fd-stream-file-position fd-stream arg1))))
;;; 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-base-string name))
- (concatenate 'simple-base-string name ".bak"))
+ (declare (type simple-string name))
+ (concatenate 'simple-string name ".bak"))
;;; Ensure that the given arg is one of the given list of valid
;;; things. Allow the user to fix any problems.
(setf *available-buffers* nil)
(with-output-to-string (*error-output*)
(setf *stdin*
- (make-fd-stream 0 :name "standard input" :input t :buffering :line))
+ (make-fd-stream 0 :name "standard input" :input t :buffering :line
+ #!+win32 :external-format #!+win32 (sb!win32::console-input-codepage)))
(setf *stdout*
- (make-fd-stream 1 :name "standard output" :output t :buffering :line))
+ (make-fd-stream 1 :name "standard output" :output t :buffering :line
+ #!+win32 :external-format #!+win32 (sb!win32::console-output-codepage)))
(setf *stderr*
- (make-fd-stream 2 :name "standard error" :output t :buffering :line))
+ (make-fd-stream 2 :name "standard error" :output t :buffering :line
+ #!+win32 :external-format #!+win32 (sb!win32::console-output-codepage)))
(let* ((ttyname #.(coerce "/dev/tty" 'simple-base-string))
(tty (sb!unix:unix-open ttyname sb!unix:o_rdwr #o666)))
(if tty