+ (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-unibyte-mapping-external-format
+ (canonical-name (&rest other-names) &body exceptions)
+ (let ((->code-name (symbolicate canonical-name '->code-mapper))
+ (code->-name (symbolicate 'code-> canonical-name '-mapper))
+ (get-bytes-name (symbolicate 'get- canonical-name '-bytes))
+ (string->-name (symbolicate 'string-> canonical-name))
+ (define-string*-name (symbolicate 'define- canonical-name '->string*))
+ (string*-name (symbolicate canonical-name '->string*))
+ (define-string-name (symbolicate 'define- canonical-name '->string))
+ (string-name (symbolicate canonical-name '->string))
+ (->string-aref-name (symbolicate canonical-name '->string-aref)))
+ `(progn
+ (define-unibyte-mapper ,->code-name ,code->-name
+ ,@exceptions)
+ (declaim (inline ,get-bytes-name))
+ (defun ,get-bytes-name (string pos)
+ (declare (optimize speed (safety 0))
+ (type simple-string string)
+ (type array-range pos))
+ (get-latin-bytes #',code->-name ,canonical-name string pos))
+ (defun ,string->-name (string sstart send null-padding)
+ (declare (optimize speed (safety 0))
+ (type simple-string string)
+ (type array-range sstart send))
+ (values (string->latin% string sstart send #',get-bytes-name null-padding)))
+ (defmacro ,define-string*-name (accessor type)
+ (declare (ignore type))
+ (let ((name (make-od-name ',string*-name accessor)))
+ `(progn
+ (defun ,name (string sstart send array astart aend)
+ (,(make-od-name 'latin->string* accessor)
+ string sstart send array astart aend #',',->code-name)))))
+ (instantiate-octets-definition ,define-string*-name)
+ (defmacro ,define-string-name (accessor type)
+ (declare (ignore type))
+ (let ((name (make-od-name ',string-name accessor)))
+ `(progn
+ (defun ,name (array astart aend)
+ (,(make-od-name 'latin->string accessor)
+ array astart aend #',',->code-name)))))
+ (instantiate-octets-definition ,define-string-name)
+ (define-unibyte-external-format ,canonical-name ,other-names
+ (let ((octet (,code->-name bits)))
+ (if octet
+ (setf (sap-ref-8 sap tail) octet)
+ (external-format-encoding-error stream bits)))
+ (let ((code (,->code-name byte)))
+ (if code
+ (code-char code)
+ (return-from decode-break-reason 1)))
+ ,->string-aref-name
+ ,string->-name))))
+
+(defmacro define-unibyte-external-format
+ (canonical-name (&rest other-names)
+ out-form in-form octets-to-string-symbol string-to-octets-symbol)
+ `(define-external-format/variable-width (,canonical-name ,@other-names)
+ t #\? 1
+ ,out-form
+ 1
+ ,in-form
+ ,octets-to-string-symbol
+ ,string-to-octets-symbol))
+
+(defmacro define-external-format/variable-width
+ (external-format output-restart replacement-character
+ 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-error string start end))
+ (do ()
+ ((= end start))
+ (let ((obuf (fd-stream-obuf stream)))
+ (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)))
+ (,@(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)
+ (setf (buffer-tail obuf) tail)
+ (incf start)))
+ (go flush))
+ ;; Exited via CATCH: skip the current character.
+ (incf start))))
+ flush
+ (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))
+ (when (fd-stream-eof-forced-p stream)
+ (setf (fd-stream-eof-forced-p stream) nil)
+ (return-from ,in-function 0))
+ (do ((instead (fd-stream-instead stream)))
+ ((= (fill-pointer instead) 0)
+ (setf (fd-stream-listen stream) nil))
+ (setf (aref buffer (+ start total-copied)) (vector-pop instead))
+ (incf total-copied)
+ (when (= requested total-copied)
+ (when (= (fill-pointer instead) 0)
+ (setf (fd-stream-listen stream) nil))
+ (return-from ,in-function 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
+ ,@(when (consp in-size-expr)
+ `((when (> ,(car in-size-expr) (- tail head))
+ (return))))
+ (let ((byte (sap-ref-8 sap head)))
+ (declare (ignorable byte))
+ (setq size ,(if (consp in-size-expr) (cadr in-size-expr) 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)))
+ ;; we might have been given stuff to use instead, so
+ ;; we have to return (and trust our caller to know
+ ;; what to do about TOTAL-COPIED being 0).
+ (return-from ,in-function total-copied)))
+ (setf (buffer-head ibuf) head)
+ ;; Maybe we need to refill the stream buffer.
+ (cond ( ;; If was data in the stream buffer, we're done.
+ (plusp total-copied)
+ (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))
+ size)
+ (catch 'eof-input-catcher
+ (loop
+ (incf (buffer-head ibuf))
+ (input-at-least stream ,(if (consp in-size-expr) (car in-size-expr) `(setq size ,in-size-expr)))
+ (unless (block decode-break-reason
+ (let* ((sap (buffer-sap ibuf))
+ (head (buffer-head ibuf))
+ (byte (sap-ref-8 sap head)))
+ (declare (ignorable byte))
+ ,@(when (consp in-size-expr)
+ `((setq size ,(cadr in-size-expr))
+ (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 ,(if (consp in-size-expr)
+ (cadr in-size-expr)
+ in-size-expr)
+ char ,in-expr)
+ (incf head size)
+ nil))
+ (when decode-break-reason
+ (c-string-decoding-error
+ ,name sap head 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 ,(if (consp in-size-expr)
+ (cadr in-size-expr)
+ in-size-expr)
+ char ,in-expr)
+ (incf head size)
+ nil))
+ (when decode-break-reason
+ (c-string-decoding-error
+ ,name sap head 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
+ :default-replacement-character ,replacement-character
+ :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-fun (lambda (&rest rest)
+ (declare (dynamic-extent rest))
+ (apply ',octets-to-string-sym rest))
+ :string-to-octets-fun (lambda (&rest rest)
+ (declare (dynamic-extent rest))
+ (apply ',string-to-octets-sym rest)))))
+ (dolist (ef ',external-format)
+ (setf (gethash ef *external-formats*) entry))))))