+ ;; 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) new-head
+ (fd-stream-ibuf-tail stream) (+ count new-head))
+ count)))
+
+(defmacro define-external-format (external-format size 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)))))
+ `(progn
+ (defun ,out-function (fd-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 (< 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)))
+ ((or (= start end) (< (- len tail) 4)) tail)
+ (let* ((byte (aref string start))
+ (bits (char-code byte)))
+ ,out-expr
+ (incf tail ,size)
+ (incf start))))
+ (when (< start end)
+ (flush-output-buffer fd-stream)))
+ (when flush-p
+ (flush-output-buffer fd-stream))))
+ (def-output-routines (,format
+ ,size
+ (:none character)
+ (:line character)
+ (:full character))
+ (if (char= byte #\Newline)
+ (setf (fd-stream-char-pos stream) 0)
+ (incf (fd-stream-char-pos stream)))
+ (let ((bits (char-code byte))
+ (sap (fd-stream-obuf-sap stream))
+ (tail (fd-stream-obuf-tail stream)))
+ ,out-expr))
+ (defun ,in-function (stream buffer start requested eof-error-p
+ &aux (total-copied 0))
+ (declare (type file-stream stream))
+ (declare (type index start requested total-copied))
+ (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* ((head (fd-stream-ibuf-head stream))
+ (tail (fd-stream-ibuf-tail stream))
+ (sap (fd-stream-ibuf-sap stream)))
+ (declare (type index head tail))
+ ;; Copy data from stream buffer into user's buffer.
+ (do ()
+ ((or (= tail head) (= requested total-copied)))
+ (let* ((byte (sap-ref-8 sap head)))
+ (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)
+ ;; 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))
+ (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 ,in-char-function (character ,size sap head)
+ (let ((byte (sap-ref-8 sap head)))
+ ,in-expr))
+ (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))))
+ '(:none :line :full)))
+ *external-formats*)))))
+
+(defmacro define-external-format/variable-width (external-format 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)))))
+ `(progn
+ (defun ,out-function (fd-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 (< 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)))
+ ((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))))
+ (when (< start end)
+ (flush-output-buffer fd-stream)))
+ (when flush-p
+ (flush-output-buffer fd-stream))))
+ (def-output-routines/variable-width (,format
+ ,out-size-expr
+ ,external-format
+ (:none character)
+ (:line character)
+ (:full character))
+ (if (char= byte #\Newline)
+ (setf (fd-stream-char-pos stream) 0)
+ (incf (fd-stream-char-pos stream)))
+ (let ((bits (char-code byte))
+ (sap (fd-stream-obuf-sap stream))
+ (tail (fd-stream-obuf-tail stream)))
+ ,out-expr))
+ (defun ,in-function (stream buffer start requested eof-error-p
+ &aux (total-copied 0))
+ (declare (type file-stream stream))
+ (declare (type index start requested total-copied))
+ (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* ((head (fd-stream-ibuf-head stream))
+ (tail (fd-stream-ibuf-tail stream))
+ (sap (fd-stream-ibuf-sap stream)))
+ (declare (type index head tail))
+ ;; Copy data from stream buffer into user's buffer.
+ (do ()
+ ((or (= tail head) (= requested total-copied)))
+ (let* ((byte (sap-ref-8 sap head))
+ (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)
+ ;; 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))
+ (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)))
+ ,in-expr))
+ (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))))
+ '(:none :line :full)))
+ *external-formats*)))))
+
+(define-external-format (:latin-1 :latin1 :iso-8859-1
+ ;; FIXME: shouldn't ASCII-like things have an
+ ;; extra typecheck for 7-bitness?
+ :ascii :us-ascii :ansi_x3.4-1968)
+ 1
+ (setf (sap-ref-8 sap tail) bits)
+ (code-char byte))
+
+#!+sb-unicode
+(let ((latin-9-table (let ((table (make-string 256)))
+ (do ((i 0 (1+ i)))
+ ((= i 256))
+ (setf (aref table i) (code-char i)))
+ (setf (aref table #xa4) (code-char #x20ac))
+ (setf (aref table #xa6) (code-char #x0160))
+ (setf (aref table #xa8) (code-char #x0161))
+ (setf (aref table #xb4) (code-char #x017d))
+ (setf (aref table #xb8) (code-char #x017e))
+ (setf (aref table #xbc) (code-char #x0152))
+ (setf (aref table #xbd) (code-char #x0153))
+ (setf (aref table #xbe) (code-char #x0178))
+ table))
+ (latin-9-reverse-1 (make-array 16
+ :element-type '(unsigned-byte 21)
+ :initial-contents '(#x0160 #x0161 #x0152 #x0153 0 0 0 0 #x0178 0 0 0 #x20ac #x017d #x017e 0)))
+ (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)
+ 1
+ (setf (sap-ref-8 sap tail)
+ (if (< bits 256)
+ (if (= bits (char-code (aref latin-9-table bits)))
+ bits
+ (error "cannot encode ~A in latin-9" bits))
+ (if (= (aref latin-9-reverse-1 (logand bits 15)) bits)
+ (aref latin-9-reverse-2 (logand bits 15))
+ (error "cannot encode ~A in latin-9" bits))))
+ (aref latin-9-table byte)))
+
+(define-external-format/variable-width (:utf-8 :utf8)
+ (let ((bits (char-code byte)))
+ (cond ((< bits #x80) 1)
+ ((< bits #x800) 2)
+ ((< bits #x10000) 3)
+ (t 4)))
+ (ecase size
+ (1 (setf (sap-ref-8 sap tail) bits))
+ (2 (setf (sap-ref-8 sap tail) (logior #xc0 (ldb (byte 5 6) bits))
+ (sap-ref-8 sap (1+ tail)) (logior #x80 (ldb (byte 6 0) bits))))
+ (3 (setf (sap-ref-8 sap tail) (logior #xe0 (ldb (byte 4 12) bits))
+ (sap-ref-8 sap (1+ tail)) (logior #x80 (ldb (byte 6 6) bits))
+ (sap-ref-8 sap (+ 2 tail)) (logior #x80 (ldb (byte 6 0) bits))))
+ (4 (setf (sap-ref-8 sap tail) (logior #xf0 (ldb (byte 3 18) bits))
+ (sap-ref-8 sap (1+ tail)) (logior #x80 (ldb (byte 6 12) bits))
+ (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 #xe0) 2)
+ ((< byte #xf0) 3)
+ (t 4))
+ (code-char (ecase size
+ (1 byte)
+ (2 (dpb byte (byte 5 6) (sap-ref-8 sap (1+ head))))
+ (3 (dpb byte (byte 4 12)
+ (dpb (sap-ref-8 sap (1+ head)) (byte 6 6)
+ (sap-ref-8 sap (+ 2 head)))))
+ (4 (dpb byte (byte 3 18)
+ (dpb (sap-ref-8 sap (1+ head)) (byte 6 12)
+ (dpb (sap-ref-8 sap (+ 2 head)) (byte 6 6)
+ (sap-ref-8 sap (+ 3 head)))))))))