lisp/international/utf-8.el

   1 ;;; utf-8.el --- UTF-8 decoding/encoding support -*- coding: iso-2022-7bit -*-
   2
   3 ;; Copyright (C) 2001 Electrotechnical Laboratory, JAPAN.
   4 ;; Licensed to the Free Software Foundation.
   5 ;; Copyright (C) 2001, 2002 Free Software Foundation, Inc.
   6
   7 ;; Author: TAKAHASHI Naoto  <ntakahas@m17n.org>
   8 ;; Maintainer: FSF
   9 ;; Keywords: multilingual, Unicode, UTF-8, i18n
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2, or (at your option)
  16 ;; any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26 ;; Boston, MA 02111-1307, USA.
  27
  28 ;;; Commentary:
  29
  30 ;; The coding-system `mule-utf-8' basically supports encoding/decoding
  31 ;; of the following character sets to and from UTF-8:
  32 ;;
  33 ;;   ascii
  34 ;;   eight-bit-control
  35 ;;   latin-iso8859-1
  36 ;;   mule-unicode-0100-24ff
  37 ;;   mule-unicode-2500-33ff
  38 ;;   mule-unicode-e000-ffff
  39 ;;
  40 ;; On decoding, Unicode characters that do not fit into the above
  41 ;; character sets are handled as `eight-bit-control' or
  42 ;; `eight-bit-graphic' characters to retain the information about the
  43 ;; original byte sequence and text properties record the corresponding
  44 ;; unicode.
  45 ;;
  46 ;; Fixme: note that reading and writing invalid utf-8 may not be
  47 ;; idempotent -- to represent the bytes to fix that needs a new charset.
  48 ;;
  49 ;; Characters from other character sets can be encoded with mule-utf-8
  50 ;; by populating the translation table
  51 ;; `utf-translation-table-for-encode'.  Hash tables
  52 ;; `utf-subst-table-for-decode' and `utf-subst-table-for-encode' are
  53 ;; used to support encoding and decoding of about a quarter of the CJK
  54 ;; space between U+3400 and U+DFFF.
  55
  56 ;; UTF-8 is defined in RFC 3629.  A sketch of the encoding is:
  57
  58 ;;        scalar       |               utf-8
  59 ;;        value        | 1st byte  | 2nd byte  | 3rd byte
  60 ;; --------------------+-----------+-----------+----------
  61 ;; 0000 0000 0xxx xxxx | 0xxx xxxx |           |
  62 ;; 0000 0yyy yyxx xxxx | 110y yyyy | 10xx xxxx |
  63 ;; zzzz yyyy yyxx xxxx | 1110 zzzz | 10yy yyyy | 10xx xxxx
  64
  65 ;;; Code:
  66
  67 (defvar ucs-mule-to-mule-unicode (make-char-table 'translation-table nil)
  68   "Char table mapping characters to latin-iso8859-1 or mule-unicode-*.
  69
  70 If `unify-8859-on-encoding-mode' is non-nil, this table populates the
  71 translation-table named `utf-translation-table-for-encode'.")
  72
  73 (define-translation-table 'utf-translation-table-for-encode)
  74
  75
  76 ;; Map Cyrillic and Greek to iso-8859 charsets, which take half the
  77 ;; space of mule-unicode.  For Latin scripts this isn't very
  78 ;; important.  Hebrew and Arabic might go here too when there's proper
  79 ;; support for them.
  80
  81 (defvar utf-fragmentation-table (make-char-table 'translation-table nil)
  82   "Char-table normally mapping non-Latin mule-unicode-* chars to iso-8859-*.
  83
  84 If `utf-fragment-on-decoding' is non-nil, this table populates the
  85 translation-table named `utf-translation-table-for-decode'")
  86
  87 (defvar utf-defragmentation-table (make-char-table 'translation-table nil)
  88   "Char-table for reverse mapping of `utf-fragmentation-table'.
  89
  90 If `utf-fragment-on-decoding' is non-nil and
  91 `unify-8859-on-encoding-mode' is nil, this table populates the
  92 translation-table named `utf-translation-table-for-encode'")
  93
  94 (define-translation-table 'utf-translation-table-for-decode)
  95
  96
  97 (defvar ucs-mule-cjk-to-unicode (make-hash-table :test 'eq)
  98   "Hash table mapping Emacs CJK character sets to Unicode code points.
  99
 100 If `utf-translate-cjk' is non-nil, this table populates the
 101 translation-hash-table named `utf-subst-table-for-encode'.")
 102
 103 (define-translation-hash-table 'utf-subst-table-for-encode
 104   ucs-mule-cjk-to-unicode)
 105
 106 (defvar ucs-unicode-to-mule-cjk (make-hash-table :test 'eq)
 107   "Hash table mapping Unicode code points to Emacs CJK character sets.
 108
 109 If `utf-translate-cjk' is non-nil, this table populates the
 110 translation-hash-table named `utf-subst-table-for-decode'.")
 111
 112 (define-translation-hash-table 'utf-subst-table-for-decode
 113   ucs-unicode-to-mule-cjk)
 114
 115 (mapc
 116  (lambda (pair)
 117    (aset utf-fragmentation-table (car pair) (cdr pair))
 118    (aset utf-defragmentation-table (cdr pair) (car pair)))
 119  '((?\e$,1&d\e(B . ?\e,F4\e(B) (?\e$,1&e\e(B . ?\e,F5\e(B) (?\e$,1&f\e(B . ?\e,F6\e(B) (?\e$,1&h\e(B . ?\e,F8\e(B) (?\e$,1&i\e(B . ?\e,F9\e(B)
 120    (?\e$,1&j\e(B . ?\e,F:\e(B) (?\e$,1&l\e(B . ?\e,F<\e(B) (?\e$,1&n\e(B . ?\e,F>\e(B) (?\e$,1&o\e(B . ?\e,F?\e(B) (?\e$,1&p\e(B . ?\e,F@\e(B)
 121    (?\e$,1&q\e(B . ?\e,FA\e(B) (?\e$,1&r\e(B . ?\e,FB\e(B) (?\e$,1&s\e(B . ?\e,FC\e(B) (?\e$,1&t\e(B . ?\e,FD\e(B) (?\e$,1&u\e(B . ?\e,FE\e(B)
 122    (?\e$,1&v\e(B . ?\e,FF\e(B) (?\e$,1&w\e(B . ?\e,FG\e(B) (?\e$,1&x\e(B . ?\e,FH\e(B) (?\e$,1&y\e(B . ?\e,FI\e(B) (?\e$,1&z\e(B . ?\e,FJ\e(B)
 123    (?\e$,1&{\e(B . ?\e,FK\e(B) (?\e$,1&|\e(B . ?\e,FL\e(B) (?\e$,1&}\e(B . ?\e,FM\e(B) (?\e$,1&~\e(B . ?\e,FN\e(B) (?\e$,1&\7f\e(B . ?\e,FO\e(B)
 124    (?\e$,1' \e(B . ?\e,FP\e(B) (?\e$,1'!\e(B . ?\e,FQ\e(B) (?\e$,1'#\e(B . ?\e,FS\e(B) (?\e$,1'$\e(B . ?\e,FT\e(B) (?\e$,1'%\e(B . ?\e,FU\e(B)
 125    (?\e$,1'&\e(B . ?\e,FV\e(B) (?\e$,1''\e(B . ?\e,FW\e(B) (?\e$,1'(\e(B . ?\e,FX\e(B) (?\e$,1')\e(B . ?\e,FY\e(B) (?\e$,1'*\e(B . ?\e,FZ\e(B)
 126    (?\e$,1'+\e(B . ?\e,F[\e(B) (?\e$,1',\e(B . ?\e,F\\e(B) (?\e$,1'-\e(B . ?\e,F]\e(B) (?\e$,1'.\e(B . ?\e,F^\e(B) (?\e$,1'/\e(B . ?\e,F_\e(B)
 127    (?\e$,1'0\e(B . ?\e,F`\e(B) (?\e$,1'1\e(B . ?\e,Fa\e(B) (?\e$,1'2\e(B . ?\e,Fb\e(B) (?\e$,1'3\e(B . ?\e,Fc\e(B) (?\e$,1'4\e(B . ?\e,Fd\e(B)
 128    (?\e$,1'5\e(B . ?\e,Fe\e(B) (?\e$,1'6\e(B . ?\e,Ff\e(B) (?\e$,1'7\e(B . ?\e,Fg\e(B) (?\e$,1'8\e(B . ?\e,Fh\e(B) (?\e$,1'9\e(B . ?\e,Fi\e(B)
 129    (?\e$,1':\e(B . ?\e,Fj\e(B) (?\e$,1';\e(B . ?\e,Fk\e(B) (?\e$,1'<\e(B . ?\e,Fl\e(B) (?\e$,1'=\e(B . ?\e,Fm\e(B) (?\e$,1'>\e(B . ?\e,Fn\e(B)
 130    (?\e$,1'?\e(B . ?\e,Fo\e(B) (?\e$,1'@\e(B . ?\e,Fp\e(B) (?\e$,1'A\e(B . ?\e,Fq\e(B) (?\e$,1'B\e(B . ?\e,Fr\e(B) (?\e$,1'C\e(B . ?\e,Fs\e(B)
 131    (?\e$,1'D\e(B . ?\e,Ft\e(B) (?\e$,1'E\e(B . ?\e,Fu\e(B) (?\e$,1'F\e(B . ?\e,Fv\e(B) (?\e$,1'G\e(B . ?\e,Fw\e(B) (?\e$,1'H\e(B . ?\e,Fx\e(B)
 132    (?\e$,1'I\e(B . ?\e,Fy\e(B) (?\e$,1'J\e(B . ?\e,Fz\e(B) (?\e$,1'K\e(B . ?\e,F{\e(B) (?\e$,1'L\e(B . ?\e,F|\e(B) (?\e$,1'M\e(B . ?\e,F}\e(B)
 133    (?\e$,1'N\e(B . ?\e,F~\e(B)
 134
 135    (?\e$,1(!\e(B . ?\e,L!\e(B) (?\e$,1("\e(B . ?\e,L"\e(B) (?\e$,1(#\e(B . ?\e,L#\e(B) (?\e$,1($\e(B . ?\e,L$\e(B)
 136    (?\e$,1(%\e(B . ?\e,L%\e(B) (?\e$,1(&\e(B . ?\e,L&\e(B) (?\e$,1('\e(B . ?\e,L'\e(B) (?\e$,1((\e(B . ?\e,L(\e(B) (?\e$,1()\e(B . ?\e,L)\e(B)
 137    (?\e$,1(*\e(B . ?\e,L*\e(B) (?\e$,1(+\e(B . ?\e,L+\e(B) (?\e$,1(,\e(B . ?\e,L,\e(B) (?\e$,1(.\e(B . ?\e,L.\e(B) (?\e$,1(/\e(B . ?\e,L/\e(B)
 138    (?\e$,1(0\e(B . ?\e,L0\e(B) (?\e$,1(1\e(B . ?\e,L1\e(B) (?\e$,1(2\e(B . ?\e,L2\e(B) (?\e$,1(3\e(B . ?\e,L3\e(B) (?\e$,1(4\e(B . ?\e,L4\e(B)
 139    (?\e$,1(5\e(B . ?\e,L5\e(B) (?\e$,1(6\e(B . ?\e,L6\e(B) (?\e$,1(7\e(B . ?\e,L7\e(B) (?\e$,1(8\e(B . ?\e,L8\e(B) (?\e$,1(9\e(B . ?\e,L9\e(B)
 140    (?\e$,1(:\e(B . ?\e,L:\e(B) (?\e$,1(;\e(B . ?\e,L;\e(B) (?\e$,1(<\e(B . ?\e,L<\e(B) (?\e$,1(=\e(B . ?\e,L=\e(B) (?\e$,1(>\e(B . ?\e,L>\e(B)
 141    (?\e$,1(?\e(B . ?\e,L?\e(B) (?\e$,1(@\e(B . ?\e,L@\e(B) (?\e$,1(A\e(B . ?\e,LA\e(B) (?\e$,1(B\e(B . ?\e,LB\e(B) (?\e$,1(C\e(B . ?\e,LC\e(B)
 142    (?\e$,1(D\e(B . ?\e,LD\e(B) (?\e$,1(E\e(B . ?\e,LE\e(B) (?\e$,1(F\e(B . ?\e,LF\e(B) (?\e$,1(G\e(B . ?\e,LG\e(B) (?\e$,1(H\e(B . ?\e,LH\e(B)
 143    (?\e$,1(I\e(B . ?\e,LI\e(B) (?\e$,1(J\e(B . ?\e,LJ\e(B) (?\e$,1(K\e(B . ?\e,LK\e(B) (?\e$,1(L\e(B . ?\e,LL\e(B) (?\e$,1(M\e(B . ?\e,LM\e(B)
 144    (?\e$,1(N\e(B . ?\e,LN\e(B) (?\e$,1(O\e(B . ?\e,LO\e(B) (?\e$,1(P\e(B . ?\e,LP\e(B) (?\e$,1(Q\e(B . ?\e,LQ\e(B) (?\e$,1(R\e(B . ?\e,LR\e(B)
 145    (?\e$,1(S\e(B . ?\e,LS\e(B) (?\e$,1(T\e(B . ?\e,LT\e(B) (?\e$,1(U\e(B . ?\e,LU\e(B) (?\e$,1(V\e(B . ?\e,LV\e(B) (?\e$,1(W\e(B . ?\e,LW\e(B)
 146    (?\e$,1(X\e(B . ?\e,LX\e(B) (?\e$,1(Y\e(B . ?\e,LY\e(B) (?\e$,1(Z\e(B . ?\e,LZ\e(B) (?\e$,1([\e(B . ?\e,L[\e(B) (?\e$,1(\\e(B . ?\e,L\\e(B)
 147    (?\e$,1(]\e(B . ?\e,L]\e(B) (?\e$,1(^\e(B . ?\e,L^\e(B) (?\e$,1(_\e(B . ?\e,L_\e(B) (?\e$,1(`\e(B . ?\e,L`\e(B) (?\e$,1(a\e(B . ?\e,La\e(B)
 148    (?\e$,1(b\e(B . ?\e,Lb\e(B) (?\e$,1(c\e(B . ?\e,Lc\e(B) (?\e$,1(d\e(B . ?\e,Ld\e(B) (?\e$,1(e\e(B . ?\e,Le\e(B) (?\e$,1(f\e(B . ?\e,Lf\e(B)
 149    (?\e$,1(g\e(B . ?\e,Lg\e(B) (?\e$,1(h\e(B . ?\e,Lh\e(B) (?\e$,1(i\e(B . ?\e,Li\e(B) (?\e$,1(j\e(B . ?\e,Lj\e(B) (?\e$,1(k\e(B . ?\e,Lk\e(B)
 150    (?\e$,1(l\e(B . ?\e,Ll\e(B) (?\e$,1(m\e(B . ?\e,Lm\e(B) (?\e$,1(n\e(B . ?\e,Ln\e(B) (?\e$,1(o\e(B . ?\e,Lo\e(B) (?\e$,1(q\e(B . ?\e,Lq\e(B)
 151    (?\e$,1(r\e(B . ?\e,Lr\e(B) (?\e$,1(s\e(B . ?\e,Ls\e(B) (?\e$,1(t\e(B . ?\e,Lt\e(B) (?\e$,1(u\e(B . ?\e,Lu\e(B) (?\e$,1(v\e(B . ?\e,Lv\e(B)
 152    (?\e$,1(w\e(B . ?\e,Lw\e(B) (?\e$,1(x\e(B . ?\e,Lx\e(B) (?\e$,1(y\e(B . ?\e,Ly\e(B) (?\e$,1(z\e(B . ?\e,Lz\e(B) (?\e$,1({\e(B . ?\e,L{\e(B)
 153    (?\e$,1(|\e(B . ?\e,L|\e(B) (?\e$,1(~\e(B . ?\e,L~\e(B) (?\e$,1(\7f\e(B . ?\e,L\7f\e(B)))
 154
 155
 156 (defcustom utf-fragment-on-decoding nil
 157   "Whether or not to decode some chars in UTF-8/16 text into iso8859 charsets.
 158 Setting this means that the relevant Cyrillic and Greek characters are
 159 decoded into the iso8859 charsets rather than into
 160 mule-unicode-0100-24ff.  The iso8859 charsets take half as much space
 161 in the buffer, but using them may affect how the buffer can be re-encoded
 162 and may require a different input method to search for them, for instance.
 163 See `unify-8859-on-decoding-mode' and `unify-8859-on-encoding-mode'
 164 for mechanisms to make this largely transparent.
 165
 166 Setting this variable outside customize has no effect."
 167   :set (lambda (s v)
 168          (if v
 169              (progn
 170                (define-translation-table 'utf-translation-table-for-decode
 171                  utf-fragmentation-table)
 172                ;; Even if unify-8859-on-encoding-mode is off, make
 173                ;; mule-utf-* encode characters in
 174                ;; utf-fragmentation-table.
 175                (unless (eq (get 'utf-translation-table-for-encode
 176                                 'translation-table)
 177                            ucs-mule-to-mule-unicode)
 178                  (define-translation-table 'utf-translation-table-for-encode
 179                    utf-defragmentation-table)))
 180            (define-translation-table 'utf-translation-table-for-decode)
 181            ;; When unify-8859-on-encoding-mode is off, be sure to make
 182            ;; mule-utf-* disabled for characters in
 183            ;; utf-fragmentation-table.
 184            (unless (eq (get 'utf-translation-table-for-encode
 185                             'translation-table)
 186                        ucs-mule-to-mule-unicode)
 187              (define-translation-table 'utf-translation-table-for-encode)))
 188          (set-default s v))
 189   :version "21.4"
 190   :type 'boolean
 191   :group 'mule)
 192
 193 (define-minor-mode utf-translate-cjk-mode
 194   "Whether the UTF based coding systems should decode/encode CJK characters.
 195 Enabling this loads tables which allow the coding systems mule-utf-8,
 196 mule-utf-16le and mule-utf-16be to encode characters in the charsets
 197 `korean-ksc5601', `chinese-gb2312', `chinese-big5-1',
 198 `chinese-big5-2', `japanese-jisx0208' and `japanese-jisx0212', and to
 199 decode the corresponding unicodes into such characters.
 200
 201 Where the charsets overlap, the one preferred for decoding is chosen
 202 according to the language environment in effect when this option is
 203 turned on: ksc5601 for Korean, gb2312 for Chinese-GB, big5 for
 204 Chinese-Big5 and jisx for other environments.
 205
 206 The tables are large (over 40000 entries), so this option is not the
 207 default.  Also, installing them may be rather slow."
 208   :init-value nil
 209   :version "21.4"
 210   :type 'boolean
 211   :set-after '(current-language-environment)
 212   :group 'mule
 213   :global t
 214   (if utf-translate-cjk-mode
 215       ;; Fixme: Allow the use of the CJK charsets to be
 216       ;; customized by reordering and possible omission.
 217       (progn
 218         ;; Redefine them with realistic initial sizes and a
 219         ;; smallish rehash size to avoid wasting significant
 220         ;; space after they're built.
 221         (setq ucs-mule-cjk-to-unicode
 222               (make-hash-table :test 'eq :size 43000 :rehash-size 1000)
 223               ucs-unicode-to-mule-cjk
 224               (make-hash-table :test 'eq :size 21500 :rehash-size 1000))
 225         ;; Load the files explicitly, to avoid having to keep
 226         ;; around the large tables they contain (as well as the
 227         ;; ones which get built).
 228         (cond
 229          ((string= "Korean" current-language-environment)
 230           (load "subst-jis")
 231           (load "subst-big5")
 232           (load "subst-gb2312")
 233           (load "subst-ksc"))
 234          ((string= "Chinese-BIG5" current-language-environment)
 235           (load "subst-jis")
 236           (load "subst-ksc")
 237           (load "subst-gb2312")
 238           (load "subst-big5"))
 239          ((string= "Chinese-GB" current-language-environment)
 240           (load "subst-jis")
 241           (load "subst-ksc")
 242           (load "subst-big5")
 243           (load "subst-gb2312"))
 244          (t
 245           (load "subst-ksc")
 246           (load "subst-gb2312")
 247           (load "subst-big5")
 248           (load "subst-jis")))    ; jis covers as much as big5, gb2312
 249         (define-translation-hash-table 'utf-subst-table-for-decode
 250           ucs-unicode-to-mule-cjk)
 251         (define-translation-hash-table 'utf-subst-table-for-encode
 252           ucs-mule-cjk-to-unicode)
 253         (set-char-table-extra-slot (get 'utf-translation-table-for-encode
 254                                         'translation-table)
 255                                    1 ucs-mule-cjk-to-unicode))
 256     (define-translation-hash-table 'utf-subst-table-for-decode
 257       (make-hash-table :test 'eq))
 258     (define-translation-hash-table 'utf-subst-table-for-encode
 259       (make-hash-table :test 'eq))
 260     (set-char-table-extra-slot (get 'utf-translation-table-for-encode
 261                                     'translation-table)
 262                                1 nil)))
 263
 264 (define-ccl-program ccl-decode-mule-utf-8
 265   ;;
 266   ;;        charset         | bytes in utf-8 | bytes in emacs
 267   ;; -----------------------+----------------+---------------
 268   ;;         ascii          |       1        |       1
 269   ;; -----------------------+----------------+---------------
 270   ;;    eight-bit-control   |       2        |       2
 271   ;;    eight-bit-graphic   |       2        |       1
 272   ;;     latin-iso8859-1    |       2        |       2
 273   ;; -----------------------+----------------+---------------
 274   ;; mule-unicode-0100-24ff |       2        |       4
 275   ;;        (< 0800)        |                |
 276   ;; -----------------------+----------------+---------------
 277   ;; mule-unicode-0100-24ff |       3        |       4
 278   ;;        (>= 8000)       |                |
 279   ;; mule-unicode-2500-33ff |       3        |       4
 280   ;; mule-unicode-e000-ffff |       3        |       4
 281   ;;
 282   ;; Thus magnification factor is two.
 283   ;;
 284   `(2
 285     ((r5 = ,(charset-id 'eight-bit-control))
 286      (r6 = ,(charset-id 'eight-bit-graphic))
 287      (loop
 288       (r0 = -1)
 289       (read r0)
 290
 291       ;; 1byte encoding, i.e., ascii
 292       (if (r0 < #x80)
 293           ((write r0))
 294         (if (r0 < #xc0)             ; continuation byte (invalid here)
 295             ((if (r0 < #xa0)
 296                  (write-multibyte-character r5 r0)
 297                (write-multibyte-character r6 r0)))
 298           ;; 2 byte encoding 00000yyyyyxxxxxx = 110yyyyy 10xxxxxx
 299           (if (r0 < #xe0)
 300               ((r1 = -1)
 301                (read r1)
 302
 303                (if ((r1 & #b11000000) != #b10000000)
 304                    ;; Invalid 2-byte sequence
 305                    ((if (r0 < #xa0)
 306                         (write-multibyte-character r5 r0)
 307                       (write-multibyte-character r6 r0))
 308                     (if (r1 < #x80)
 309                         (write r1)
 310                       (if (r1 < #xa0)
 311                           (write-multibyte-character r5 r1)
 312                         (write-multibyte-character r6 r1))))
 313
 314                  ((r3 = r0)        ; save in case of overlong sequence
 315                   (r2 = r1)
 316                   (r0 &= #x1f)
 317                   (r0 <<= 6)
 318                   (r1 &= #x3f)
 319                   (r1 += r0)
 320                   ;; Now r1 holds scalar value
 321
 322                   (if (r1 < 128)        ; `overlong sequence'
 323                       ((if (r3 < #xa0)
 324                            (write-multibyte-character r5 r3)
 325                          (write-multibyte-character r6 r3))
 326                        (if (r2 < #x80)
 327                            (write r2)
 328                          (if (r2 < #xa0)
 329                              (write-multibyte-character r5 r2)
 330                            (write-multibyte-character r6 r2))))
 331
 332                     ;; eight-bit-control
 333                     (if (r1 < 160)
 334                         ((write-multibyte-character r5 r1))
 335
 336                       ;; latin-iso8859-1
 337                       (if (r1 < 256)
 338                           ((r0 = ,(charset-id 'latin-iso8859-1))
 339                            (r1 -= 128)
 340                            (write-multibyte-character r0 r1))
 341
 342                         ;; mule-unicode-0100-24ff (< 0800)
 343                         ((r0 = ,(charset-id 'mule-unicode-0100-24ff))
 344                          (r1 -= #x0100)
 345                          (r2 = (((r1 / 96) + 32) << 7))
 346                          (r1 %= 96)
 347                          (r1 += (r2 + 32))
 348                          (translate-character
 349                           utf-translation-table-for-decode r0 r1)
 350                          (write-multibyte-character r0 r1))))))))
 351
 352             ;; 3byte encoding
 353             ;; zzzzyyyyyyxxxxxx = 1110zzzz 10yyyyyy 10xxxxxx
 354             (if (r0 < #xf0)
 355                 ((r1 = -1)
 356                  (r2 = -1)
 357                  (read r1 r2)
 358
 359                  ;; This is set to 1 if the encoding is invalid.
 360                  (r4 = 0)
 361
 362                  (r3 = (r1 & #b11000000))
 363                  (r3 |= ((r2 >> 2) & #b00110000))
 364                  (if (r3 != #b10100000)
 365                      (r4 = 1)
 366                    ((r3 = ((r0 & #x0f) << 12))
 367                     (r3 += ((r1 & #x3f) << 6))
 368                     (r3 += (r2 & #x3f))
 369                     (if (r3 < #x0800)
 370                         (r4 = 1))))
 371
 372                  (if (r4 != 0)
 373                      ;; Invalid 3-byte sequence
 374                      ((if (r0 < #xa0)
 375                           (write-multibyte-character r5 r0)
 376                         (write-multibyte-character r6 r0))
 377                       (if (r1 < #x80)
 378                           (write r1)
 379                         (if (r1 < #xa0)
 380                             (write-multibyte-character r5 r1)
 381                           (write-multibyte-character r6 r1)))
 382                       (if (r2 < #x80)
 383                           (write r2)
 384                         (if (r2 < #xa0)
 385                             (write-multibyte-character r5 r2)
 386                           (write-multibyte-character r6 r2))))
 387
 388                    ;; mule-unicode-0100-24ff (>= 0800)
 389                    ((if (r3 < #x2500)
 390                         ((r0 = ,(charset-id 'mule-unicode-0100-24ff))
 391                          (r3 -= #x0100)
 392                          (r3 //= 96)
 393                          (r1 = (r7 + 32))
 394                          (r1 += ((r3 + 32) << 7))
 395                          (translate-character
 396                           utf-translation-table-for-decode r0 r1)
 397                          (write-multibyte-character r0 r1))
 398
 399                       ;; mule-unicode-2500-33ff
 400                       (if (r3 < #x3400)
 401                           ((r4 = r3)    ; don't zap r3
 402                            (lookup-integer utf-subst-table-for-decode r4 r5)
 403                            (if r7
 404                                ;; got a translation
 405                                ((write-multibyte-character r4 r5)
 406                                 ;; Zapped through register starvation.
 407                                 (r5 = ,(charset-id 'eight-bit-control)))
 408                              ((r0 = ,(charset-id 'mule-unicode-2500-33ff))
 409                               (r3 -= #x2500)
 410                               (r3 //= 96)
 411                               (r1 = (r7 + 32))
 412                               (r1 += ((r3 + 32) << 7))
 413                               (write-multibyte-character r0 r1))))
 414
 415                         ;; U+3400 .. U+D7FF
 416                         ;; Try to convert to CJK chars, else keep
 417                         ;; them as eight-bit-{control|graphic}.
 418                         (if (r3 < #xd800)
 419                             ((r4 = r3)  ; don't zap r3
 420                              (lookup-integer utf-subst-table-for-decode r4 r5)
 421                              (if r7
 422                                  ;; got a translation
 423                                  ((write-multibyte-character r4 r5)
 424                                   ;; Zapped through register starvation.
 425                                   (r5 = ,(charset-id 'eight-bit-control)))
 426                                ;; #xe0 <= r0 < #xf0, so r0 is eight-bit-graphic
 427                                ((r3 = r6)
 428                                 (write-multibyte-character r3 r0)
 429                                 (if (r1 < #xa0)
 430                                     (r3 = r5))
 431                                 (write-multibyte-character r3 r1)
 432                                 (if (r2 < #xa0)
 433                                     (r3 = r5)
 434                                   (r3 = r6))
 435                                 (write-multibyte-character r3 r2))))
 436
 437                           ;; Surrogates, U+D800 .. U+DFFF
 438                           (if (r3 < #xe000)
 439                               ((r3 = r6)
 440                                (write-multibyte-character r3 r0) ; eight-bit-graphic
 441                                (if (r1 < #xa0)
 442                                    (r3 = r5))
 443                                (write-multibyte-character r3 r1)
 444                                (if (r2 < #xa0)
 445                                    (r3 = r5)
 446                                  (r3 = r6))
 447                                (write-multibyte-character r3 r2))
 448
 449                             ;; mule-unicode-e000-ffff
 450                             ;; Fixme: fffe and ffff are invalid.
 451                             ((r4 = r3)  ; don't zap r3
 452                              (lookup-integer utf-subst-table-for-decode r4 r5)
 453                              (if r7
 454                                  ;; got a translation
 455                                  ((write-multibyte-character r4 r5)
 456                                   ;; Zapped through register starvation.
 457                                   (r5 = ,(charset-id 'eight-bit-control)))
 458                                ((r0 = ,(charset-id 'mule-unicode-e000-ffff))
 459                                 (r3 -= #xe000)
 460                                 (r3 //= 96)
 461                                 (r1 = (r7 + 32))
 462                                 (r1 += ((r3 + 32) << 7))
 463                                 (write-multibyte-character r0 r1)))))))))))
 464
 465               (if (r0 < #xfe)
 466                   ;; 4byte encoding
 467                   ;; keep those bytes as eight-bit-{control|graphic}
 468                   ;; Fixme: allow lookup in utf-subst-table-for-decode.
 469                   ((r1 = -1)
 470                    (r2 = -1)
 471                    (r3 = -1)
 472                    (read r1 r2 r3)
 473                    ;; r0 > #xf0, thus eight-bit-graphic
 474                    (write-multibyte-character r6 r0)
 475                    (if (r1 < #xa0)
 476                        (if (r1 < #x80)  ; invalid byte
 477                            (write r1)
 478                          (write-multibyte-character r5 r1))
 479                      (write-multibyte-character r6 r1))
 480                    (if (r2 < #xa0)
 481                        (if (r2 < #x80)  ; invalid byte
 482                            (write r2)
 483                          (write-multibyte-character r5 r2))
 484                      (write-multibyte-character r6 r2))
 485                    (if (r3 < #xa0)
 486                        (if (r3 < #x80)  ; invalid byte
 487                            (write r3)
 488                          (write-multibyte-character r5 r3))
 489                      (write-multibyte-character r6 r3))
 490                    (if (r0 >= #xf8)     ; 5- or 6-byte encoding
 491                        ((r0 = -1)
 492                         (read r0)
 493                         (if (r0 < #xa0)
 494                             (if (r0 < #x80) ; invalid byte
 495                                 (write r0)
 496                               (write-multibyte-character r5 r0))
 497                           (write-multibyte-character r6 r0))
 498                         (if (r0 >= #xfc) ; 6-byte
 499                             ((r0 = -1)
 500                              (read r0)
 501                              (if (r0 < #xa0)
 502                                  (if (r0 < #x80) ; invalid byte
 503                                      (write r0)
 504                                    (write-multibyte-character r5 r0))
 505                                (write-multibyte-character r6 r0)))))))
 506                 ;; else invalid byte >= #xfe
 507                 (write-multibyte-character r6 r0))))))
 508       (repeat)))
 509
 510     ;; At EOF...
 511     (if (r0 >= 0)
 512         ((if (r0 < #x80)
 513              (write r0)
 514            (if (r0 < #xa0)
 515                (write-multibyte-character r5 r0)
 516              ((write-multibyte-character r6 r0))))
 517          (if (r1 >= 0)
 518              ((if (r1 < #x80)
 519                   (write r1)
 520                 (if (r1 < #xa0)
 521                     (write-multibyte-character r5 r1)
 522                   ((write-multibyte-character r6 r1))))
 523               (if (r2 >= 0)
 524                   ((if (r2 < #x80)
 525                        (write r2)
 526                      (if (r2 < #xa0)
 527                          (write-multibyte-character r5 r2)
 528                        ((write-multibyte-character r6 r2))))
 529                    (if (r3 >= 0)
 530                        (if (r3 < #x80)
 531                            (write r3)
 532                          (if (r3 < #xa0)
 533                              (write-multibyte-character r5 r3)
 534                            ((write-multibyte-character r6 r3))))))))))))
 535
 536   "CCL program to decode UTF-8.
 537 Basic decoding is done into the charsets ascii, latin-iso8859-1 and
 538 mule-unicode-*, but see also `utf-fragmentation-table' and
 539 `ucs-mule-cjk-to-unicode'.
 540 Encodings of un-representable Unicode characters are decoded asis into
 541 eight-bit-control and eight-bit-graphic characters.")
 542
 543 (define-ccl-program ccl-encode-mule-utf-8
 544   `(1
 545     ((r5 = -1)
 546      (loop
 547       (if (r5 < 0)
 548           ((r1 = -1)
 549            (read-multibyte-character r0 r1)
 550            (translate-character utf-translation-table-for-encode r0 r1))
 551         (;; We have already done read-multibyte-character.
 552          (r0 = r5)
 553          (r1 = r6)
 554          (r5 = -1)))
 555
 556       (if (r0 == ,(charset-id 'ascii))
 557           (write r1)
 558
 559         (if (r0 == ,(charset-id 'latin-iso8859-1))
 560             ;; r1          scalar                  utf-8
 561             ;;       0000 0yyy yyxx xxxx    110y yyyy 10xx xxxx
 562             ;; 20    0000 0000 1010 0000    1100 0010 1010 0000
 563             ;; 7f    0000 0000 1111 1111    1100 0011 1011 1111
 564             ((r0 = (((r1 & #x40) >> 6) | #xc2))
 565              (r1 &= #x3f)
 566              (r1 |= #x80)
 567              (write r0 r1))
 568
 569           (if (r0 == ,(charset-id 'mule-unicode-0100-24ff))
 570               ((r0 = ((((r1 & #x3f80) >> 7) - 32) * 96))
 571                ;; #x3f80 == (0011 1111 1000 0000)b
 572                (r1 &= #x7f)
 573                (r1 += (r0 + 224))       ; 240 == -32 + #x0100
 574                ;; now r1 holds scalar value
 575                (if (r1 < #x0800)
 576                    ;; 2byte encoding
 577                    ((r0 = (((r1 & #x07c0) >> 6) | #xc0))
 578                     ;; #x07c0 == (0000 0111 1100 0000)b
 579                     (r1 &= #x3f)
 580                     (r1 |= #x80)
 581                     (write r0 r1))
 582                  ;; 3byte encoding
 583                  ((r0 = (((r1 & #xf000) >> 12) | #xe0))
 584                   (r2 = ((r1 & #x3f) | #x80))
 585                   (r1 &= #x0fc0)
 586                   (r1 >>= 6)
 587                   (r1 |= #x80)
 588                   (write r0 r1 r2))))
 589
 590             (if (r0 == ,(charset-id 'mule-unicode-2500-33ff))
 591                 ((r0 = ((((r1 & #x3f80) >> 7) - 32) * 96))
 592                  (r1 &= #x7f)
 593                  (r1 += (r0 + 9440))    ; 9440 == -32 + #x2500
 594                  (r0 = (((r1 & #xf000) >> 12) | #xe0))
 595                  (r2 = ((r1 & #x3f) | #x80))
 596                  (r1 &= #x0fc0)
 597                  (r1 >>= 6)
 598                  (r1 |= #x80)
 599                  (write r0 r1 r2))
 600
 601               (if (r0 == ,(charset-id 'mule-unicode-e000-ffff))
 602                   ((r0 = ((((r1 & #x3f80) >> 7) - 32) * 96))
 603                    (r1 &= #x7f)
 604                    (r1 += (r0 + 57312)) ; 57312 == -32 + #xe000
 605                    (r0 = (((r1 & #xf000) >> 12) | #xe0))
 606                    (r2 = ((r1 & #x3f) | #x80))
 607                    (r1 &= #x0fc0)
 608                    (r1 >>= 6)
 609                    (r1 |= #x80)
 610                    (write r0 r1 r2))
 611
 612                 (if (r0 == ,(charset-id 'eight-bit-control))
 613                     ;; r1          scalar                  utf-8
 614                     ;;       0000 0yyy yyxx xxxx    110y yyyy 10xx xxxx
 615                     ;; 80    0000 0000 1000 0000    1100 0010 1000 0000
 616                     ;; 9f    0000 0000 1001 1111    1100 0010 1001 1111
 617                     ((write #xc2)
 618                      (write r1))
 619
 620                   (if (r0 == ,(charset-id 'eight-bit-graphic))
 621                       ;; r1          scalar                  utf-8
 622                       ;;       0000 0yyy yyxx xxxx    110y yyyy 10xx xxxx
 623                       ;; a0    0000 0000 1010 0000    1100 0010 1010 0000
 624                       ;; ff    0000 0000 1111 1111    1101 1111 1011 1111
 625                       ((write r1)
 626                        (r1 = -1)
 627                        (read-multibyte-character r0 r1)
 628                        (if (r0 != ,(charset-id 'eight-bit-graphic))
 629                            (if (r0 != ,(charset-id 'eight-bit-control))
 630                                ((r5 = r0)
 631                                 (r6 = r1))))
 632                        (if (r5 < 0)
 633                            ((read-multibyte-character r0 r2)
 634                             (if (r0 != ,(charset-id 'eight-bit-graphic))
 635                                 (if (r0 != ,(charset-id 'eight-bit-control))
 636                                     ((r5 = r0)
 637                                      (r6 = r2))))
 638                             (if (r5 < 0)
 639                                 (write r1 r2)
 640                               (if (r1 < #xa0)
 641                                   (write r1)
 642                                 ((write #xc2)
 643                                  (write r1)))))))
 644
 645                     ((lookup-character utf-subst-table-for-encode r0 r1)
 646                      (if r7             ; lookup succeeded
 647                          ((r1 = (((r0 & #xf000) >> 12) | #xe0))
 648                           (r2 = ((r0 & #x3f) | #x80))
 649                           (r0 &= #x0fc0)
 650                           (r0 >>= 6)
 651                           (r0 |= #x80)
 652                           (write r1 r0 r2))
 653                        ;; Unsupported character.
 654                        ;; Output U+FFFD, which is `ef bf bd' in UTF-8.
 655                        ((write #xef)
 656                         (write #xbf)
 657                         (write #xbd)))))))))))
 658       (repeat)))
 659     (if (r1 >= #xa0)
 660         (write r1)
 661       (if (r1 >= #x80)
 662           ((write #xc2)
 663            (write r1)))))
 664
 665   "CCL program to encode into UTF-8.")
 666
 667
 668 (define-ccl-program ccl-untranslated-to-ucs
 669   `(0
 670     (if (r0 < #xf0)                     ; 3-byte encoding, as above
 671         ((r4 = 0)
 672          (r3 = (r1 & #b11000000))
 673          (r3 |= ((r2 >> 2) & #b00110000))
 674          (if (r3 != #b10100000)
 675              (r4 = 1)
 676            ((r3 = ((r0 & #x0f) << 12))
 677             (r3 += ((r1 & #x3f) << 6))
 678             (r3 += (r2 & #x3f))
 679             (if (r3 < #x0800)
 680                 (r4 = 1))))
 681          (if (r4 != 0)
 682              (r0 = 0)
 683            (r0 = r3)))
 684       (if (r0 < #xf8)                   ; 4-byte (Mule-UCS recipe)
 685           ((r4 = (r1 >> 6))
 686            (if (r4 != #b10)
 687                (r0 = 0)
 688              ((r4 = (r2 >> 6))
 689               (if (r4 != #b10)
 690                   (r0 = 0)
 691                 ((r4 = (r3 >> 6))
 692                  (if (r4 != #b10)
 693                      (r0 = 0)
 694                    ((r1 = ((r1  & #x3F) << 12))
 695                     (r2 = ((r2  & #x3F) << 6))
 696                     (r3 &= #x3F)
 697                     (r0 = (((((r0 & #x07) << 18) | r1) | r2) | r3)))))))))
 698         (r0 = 0))))
 699   "Decode 3- or 4-byte sequences in r0, r1, r2 [,r3] to unicodes in r0.
 700 r0 == 0 for invalid sequence.")
 701
 702 (defvar utf-8-ccl-regs (make-vector 8 0))
 703
 704 (defsubst utf-8-untranslated-to-ucs ()
 705   "Return the UCS code for an untranslated sequence of raw bytes t point.
 706 Only for 3- or 4-byte sequences."
 707   (aset utf-8-ccl-regs 0 (or (char-after) 0))
 708   (aset utf-8-ccl-regs 1 (or (char-after (1+ (point))) 0))
 709   (aset utf-8-ccl-regs 2 (or (char-after (+ 2 (point))) 0))
 710   (aset utf-8-ccl-regs 3 (or (char-after (+ 3 (point))) 0))
 711   (ccl-execute 'ccl-untranslated-to-ucs utf-8-ccl-regs)
 712   (aref utf-8-ccl-regs 0))
 713
 714 (defun utf-8-help-echo (window object position)
 715   (format "Untranslated Unicode U+%04X"
 716           (get-char-property position 'untranslated-utf-8 object)))
 717
 718 ;; We compose the untranslatable sequences into a single character.
 719 ;; This is infelicitous for editing, because there's currently no
 720 ;; mechanism for treating compositions as atomic, but is OK for
 721 ;; display.  They are composed to U+FFFD with help-echo which
 722 ;; indicates the unicodes they represent.  This function GCs too much.
 723 (defsubst utf-8-compose ()
 724   "Put a suitable composition on an untranslatable sequence.
 725 Return the sequence's length."
 726   (let* ((u (utf-8-untranslated-to-ucs))
 727          (l (unless (zerop u)
 728               (if (>= u #x10000)
 729                        4
 730                      3))))
 731     (when l
 732       (put-text-property (point) (min (point-max) (+ l (point)))
 733                          'untranslated-utf-8 u)
 734       (put-text-property (point) (min (point-max) (+ l (point)))
 735                          'help-echo 'utf-8-help-echo)
 736       (compose-region (point) (+ l (point)) ?\e$,3u=\e(B)
 737       l)))
 738
 739 (defcustom utf-8-compose-scripts nil
 740   "*Non-nil means compose various scripts on decoding utf-8 text."
 741   :group 'mule
 742   :version "21.4"
 743   :type 'boolean)
 744
 745 (defun utf-8-post-read-conversion (length)
 746   "Compose untranslated utf-8 sequences into single characters.
 747 Also compose particular scripts if `utf-8-compose-scripts' is non-nil."
 748   (save-excursion
 749     ;; Can't do eval-when-compile to insert a multibyte constant
 750     ;; version of the string in the loop, since it's always loaded as
 751     ;; unibyte from a byte-compiled file.
 752     (let ((range (string-as-multibyte "^\xe1-\xf7")))
 753       (while (and (skip-chars-forward range)
 754                   (not (eobp)))
 755         (forward-char (utf-8-compose)))))
 756   ;; Fixme: Takahashi-san implies it may not work this easily.  I
 757   ;; asked why but didn't get a reply. -- fx
 758   (when (and utf-8-compose-scripts (> length 1))
 759     ;; These currently have definitions which cover the relevant
 760     ;; unicodes.  We could avoid loading thai-util &c by checking
 761     ;; whether the region contains any characters with the appropriate
 762     ;; categories.  There aren't yet Unicode-based rules for Tibetan.
 763     (save-excursion (setq length (diacritic-post-read-conversion length)))
 764     (save-excursion (setq length (thai-post-read-conversion length)))
 765     (save-excursion (setq length (lao-post-read-conversion length)))
 766     (save-excursion (setq length (devanagari-post-read-conversion length)))
 767     (save-excursion (setq length (malayalam-post-read-conversion length)))
 768     (save-excursion (setq length (tamil-post-read-conversion length))))
 769   length)
 770
 771 ;; ucs-tables is preloaded
 772 ;; (defun utf-8-pre-write-conversion (beg end)
 773 ;;   "Semi-dummy pre-write function effectively to autoload ucs-tables."
 774 ;;   ;; Ensure translation-table is loaded.
 775 ;;   (require 'ucs-tables)
 776 ;;   ;; Don't do this again.
 777 ;;   (coding-system-put 'mule-utf-8 'pre-write-conversion nil)
 778 ;;   nil)
 779
 780 (make-coding-system
 781  'mule-utf-8 4 ?u
 782  "UTF-8 encoding for Emacs-supported Unicode characters.
 783 It supports Unicode characters of these ranges:
 784     U+0000..U+33FF, U+E000..U+FFFF.
 785 They correspond to these Emacs character sets:
 786     ascii, latin-iso8859-1, mule-unicode-0100-24ff,
 787     mule-unicode-2500-33ff, mule-unicode-e000-ffff
 788
 789 On decoding (e.g. reading a file), Unicode characters not in the above
 790 ranges are decoded into sequences of eight-bit-control and
 791 eight-bit-graphic characters to preserve their byte sequences.  The
 792 byte sequence is preserved on i/o for valid utf-8, but not necessarily
 793 for invalid utf-8.
 794
 795 On encoding (e.g. writing a file), Emacs characters not belonging to
 796 any of the character sets listed above are encoded into the UTF-8 byte
 797 sequence representing U+FFFD (REPLACEMENT CHARACTER)."
 798
 799  '(ccl-decode-mule-utf-8 . ccl-encode-mule-utf-8)
 800  '((safe-charsets
 801     ascii
 802     eight-bit-control
 803     eight-bit-graphic
 804     latin-iso8859-1
 805     mule-unicode-0100-24ff
 806     mule-unicode-2500-33ff
 807     mule-unicode-e000-ffff)
 808    (mime-charset . utf-8)
 809    (coding-category . coding-category-utf-8)
 810    (valid-codes (0 . 255))
 811 ;;    (pre-write-conversion . utf-8-pre-write-conversion)
 812    (post-read-conversion . utf-8-post-read-conversion)
 813    (translation-table-for-encode . utf-translation-table-for-encode)
 814    (dependency unify-8859-on-encoding-mode
 815                unify-8859-on-decoding-mode
 816                utf-fragment-on-decoding
 817                utf-translate-cjk)))
 818
 819 (define-coding-system-alias 'utf-8 'mule-utf-8)
 820
 821 ;; I think this needs special private charsets defined for the
 822 ;; untranslated sequences, if it's going to work well.
 823
 824 ;;; (defun utf-8-compose-function (pos to pattern &optional string)
 825 ;;;   (let* ((prop (get-char-property pos 'composition string))
 826 ;;;      (l (and prop (- (cadr prop) (car prop)))))
 827 ;;;     (cond ((and l (> l (- to pos)))
 828 ;;;        (delete-region pos to))
 829 ;;;       ((and (> (char-after pos) 224)
 830 ;;;             (< (char-after pos) 256)
 831 ;;;             (save-restriction
 832 ;;;               (narrow-to-region pos to)
 833 ;;;               (utf-8-compose)))
 834 ;;;        t))))
 835
 836 ;;; (dotimes (i 96)
 837 ;;;   (aset composition-function-table
 838 ;;;     (+ 128 i)
 839 ;;;     `((,(string-as-multibyte "[\200-\237\240-\377]")
 840 ;;;        . utf-8-compose-function))))
 841
 842 ;;; arch-tag: b08735b7-753b-4ae6-b754-0f3efe4515c5
 843 ;;; utf-8.el ends here