+ (eql total-copied requested)
+ (return total-copied))
+ (;; If EOF, we're done in another way.
+ (null (catch 'eof-input-catcher (refill-input-buffer stream)))
+ (if eof-error-p
+ (error 'end-of-file :stream stream)
+ (return total-copied)))
+ ;; Otherwise we refilled the stream buffer, so fall
+ ;; through into another pass of the loop.
+ ))))
+
+(defun fd-stream-resync (stream)
+ (let ((entry (get-external-format (fd-stream-external-format stream))))
+ (when entry
+ (funcall (ef-resync-fun entry) stream))))
+
+(defun get-fd-stream-character-sizer (stream)
+ (let ((entry (get-external-format (fd-stream-external-format stream))))
+ (when entry
+ (ef-bytes-for-char-fun 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
+ (get-external-format external-format)))
+
+(defun variable-width-external-format-p (ef-entry)
+ (and ef-entry (not (null (ef-resync-fun ef-entry)))))
+
+(defun bytes-for-char-fun (ef-entry)
+ (if ef-entry (ef-bytes-for-char-fun ef-entry) (constantly 1)))
+
+(defmacro define-external-format (external-format size output-restart
+ out-expr in-expr
+ octets-to-string-sym
+ string-to-octets-sym)
+ (let* ((name (first external-format))
+ (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))
+ (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))
+ (n-buffer (gensym "BUFFER")))
+ `(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))))
+ (declare (type index start end))
+ (synchronize-stream-output stream)
+ (unless (<= 0 start end (length string))
+ (sequence-bounding-indices-bad-error string start end))
+ (do ()
+ ((= end start))
+ (let ((obuf (fd-stream-obuf stream)))
+ (setf (buffer-tail obuf)
+ (string-dispatch (simple-base-string
+ #!+sb-unicode
+ (simple-array character (*))
+ string)
+ string
+ (let ((sap (buffer-sap obuf))
+ (len (buffer-length obuf))
+ ;; FIXME: rename
+ (tail (buffer-tail obuf)))
+ (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
+ (flush-output-buffer stream))))
+ (def-output-routines (,format
+ ,size
+ ,output-restart
+ (:none character)
+ (:line character)
+ (:full character))
+ (if (eql byte #\Newline)
+ (setf (fd-stream-char-pos stream) 0)
+ (incf (fd-stream-char-pos stream)))
+ (let* ((obuf (fd-stream-obuf stream))
+ (bits (char-code byte))
+ (sap (buffer-sap obuf))
+ (tail (buffer-tail obuf)))
+ ,out-expr))
+ (defun ,in-function (stream buffer start requested eof-error-p
+ &aux (index start) (end (+ start requested)))
+ (declare (type fd-stream stream)
+ (type index start requested index end)
+ (type
+ (simple-array character (#.+ansi-stream-in-buffer-length+))
+ buffer))
+ (let ((unread (fd-stream-unread stream)))
+ (when unread
+ (setf (aref buffer index) unread)
+ (setf (fd-stream-unread stream) nil)
+ (setf (fd-stream-listen stream) nil)
+ (incf index)))
+ (do ()
+ (nil)
+ (let* ((ibuf (fd-stream-ibuf stream))
+ (head (buffer-head ibuf))
+ (tail (buffer-tail ibuf))
+ (sap (buffer-sap ibuf)))
+ (declare (type index head tail)
+ (type system-area-pointer sap))
+ ;; Copy data from stream buffer into user's buffer.
+ (dotimes (i (min (truncate (- tail head) ,size)
+ (- end index)))
+ (declare (optimize speed))
+ (let* ((byte (sap-ref-8 sap head)))
+ (setf (aref buffer index) ,in-expr)
+ (incf index)
+ (incf head ,size)))
+ (setf (buffer-head ibuf) head)
+ ;; Maybe we need to refill the stream buffer.
+ (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-input-buffer stream)))
+ (if eof-error-p
+ (error 'end-of-file :stream stream)
+ (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)))
+ ;; Inline the common cases
+ (string (make-string length :element-type element-type)))
+ (declare (ignorable stream)
+ (type index length)
+ (type simple-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))
+ (,n-buffer (make-array (* (1+ length) ,size)
+ :element-type '(unsigned-byte 8)))
+ (tail 0)
+ (stream ,name))
+ (declare (type index length tail))
+ (with-pinned-objects (,n-buffer)
+ (let ((sap (vector-sap ,n-buffer)))
+ (declare (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)))
+ ,n-buffer)))
+ (let ((entry (%make-external-format
+ :names ',external-format
+ :read-n-chars-fun #',in-function
+ :read-char-fun #',in-char-function
+ :write-n-bytes-fun #',out-function
+ ,@(mapcan #'(lambda (buffering)
+ (list (intern (format nil "WRITE-CHAR-~A-BUFFERED-FUN" buffering) :keyword)
+ `#',(intern (format nil format (string buffering)))))
+ '(:none :line :full))
+ :resync-fun nil
+ :bytes-for-char-fun #',size-function
+ :read-c-string-fun #',read-c-string-function
+ :write-c-string-fun #',output-c-string-function
+ :octets-to-string-sym ',octets-to-string-sym
+ :string-to-octets-sym ',string-to-octets-sym)))
+ (dolist (ef ',external-format)
+ (setf (gethash ef *external-formats*) entry))))))
+
+(defmacro define-external-format/variable-width
+ (external-format output-restart out-size-expr
+ out-expr in-size-expr in-expr
+ octets-to-string-sym string-to-octets-sym)
+ (let* ((name (first external-format))
+ (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))
+ (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))
+ (n-buffer (gensym "BUFFER")))
+ `(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))))
+ (declare (type index start end))
+ (synchronize-stream-output stream)
+ (unless (<= 0 start end (length string))
+ (sequence-bounding-indices-bad string start end))
+ (do ()
+ ((= end start))
+ (let ((obuf (fd-stream-obuf stream)))
+ (setf (buffer-tail obuf)
+ (string-dispatch (simple-base-string
+ #!+sb-unicode
+ (simple-array character (*))
+ string)
+ string
+ (let ((len (buffer-length obuf))
+ (sap (buffer-sap obuf))
+ ;; FIXME: Rename
+ (tail (buffer-tail obuf)))
+ (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
+ (flush-output-buffer stream))))
+ (def-output-routines/variable-width (,format
+ ,out-size-expr
+ ,output-restart
+ ,external-format
+ (:none character)
+ (:line character)
+ (:full character))
+ (if (eql byte #\Newline)
+ (setf (fd-stream-char-pos stream) 0)
+ (incf (fd-stream-char-pos stream)))
+ (let ((bits (char-code byte))
+ (sap (buffer-sap obuf))
+ (tail (buffer-tail obuf)))
+ ,out-expr))
+ (defun ,in-function (stream buffer start requested eof-error-p
+ &aux (total-copied 0))
+ (declare (type fd-stream stream)
+ (type index start requested total-copied)
+ (type
+ (simple-array character (#.+ansi-stream-in-buffer-length+))
+ buffer))
+ (let ((unread (fd-stream-unread stream)))
+ (when unread
+ (setf (aref buffer start) unread)
+ (setf (fd-stream-unread stream) nil)
+ (setf (fd-stream-listen stream) nil)
+ (incf total-copied)))
+ (do ()
+ (nil)
+ (let* ((ibuf (fd-stream-ibuf stream))
+ (head (buffer-head ibuf))
+ (tail (buffer-tail ibuf))
+ (sap (buffer-sap ibuf))
+ (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)))
+ (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))
+ (setf (aref buffer (+ start total-copied)) ,in-expr)
+ (incf total-copied)
+ (incf head size))
+ nil))
+ (setf (buffer-head ibuf) head)
+ (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 (buffer-head ibuf))
+ (setf tail (buffer-tail ibuf))))
+ (setf (buffer-head ibuf) 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.
+ (or (eq decode-break-reason 'eof)
+ (null (catch 'eof-input-catcher
+ (refill-input-buffer stream))))
+ (if eof-error-p
+ (error 'end-of-file :stream stream)
+ (return total-copied)))
+ ;; Otherwise we refilled the stream buffer, so fall
+ ;; through into another pass of the loop.
+ ))))
+ (def-input-routine/variable-width ,in-char-function (character
+ ,external-format
+ ,in-size-expr
+ sap head)
+ (let ((byte (sap-ref-8 sap head)))
+ (declare (ignorable byte))
+ ,in-expr))
+ (defun ,resync-function (stream)
+ (let ((ibuf (fd-stream-ibuf stream)))
+ (loop
+ (input-at-least stream 2)
+ (incf (buffer-head ibuf))
+ (unless (block decode-break-reason
+ (let* ((sap (buffer-sap ibuf))
+ (head (buffer-head ibuf))
+ (byte (sap-ref-8 sap head))
+ (size ,in-size-expr))
+ (declare (ignorable byte))
+ (input-at-least stream size)
+ (setf head (buffer-head ibuf))
+ ,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)
+ (,n-buffer (make-array buffer-length
+ :element-type '(unsigned-byte 8)))
+ stream)
+ (declare (type index length buffer-length tail)
+ (type null stream)
+ (ignorable stream))
+ (with-pinned-objects (,n-buffer)
+ (let ((sap (vector-sap ,n-buffer)))
+ (declare (system-area-pointer sap))
+ (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)))
+ ,n-buffer)))
+
+ (let ((entry (%make-external-format
+ :names ',external-format
+ :read-n-chars-fun #',in-function
+ :read-char-fun #',in-char-function
+ :write-n-bytes-fun #',out-function
+ ,@(mapcan #'(lambda (buffering)
+ (list (intern (format nil "WRITE-CHAR-~A-BUFFERED-FUN" buffering) :keyword)
+ `#',(intern (format nil format (string buffering)))))
+ '(:none :line :full))
+ :resync-fun #',resync-function
+ :bytes-for-char-fun #',size-function
+ :read-c-string-fun #',read-c-string-function
+ :write-c-string-fun #',output-c-string-function
+ :octets-to-string-sym ',octets-to-string-sym
+ :string-to-octets-sym ',string-to-octets-sym)))
+ (dolist (ef ',external-format)
+ (setf (gethash ef *external-formats*) entry))))))