- (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
- ,size-function ,read-c-string-function ,output-c-string-function)
- *external-formats*)))))
-
-;;; 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)
- (external-format-encoding-error stream bits)
- (setf (sap-ref-8 sap tail) bits))
- (code-char byte))
-
-(define-external-format (:ascii :us-ascii :ansi_x3.4-1968
- :iso-646 :iso-646-us :|646|)
- 1 t
- (if (>= bits 128)
- (external-format-encoding-error stream bits)
- (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 :iso8859-15)
- 1 t
- (setf (sap-ref-8 sap tail)
- (if (< bits 256)
- (if (= bits (char-code (aref latin-9-table bits)))
- bits
- (external-format-encoding-error stream byte))
- (if (= (aref latin-9-reverse-1 (logand bits 15)) bits)
- (aref latin-9-reverse-2 (logand bits 15))
- (external-format-encoding-error stream byte))))
- (aref latin-9-table byte)))
-
-(define-external-format/variable-width (:utf-8 :utf8) nil
- (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 #xc2) (return-from decode-break-reason 1))
- ((< byte #xe0) 2)
- ((< byte #xf0) 3)
- (t 4))
- (code-char (ecase size
- (1 byte)
- (2 (let ((byte2 (sap-ref-8 sap (1+ head))))
- (unless (<= #x80 byte2 #xbf)
- (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 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)))
- (byte4 (sap-ref-8 sap (+ 3 head))))
- (unless (and (<= #x80 byte2 #xbf)
- (<= #x80 byte3 #xbf)
- (<= #x80 byte4 #xbf))
- (return-from decode-break-reason 4))
- (dpb byte (byte 3 18)
- (dpb byte2 (byte 6 12)
- (dpb byte3 (byte 6 6) byte4))))))))
+ (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))))))