lisp/international/utf-8.el

   1 ;;; utf-8.el --- UTF-8 decoding/encoding support -*- coding: iso-2022-7bit -*-
   2
   3 ;; Copyright (C) 2001, 2004 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-mode' 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-mode' 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
 194 (defconst utf-translate-cjk-charsets '(chinese-gb2312
 195                                        chinese-big5-1 chinese-big5-2
 196                                        japanese-jisx0208 japanese-jisx0212
 197                                        katakana-jisx0201
 198                                        korean-ksc5601)
 199   "List of charsets supported by `utf-translate-cjk-mode'.")
 200
 201 (defvar utf-translate-cjk-lang-env nil
 202   "Language environment in which tables for `utf-translate-cjk-mode' is loaded.
 203 The value nil means that the tables are not yet loaded.")
 204
 205 (defvar utf-translate-cjk-unicode-range)
 206
 207 ;; String generated from utf-translate-cjk-unicode-range.  It is
 208 ;; suitable for an argument to skip-chars-forward.
 209 (defvar utf-translate-cjk-unicode-range-string nil)
 210
 211 (defun utf-translate-cjk-set-unicode-range (range)
 212   (setq utf-translate-cjk-unicode-range range)
 213   (setq utf-translate-cjk-unicode-range-string
 214         (let ((decode-char-no-trans
 215                #'(lambda (x)
 216                    (cond ((< x #x100) (make-char 'latin-iso8859-1 x))
 217                          ((< x #x2500)
 218                           (setq x (- x #x100))
 219                           (make-char 'mule-unicode-0100-24ff
 220                                      (+ (/ x 96) 32) (+ (% x 96) 32)))
 221                          ((< x #x3400)
 222                           (setq x (- x #x2500))
 223                           (make-char 'mule-unicode-2500-33ff
 224                                      (+ (/ x 96) 32) (+ (% x 96) 32)))
 225                          (t
 226                           (setq x (- x #xe000))
 227                           (make-char 'mule-unicode-e000-ffff
 228                                      (+ (/ x 96) 32) (+ (% x 96) 32))))))
 229               ranges from to)
 230           (dolist (elt range)
 231             (setq from (max #xA0 (car elt)) to (min #xffff (cdr elt)))
 232             (if (and (>= to #x3400) (< to #xE000))
 233                 (setq to #x33FF))
 234             (cond ((< from #x100)
 235                    (if (>= to #xE000)
 236                        (setq ranges (cons (cons #xE000 to) ranges)
 237                              to #x33FF))
 238                    (if (>= to #x2500)
 239                        (setq ranges (cons (cons #x2500 to) ranges)
 240                              to #x24FF))
 241                    (if (>= to #x100)
 242                        (setq ranges (cons (cons #x100 to) ranges)
 243                              to #xFF)))
 244                   ((< from #x2500)
 245                    (if (>= to #xE000)
 246                        (setq ranges (cons (cons #xE000 to) ranges)
 247                              to #x33FF))
 248                    (if (>= to #x2500)
 249                        (setq ranges (cons (cons #x2500 to) ranges)
 250                              to #x24FF)))
 251                   ((< from #x3400)
 252                    (if (>= to #xE000)
 253                        (setq ranges (cons (cons #xE000 to) ranges)
 254                              to #x33FF))))
 255             (if (<= from to)
 256                 (setq ranges (cons (cons from to) ranges))))
 257           (mapconcat #'(lambda (x)
 258                          (format "%c-%c"
 259                                  (funcall decode-char-no-trans (car x))
 260                                  (funcall decode-char-no-trans (cdr x))))
 261                      ranges "")))
 262   ;; These forces loading and settting tables for
 263   ;; utf-translate-cjk-mode.
 264   (setq utf-translate-cjk-lang-env nil
 265         ucs-mule-cjk-to-unicode (make-hash-table :test 'eq)
 266         ucs-unicode-to-mule-cjk (make-hash-table :test 'eq)))
 267
 268 (defcustom utf-translate-cjk-unicode-range '((#x2e80 . #xd7a3)
 269                                              (#xff00 . #xffef))
 270   "List of Unicode code ranges supported by `utf-translate-cjk-mode'.
 271 Setting this variable directly does not take effect;
 272 use either \\[customize] or the function
 273 `utf-translate-cjk-set-unicode-range'."
 274   :version "21.4"
 275   :type '(repeat (cons integer integer))
 276   :set (lambda (symbol value)
 277          (utf-translate-cjk-set-unicode-range value))
 278   :group 'mule)
 279
 280 ;; Return non-nil if CODE-POINT is in `utf-translate-cjk-unicode-range'.
 281 (defsubst utf-translate-cjk-substitutable-p (code-point)
 282   (let ((tail utf-translate-cjk-unicode-range)
 283         elt)
 284     (while tail
 285       (setq elt (car tail) tail (cdr tail))
 286       (if (and (>= code-point (car elt)) (<= code-point (cdr elt)))
 287           (setq tail nil)
 288         (setq elt nil)))
 289     elt))
 290
 291 (defun utf-translate-cjk-load-tables ()
 292   "Load tables for `utf-translate-cjk-mode'."
 293   ;; Fixme: Allow the use of the CJK charsets to be
 294   ;; customized by reordering and possible omission.
 295   (let ((redefined (< (hash-table-size ucs-mule-cjk-to-unicode) 43000)))
 296     (if redefined
 297         ;; Redefine them with realistic initial sizes and a
 298         ;; smallish rehash size to avoid wasting significant
 299         ;; space after they're built.
 300         (setq ucs-mule-cjk-to-unicode
 301               (make-hash-table :test 'eq :size 43000 :rehash-size 1000)
 302               ucs-unicode-to-mule-cjk
 303               (make-hash-table :test 'eq :size 21500 :rehash-size 1000)))
 304
 305     ;; Load the files explicitly, to avoid having to keep
 306     ;; around the large tables they contain (as well as the
 307     ;; ones which get built).
 308     ;; Here we bind coding-system-for-read to nil so that coding tags
 309     ;; in the files are respected even if the files are not yet
 310     ;; byte-compiled
 311     (let ((coding-system-for-read nil))
 312       (cond ((string= "Korean" current-language-environment)
 313              (load "subst-jis")
 314              (load "subst-big5")
 315              (load "subst-gb2312")
 316              (load "subst-ksc"))
 317             ((string= "Chinese-BIG5" current-language-environment)
 318              (load "subst-jis")
 319              (load "subst-ksc")
 320              (load "subst-gb2312")
 321              (load "subst-big5"))
 322             ((string= "Chinese-GB" current-language-environment)
 323              (load "subst-jis")
 324              (load "subst-ksc")
 325              (load "subst-big5")
 326              (load "subst-gb2312"))
 327             (t
 328              (load "subst-ksc")
 329              (load "subst-gb2312")
 330              (load "subst-big5")
 331              (load "subst-jis")))) ; jis covers as much as big5, gb2312
 332
 333     (when redefined
 334       (define-translation-hash-table 'utf-subst-table-for-decode
 335         ucs-unicode-to-mule-cjk)
 336       (define-translation-hash-table 'utf-subst-table-for-encode
 337         ucs-mule-cjk-to-unicode)
 338       (set-char-table-extra-slot (get 'utf-translation-table-for-encode
 339                                       'translation-table)
 340                                  1 ucs-mule-cjk-to-unicode))
 341
 342     (setq utf-translate-cjk-lang-env current-language-environment)))
 343
 344 (defun utf-lookup-subst-table-for-decode (code-point)
 345   (if (and utf-translate-cjk-mode
 346            (not utf-translate-cjk-lang-env)
 347            (utf-translate-cjk-substitutable-p code-point))
 348       (utf-translate-cjk-load-tables))
 349   (gethash code-point
 350            (get 'utf-subst-table-for-decode 'translation-hash-table)))
 351
 352
 353 (defun utf-lookup-subst-table-for-encode (char)
 354   (if (and utf-translate-cjk-mode
 355            (not utf-translate-cjk-lang-env)
 356            (memq (char-charset char) utf-translate-cjk-charsets))
 357       (utf-translate-cjk-load-tables))
 358   (gethash char
 359            (get 'utf-subst-table-for-encode 'translation-hash-table)))
 360
 361 (define-minor-mode utf-translate-cjk-mode
 362   "Toggle whether UTF based coding systems de/encode CJK characters.
 363 If ARG is an integer, enable if ARG is positive and disable if
 364 zero or negative.  This is a minor mode.
 365 Enabling this allows the coding systems mule-utf-8,
 366 mule-utf-16le and mule-utf-16be to encode characters in the charsets
 367 `korean-ksc5601', `chinese-gb2312', `chinese-big5-1',
 368 `chinese-big5-2', `japanese-jisx0208' and `japanese-jisx0212', and to
 369 decode the corresponding unicodes into such characters.
 370
 371 Where the charsets overlap, the one preferred for decoding is chosen
 372 according to the language environment in effect when this option is
 373 turned on: ksc5601 for Korean, gb2312 for Chinese-GB, big5 for
 374 Chinese-Big5 and jisx for other environments.
 375
 376 This mode is on by default.  If you are not interested in CJK
 377 characters and want to avoid some overhead on encoding/decoding
 378 by the above coding systems, you can customize the user option
 379 `utf-translate-cjk-mode' to nil."
 380   :init-value t
 381   :version "21.4"
 382   :type 'boolean
 383   :group 'mule
 384   :global t
 385   (if utf-translate-cjk-mode
 386       (progn
 387         (define-translation-hash-table 'utf-subst-table-for-decode
 388           ucs-unicode-to-mule-cjk)
 389         (define-translation-hash-table 'utf-subst-table-for-encode
 390           ucs-mule-cjk-to-unicode)
 391         (set-char-table-extra-slot (get 'utf-translation-table-for-encode
 392                                         'translation-table)
 393                                    1 ucs-mule-cjk-to-unicode))
 394     (define-translation-hash-table 'utf-subst-table-for-decode
 395       (make-hash-table :test 'eq))
 396     (define-translation-hash-table 'utf-subst-table-for-encode
 397       (make-hash-table :test 'eq))
 398     (set-char-table-extra-slot (get 'utf-translation-table-for-encode
 399                                     'translation-table)
 400                                1 nil))
 401
 402   ;; Update safe-chars of mule-utf-* coding systems.
 403   (dolist (elt (coding-system-list t))
 404     (if (string-match "^mule-utf" (symbol-name elt))
 405         (let ((safe-charsets (coding-system-get elt 'safe-charsets))
 406               (safe-chars (coding-system-get elt 'safe-chars))
 407               (need-update nil))
 408           (dolist (charset utf-translate-cjk-charsets)
 409             (unless (eq utf-translate-cjk-mode (memq charset safe-charsets))
 410               (setq safe-charsets
 411                     (if utf-translate-cjk-mode
 412                         (cons charset safe-charsets)
 413                       (delq charset safe-charsets))
 414                     need-update t)
 415               (aset safe-chars (make-char charset) utf-translate-cjk-mode)))
 416           (when need-update
 417             (coding-system-put elt 'safe-charsets safe-charsets)
 418             (define-coding-system-internal elt))))))
 419
 420 (define-ccl-program ccl-mule-utf-untrans
 421   ;; R0 is an untranslatable Unicode code-point (U+3500..U+DFFF or
 422   ;; U+10000..U+10FFFF) or an invaid byte (#x00..#xFF).  Write
 423   ;; eight-bit-control/graphic sequence (2 to 4 chars) representing
 424   ;; UTF-8 sequence of r0.  Registers r4, r5, r6 are modified.
 425   ;;
 426   ;; This is a subrountine because we assume that this is called very
 427   ;; rarely (so we don't have to worry about the overhead of the
 428   ;; call).
 429   `(0
 430     ((r5 = ,(charset-id 'eight-bit-control))
 431      (r6 = ,(charset-id 'eight-bit-graphic))
 432      (if (r0 < #x100)
 433          ((r4 = ((r0 >> 6) | #xC0))
 434           (write-multibyte-character r6 r4))
 435        ((if (r0 < #x10000)
 436             ((r4 = ((r0 >> 12) | #xE0))
 437              (write-multibyte-character r6 r4))
 438           ((r4 = ((r0 >> 18) | #xF0))
 439            (write-multibyte-character r6 r4)
 440            (r4 = (((r0 >> 12) & #x3F) | #x80))
 441            (if (r4 < #xA0)
 442                (write-multibyte-character r5 r4)
 443              (write-multibyte-character r6 r4))))
 444         (r4 = (((r0 >> 6) & #x3F) | #x80))
 445         (if (r4 < #xA0)
 446             (write-multibyte-character r5 r4)
 447           (write-multibyte-character r6 r4))))
 448      (r4 = ((r0 & #x3F) | #x80))
 449      (if (r4 < #xA0)
 450          (write-multibyte-character r5 r4)
 451        (write-multibyte-character r6 r4)))))
 452
 453 (define-ccl-program ccl-decode-mule-utf-8
 454   ;;
 455   ;;        charset         | bytes in utf-8 | bytes in emacs
 456   ;; -----------------------+----------------+---------------
 457   ;;         ascii          |       1        |       1
 458   ;; -----------------------+----------------+---------------
 459   ;;    eight-bit-control   |       2        |       2
 460   ;;    eight-bit-graphic   |       2        |       1
 461   ;;     latin-iso8859-1    |       2        |       2
 462   ;; -----------------------+----------------+---------------
 463   ;; mule-unicode-0100-24ff |       2        |       4
 464   ;;        (< 0800)        |                |
 465   ;; -----------------------+----------------+---------------
 466   ;; mule-unicode-0100-24ff |       3        |       4
 467   ;;        (>= 8000)       |                |
 468   ;; mule-unicode-2500-33ff |       3        |       4
 469   ;; mule-unicode-e000-ffff |       3        |       4
 470   ;; -----------------------+----------------+---------------
 471   ;;      invalid byte      |       1        |       2
 472   ;;
 473   ;; Thus magnification factor is two.
 474   ;;
 475   `(2
 476     ((r6 = ,(charset-id 'latin-iso8859-1))
 477      (read r0)
 478      (loop
 479       (if (r0 < #x80)
 480           ;; 1-byte encoding, i.e., ascii
 481           (write-read-repeat r0))
 482       (if (r0 < #xc2)
 483           ;; continuation byte (invalid here) or 1st byte of overlong
 484           ;; 2-byte sequence.
 485           ((call ccl-mule-utf-untrans)
 486            (r6 = ,(charset-id 'latin-iso8859-1))
 487            (read r0)
 488            (repeat)))
 489
 490       ;; Read the 2nd byte.
 491       (read r1)
 492       (if ((r1 & #b11000000) != #b10000000) ; Invalid 2nd byte
 493           ((call ccl-mule-utf-untrans)
 494            (r6 = ,(charset-id 'latin-iso8859-1))
 495            ;; Handle it in the next loop.
 496            (r0 = r1)
 497            (repeat)))
 498
 499       (if (r0 < #xe0)
 500           ;; 2-byte encoding 00000yyyyyxxxxxx = 110yyyyy 10xxxxxx
 501           ((r1 &= #x3F)
 502            (r1 |= ((r0 & #x1F) << 6))
 503            ;; Now r1 holds scalar value.  We don't have to check
 504            ;; `overlong sequence' because r0 >= 0xC2.
 505
 506            (if (r1 >= 256)
 507                ;; mule-unicode-0100-24ff (< 0800)
 508                ((r0 = r1)
 509                 (lookup-integer utf-subst-table-for-decode r0 r1)
 510                 (if (r7 == 0)
 511                     ((r0 = ,(charset-id 'mule-unicode-0100-24ff))
 512                      (r1 -= #x0100)
 513                      (r2 = (((r1 / 96) + 32) << 7))
 514                      (r1 %= 96)
 515                      (r1 += (r2 + 32))
 516                      (translate-character
 517                       utf-translation-table-for-decode r0 r1)))
 518                 (write-multibyte-character r0 r1)
 519                 (read r0)
 520                 (repeat))
 521              (if (r1 >= 160)
 522                  ;; latin-iso8859-1
 523                  ((r0 = r1)
 524                   (lookup-integer utf-subst-table-for-decode r0 r1)
 525                   (if (r7 == 0)
 526                       ((r1 -= 128)
 527                        (write-multibyte-character r6 r1))
 528                     ((write-multibyte-character r0 r1)))
 529                   (read r0)
 530                   (repeat))
 531                ;; eight-bit-control
 532                ((r0 = ,(charset-id 'eight-bit-control))
 533                 (write-multibyte-character r0 r1)
 534                 (read r0)
 535                 (repeat))))))
 536
 537       ;; Read the 3rd bytes.
 538       (read r2)
 539       (if ((r2 & #b11000000) != #b10000000) ; Invalid 3rd byte
 540           ((call ccl-mule-utf-untrans)
 541            (r0 = r1)
 542            (call ccl-mule-utf-untrans)
 543            (r6 = ,(charset-id 'latin-iso8859-1))
 544            ;; Handle it in the next loop.
 545            (r0 = r2)
 546            (repeat)))
 547
 548       (if (r0 < #xF0)
 549           ;; 3byte encoding
 550           ;; zzzzyyyyyyxxxxxx = 1110zzzz 10yyyyyy 10xxxxxx
 551           ((r3 = ((r0 & #xF) << 12))
 552            (r3 |= ((r1 & #x3F) << 6))
 553            (r3 |= (r2 & #x3F))
 554
 555            (if (r3 < #x800)             ; `overlong sequence'
 556                ((call ccl-mule-utf-untrans)
 557                 (r0 = r1)
 558                 (call ccl-mule-utf-untrans)
 559                 (r0 = r2)
 560                 (call ccl-mule-utf-untrans)
 561                 (r6 = ,(charset-id 'latin-iso8859-1))
 562                 (read r0)
 563                 (repeat)))
 564
 565            (if (r3 < #x2500)
 566                ;; mule-unicode-0100-24ff (>= 0800)
 567                ((r0 = r3)
 568                 (lookup-integer utf-subst-table-for-decode r0 r1)
 569                 (if (r7 == 0)
 570                     ((r0 = ,(charset-id 'mule-unicode-0100-24ff))
 571                      (r3 -= #x0100)
 572                      (r3 //= 96)
 573                      (r1 = (r7 + 32))
 574                      (r1 += ((r3 + 32) << 7))
 575                      (translate-character
 576                       utf-translation-table-for-decode r0 r1)))
 577                 (write-multibyte-character r0 r1)
 578                 (read r0)
 579                 (repeat)))
 580
 581            (if (r3 < #x3400)
 582                ;; mule-unicode-2500-33ff
 583                ((r0 = r3)               ; don't zap r3
 584                 (lookup-integer utf-subst-table-for-decode r0 r1)
 585                 (if (r7 == 0)
 586                     ((r0 = ,(charset-id 'mule-unicode-2500-33ff))
 587                      (r3 -= #x2500)
 588                      (r3 //= 96)
 589                      (r1 = (r7 + 32))
 590                      (r1 += ((r3 + 32) << 7))))
 591                 (write-multibyte-character r0 r1)
 592                 (read r0)
 593                 (repeat)))
 594
 595            (if (r3 < #xE000)
 596                ;; Try to convert to CJK chars, else
 597                ;; keep them as eight-bit-{control|graphic}.
 598                ((r0 = r3)
 599                 (lookup-integer utf-subst-table-for-decode r3 r1)
 600                 (if r7
 601                     ;; got a translation
 602                     ((write-multibyte-character r3 r1)
 603                      (read r0)
 604                      (repeat))
 605                   ((call ccl-mule-utf-untrans)
 606                    (r6 = ,(charset-id 'latin-iso8859-1))
 607                    (read r0)
 608                    (repeat)))))
 609
 610            ;; mule-unicode-e000-ffff
 611            ;; Fixme: fffe and ffff are invalid.
 612            (r0 = r3)            ; don't zap r3
 613            (lookup-integer utf-subst-table-for-decode r0 r1)
 614            (if (r7 == 0)
 615                ((r0 = ,(charset-id 'mule-unicode-e000-ffff))
 616                 (r3 -= #xe000)
 617                 (r3 //= 96)
 618                 (r1 = (r7 + 32))
 619                 (r1 += ((r3 + 32) << 7))))
 620            (write-multibyte-character r0 r1)
 621            (read r0)
 622            (repeat)))
 623
 624       ;; Read the 4th bytes.
 625       (read r3)
 626       (if ((r3 & #b11000000) != #b10000000) ; Invalid 4th byte
 627           ((call ccl-mule-utf-untrans)
 628            (r0 = r1)
 629            (call ccl-mule-utf-untrans)
 630            (r0 = r2)
 631            (call ccl-mule-utf-untrans)
 632            (r6 = ,(charset-id 'latin-iso8859-1))
 633            ;; Handle it in the next loop.
 634            (r0 = r3)
 635            (repeat)))
 636
 637       (if (r0 < #xF8)
 638           ;; 4-byte encoding:
 639           ;; wwwzzzzzzyyyyyyxxxxxx = 11110www 10zzzzzz 10yyyyyy 10xxxxxx
 640           ;; keep those bytes as eight-bit-{control|graphic}
 641           ;; Fixme: allow lookup in utf-subst-table-for-decode.
 642           ((r4 = ((r0 & #x7) << 18))
 643            (r4 |= ((r1 & #x3F) << 12))
 644            (r4 |= ((r2 & #x3F) << 6))
 645            (r4 |= (r3 & #x3F))
 646
 647            (if (r4 < #x10000)           ; `overlong sequence'
 648                ((call ccl-mule-utf-untrans)
 649                 (r0 = r1)
 650                 (call ccl-mule-utf-untrans)
 651                 (r0 = r2)
 652                 (call ccl-mule-utf-untrans)
 653                 (r0 = r3)
 654                 (call ccl-mule-utf-untrans))
 655              ((r0 = r4)
 656               (call ccl-mule-utf-untrans))))
 657
 658         ;; Unsupported sequence.
 659         ((call ccl-mule-utf-untrans)
 660          (r0 = r1)
 661          (call ccl-mule-utf-untrans)
 662          (r0 = r2)
 663          (call ccl-mule-utf-untrans)
 664          (r0 = r3)
 665          (call ccl-mule-utf-untrans)))
 666       (r6 = ,(charset-id 'latin-iso8859-1))
 667       (read r0)
 668       (repeat)))
 669
 670
 671     ;; At EOF...
 672     (if (r0 >= 0)
 673         ;; r0 >= #x80
 674         ((call ccl-mule-utf-untrans)
 675          (if (r1 >= 0)
 676              ((r0 = r1)
 677               (call ccl-mule-utf-untrans)
 678               (if (r2 >= 0)
 679                   ((r0 = r2)
 680                    (call ccl-mule-utf-untrans)
 681                    (if (r3 >= 0)
 682                        ((r0 = r3)
 683                         (call ccl-mule-utf-untrans))))))))))
 684
 685   "CCL program to decode UTF-8.
 686 Basic decoding is done into the charsets ascii, latin-iso8859-1 and
 687 mule-unicode-*, but see also `utf-fragmentation-table' and
 688 `ucs-mule-cjk-to-unicode'.
 689 Encodings of un-representable Unicode characters are decoded asis into
 690 eight-bit-control and eight-bit-graphic characters.")
 691
 692 (define-ccl-program ccl-mule-utf-8-encode-untrans
 693   ;; UTF-8 decoder generates an UTF-8 sequence represented by a
 694   ;; sequence eight-bit-control/graphic chars for an untranslatable
 695   ;; character and an invalid byte.
 696   ;;
 697   ;; This CCL parses that sequence (the first byte is already in r1),
 698   ;; writes out the original bytes of that sequence, and sets r5 to
 699   ;; -1.
 700   ;;
 701   ;; If the eight-bit-control/graphic sequence is shorter than what r1
 702   ;; suggests, it sets r5 and r6 to the last character read that
 703   ;; should be handled by the next loop of a caller.
 704   ;;
 705   ;; Note: For UTF-8 validation, we only check if a character is
 706   ;; eight-bit-control/graphic or not.  It may result in incorrect
 707   ;; handling of random binary data, but such a data can't be encoded
 708   ;; by UTF-8 anyway.  At least, UTF-8 decoders doesn't generate such
 709   ;; a sequence even if a source contains invalid byte-sequence.
 710   `(0
 711     (;; Read the 2nd byte.
 712      (read-multibyte-character r5 r6)
 713      (r0 = (r5 != ,(charset-id 'eight-bit-control)))
 714      (if ((r5 != ,(charset-id 'eight-bit-graphic)) & r0)
 715          ((write r1)                    ; invalid UTF-8
 716           (r1 = -1)
 717           (end)))
 718
 719      (if (r1 <= #xC3)
 720          ;; 2-byte sequence for an originally invalid byte.
 721          ((r6 &= #x3F)
 722           (r6 |= ((r1 & #x1F) << 6))
 723           (write r6)
 724           (r5 = -1)
 725           (end)))
 726
 727      (write r1 r6)
 728      (r2 = r1)
 729      (r1 = -1)
 730      ;; Read the 3rd byte.
 731      (read-multibyte-character r5 r6)
 732      (r0 = (r5 != ,(charset-id 'eight-bit-control)))
 733      (if ((r5 != ,(charset-id 'eight-bit-graphic)) & r0)
 734          (end))                         ; invalid UTF-8
 735      (write r6)
 736      (if (r2 < #xF0)
 737          ;; 3-byte sequence for an untranslated character.
 738          ((r5 = -1)
 739           (end)))
 740      ;; Read the 4th byte.
 741      (read-multibyte-character r5 r6)
 742      (r0 = (r5 != ,(charset-id 'eight-bit-control)))
 743      (if ((r5 != ,(charset-id 'eight-bit-graphic)) & r0)
 744          (end))                 ; invalid UTF-8
 745      ;; 4-byte sequence for an untranslated character.
 746      (write r6)
 747      (r5 = -1)
 748      (end))
 749
 750     ;; At EOF...
 751     ((r5 = -1)
 752      (if (r1 >= 0)
 753          (write r1)))))
 754
 755 (define-ccl-program ccl-encode-mule-utf-8
 756   `(1
 757     ((r5 = -1)
 758      (loop
 759       (if (r5 < 0)
 760           (read-multibyte-character r0 r1)
 761         ;; Pre-read character is in r5 (charset-ID) and r6 (code-point).
 762         ((r0 = r5)
 763          (r1 = r6)
 764          (r5 = -1)))
 765       (translate-character utf-translation-table-for-encode r0 r1)
 766
 767       (if (r0 == ,(charset-id 'ascii))
 768           (write-repeat r1))
 769
 770       (if (r0 == ,(charset-id 'latin-iso8859-1))
 771           ;; r1          scalar                  utf-8
 772           ;;       0000 0yyy yyxx xxxx    110y yyyy 10xx xxxx
 773           ;; 20    0000 0000 1010 0000    1100 0010 1010 0000
 774           ;; 7f    0000 0000 1111 1111    1100 0011 1011 1111
 775           ((write ((r1 >> 6) | #xc2))
 776            (r1 &= #x3f)
 777            (r1 |= #x80)
 778            (write-repeat r1)))
 779
 780       (if (r0 == ,(charset-id 'mule-unicode-0100-24ff))
 781           ((r0 = ((((r1 & #x3f80) >> 7) - 32) * 96))
 782            ;; #x3f80 == (0011 1111 1000 0000)b
 783            (r1 &= #x7f)
 784            (r1 += (r0 + 224))           ; 240 == -32 + #x0100
 785            ;; now r1 holds scalar value
 786            (if (r1 < #x0800)
 787                ;; 2byte encoding
 788                ((write ((r1 >> 6) | #xC0))
 789                 (r1 &= #x3F)
 790                 (r1 |= #x80)
 791                 (write-repeat r1))
 792              ;; 3byte encoding
 793              ((write ((r1 >> 12) | #xE0))
 794               (write  (((r1 & #x0FC0) >> 6) | #x80))
 795               (r1 &= #x3F)
 796               (r1 |= #x80)
 797               (write-repeat r1)))))
 798
 799       (if (r0 == ,(charset-id 'mule-unicode-2500-33ff))
 800           ((r0 = ((((r1 & #x3f80) >> 7) - 32) * 96))
 801            (r1 &= #x7f)
 802            (r1 += (r0 + 9440))          ; 9440 == -32 + #x2500
 803            ;; now r1 holds scalar value
 804            (write ((r1 >> 12) | #xE0))
 805            (write  (((r1 & #x0FC0) >> 6) | #x80))
 806            (r1 &= #x3F)
 807            (r1 |= #x80)
 808            (write-repeat r1)))
 809
 810       (if (r0 == ,(charset-id 'mule-unicode-e000-ffff))
 811           ((r0 = ((((r1 & #x3f80) >> 7) - 32) * 96))
 812            (r1 &= #x7f)
 813            (r1 += (r0 + 57312))         ; 57312 == -32 + #xe000
 814            ;; now r1 holds scalar value
 815            (write ((r1 >> 12) | #xE0))
 816            (write  (((r1 & #x0FC0) >> 6) | #x80))
 817            (r1 &= #x3F)
 818            (r1 |= #x80)
 819            (write-repeat r1)))
 820
 821       (if (r0 == ,(charset-id 'eight-bit-control))
 822           ;; r1          scalar                  utf-8
 823           ;;       0000 0yyy yyxx xxxx    110y yyyy 10xx xxxx
 824           ;; 80    0000 0000 1000 0000    1100 0010 1000 0000
 825           ;; 9f    0000 0000 1001 1111    1100 0010 1001 1111
 826           ((write #xC2)
 827            (write-repeat r1)))
 828
 829       (if (r0 == ,(charset-id 'eight-bit-graphic))
 830           ;; r1          scalar                  utf-8
 831           ;;       0000 0yyy yyxx xxxx    110y yyyy 10xx xxxx
 832           ;; a0    0000 0000 1010 0000    1100 0010 1010 0000
 833           ;; ff    0000 0000 1111 1111    1101 1111 1011 1111
 834           ((r0 = (r1 >= #xC0))
 835            (r0 &= (r1 <= #xC3))
 836            (r4 = (r1 >= #xE1))
 837            (r4 &= (r1 <= #xF7))
 838            (r0 |= r4)
 839            (if r0
 840                ((call ccl-mule-utf-8-encode-untrans)
 841                 (repeat))
 842              (write-repeat r1))))
 843
 844       (lookup-character utf-subst-table-for-encode r0 r1)
 845       (if r7            ; lookup succeeded
 846           (if (r0 < #x800)
 847               ;; 2byte encoding
 848               ((write ((r0 >> 6) | #xC0))
 849                (r0 = ((r0 & #x3F) | #x80))
 850                (write-repeat r0))
 851             ;; 3byte encoding
 852             ((write ((r0 >> 12) | #xE0))
 853              (write  (((r0 & #x0FC0) >> 6) | #x80))
 854              (r0 = ((r0 & #x3F) | #x80))
 855              (write-repeat r0))))
 856
 857       ;; Unsupported character.
 858       ;; Output U+FFFD, which is `ef bf bd' in UTF-8.
 859       (write #xef)
 860       (write #xbf)
 861       (write-repeat #xbd))))
 862   "CCL program to encode into UTF-8.")
 863
 864
 865 (define-ccl-program ccl-untranslated-to-ucs
 866   `(0
 867     (if (r1 == 0)
 868         nil
 869       (if (r0 <= #xC3)                  ; 2-byte encoding
 870           ((r0 = ((r0 & #x3) << 6))
 871            (r0 |= (r1 & #x3F))
 872            (r1 = 2))
 873         (if (r2 == 0)
 874             (r1 = 0)
 875           (if (r0 < #xF0)               ; 3-byte encoding, as above
 876               ((r0 = ((r0 & #xF) << 12))
 877                (r0 |= ((r1 & #x3F) << 6))
 878                (r0 |= (r2 & #x3F))
 879                (r1 = 3))
 880             (if (r3 == 0)
 881                 (r1 = 0)
 882               ((r0 = ((r0 & #x7) << 18))
 883                (r0 |= ((r1 & #x3F) << 12))
 884                (r0 |= ((r2 & #x3F) << 6))
 885                (r0 |= (r3 & #x3F))
 886                (r1 = 4))))))))
 887   "Decode 2-, 3-, or 4-byte sequences in r0, r1, r2 [,r3] to unicodes in r0.
 888 Set r1 to the byte length.  r0 == 0 for invalid sequence.")
 889
 890 (defvar utf-8-ccl-regs (make-vector 8 0))
 891
 892 (defsubst utf-8-untranslated-to-ucs ()
 893   "Return the UCS code for an untranslated sequence of raw bytes t point.
 894 Only for 3- or 4-byte sequences."
 895   (aset utf-8-ccl-regs 0 (or (char-after) 0))
 896   (aset utf-8-ccl-regs 1 (or (char-after (1+ (point))) 0))
 897   (aset utf-8-ccl-regs 2 (or (char-after (+ 2 (point))) 0))
 898   (aset utf-8-ccl-regs 3 (or (char-after (+ 3 (point))) 0))
 899   (ccl-execute 'ccl-untranslated-to-ucs utf-8-ccl-regs))
 900
 901 (defun utf-8-help-echo (window object position)
 902   (format "Untranslated Unicode U+%04X"
 903           (get-char-property position 'untranslated-utf-8 object)))
 904
 905 ;; We compose the untranslatable sequences into a single character,
 906 ;; and move point to the next character.
 907 ;; This is infelicitous for editing, because there's currently no
 908 ;; mechanism for treating compositions as atomic, but is OK for
 909 ;; display.  They are composed to U+FFFD with help-echo which
 910 ;; indicates the unicodes they represent.  This function GCs too much.
 911
 912 ;; If utf-translate-cjk-mode is non-nil, this function is called with
 913 ;; HASH-TABLE which translates CJK characters into some of CJK
 914 ;; charsets.
 915
 916 (defsubst utf-8-compose (hash-table)
 917   "Put a suitable composition on an untranslatable sequence at point.
 918 If HASH-TABLE is non-nil, try to translate CJK characters by it at first.
 919 Move point to the end of the sequence."
 920   (utf-8-untranslated-to-ucs)
 921   (let ((l (aref utf-8-ccl-regs 1))
 922         ch)
 923     (if (> l 0)
 924         (if (and hash-table
 925                  (setq ch (gethash (aref utf-8-ccl-regs 0)  hash-table)))
 926             (progn
 927               (insert ch)
 928               (delete-region (point) (min (point-max) (+ l (point)))))
 929           (setq ch (aref utf-8-ccl-regs 0))
 930           (put-text-property (point) (min (point-max) (+ l (point)))
 931                              'untranslated-utf-8 ch)
 932           (put-text-property (point) (min (point-max) (+ l (point)))
 933                              'help-echo 'utf-8-help-echo)
 934           (if (= l 2)
 935               (put-text-property (point) (min (point-max) (+ l (point)))
 936                                  'display (format "\\%03o" ch))
 937             (compose-region (point) (+ l (point)) ?\e$,3u=\e(B))
 938           (forward-char l))
 939       (forward-char 1))))
 940
 941 (defcustom utf-8-compose-scripts nil
 942   "*Non-nil means compose various scripts on decoding utf-8 text."
 943   :group 'mule
 944   :version "21.4"
 945   :type 'boolean)
 946
 947 (defun utf-8-post-read-conversion (length)
 948   "Compose untranslated utf-8 sequences into single characters.
 949 If `utf-translate-cjk-mode' is non-nil, tries to translate CJK characters.
 950 Also compose particular scripts if `utf-8-compose-scripts' is non-nil."
 951   (save-excursion
 952     (save-restriction
 953       (narrow-to-region (point) (+ (point) length))
 954       ;; Can't do eval-when-compile to insert a multibyte constant
 955       ;; version of the string in the loop, since it's always loaded as
 956       ;; unibyte from a byte-compiled file.
 957       (let ((range (string-as-multibyte "^\xc0-\xc3\xe1-\xf7"))
 958             (buffer-multibyte enable-multibyte-characters)
 959             hash-table ch)
 960         (set-buffer-multibyte t)
 961         (when utf-translate-cjk-mode
 962           (unless utf-translate-cjk-lang-env
 963             ;; Check these characters in utf-translate-cjk-range.
 964             ;; We may have to translate them to CJK charsets.
 965             (skip-chars-forward
 966              (concat range utf-translate-cjk-unicode-range-string))
 967             (unless (eobp)
 968               (utf-translate-cjk-load-tables)
 969               (setq range
 970                     (concat range utf-translate-cjk-unicode-range-string)))
 971             (setq hash-table (get 'utf-subst-table-for-decode
 972                                   'translation-hash-table))))
 973         (while (and (skip-chars-forward range)
 974                     (not (eobp)))
 975           (setq ch (following-char))
 976           (if (< ch 256)
 977               (utf-8-compose hash-table)
 978             (if (and hash-table
 979                      (setq ch (gethash (encode-char ch 'ucs) hash-table)))
 980                 (progn
 981                   (insert ch)
 982                   (delete-char 1))
 983               (forward-char 1))))
 984         (or buffer-multibyte
 985             (set-buffer-multibyte nil)))
 986
 987       (when (and utf-8-compose-scripts (> length 1))
 988         ;; These currently have definitions which cover the relevant
 989         ;; unicodes.  We could avoid loading thai-util &c by checking
 990         ;; whether the region contains any characters with the appropriate
 991         ;; categories.  There aren't yet Unicode-based rules for Tibetan.
 992         (diacritic-compose-region (point-max) (point-min))
 993         (thai-compose-region (point-max) (point-min))
 994         (lao-compose-region (point-max) (point-min))
 995         (devanagari-compose-region (point-max) (point-min))
 996         (malayalam-compose-region (point-max) (point-min))
 997         (tamil-compose-region (point-max) (point-min)))
 998       (- (point-max) (point-min)))))
 999
1000 (defun utf-8-pre-write-conversion (beg end)
1001   "Prepare for `utf-translate-cjk-mode' to encode text between BEG and END.
1002 This is used as a post-read-conversion of utf-8 coding system."
1003   (if (and utf-translate-cjk-mode
1004            (not utf-translate-cjk-lang-env)
1005            (save-excursion
1006              (goto-char beg)
1007              (re-search-forward "\\cc\\|\\cj\\|\\ch" end t)))
1008       (utf-translate-cjk-load-tables))
1009   nil)
1010
1011 (make-coding-system
1012  'mule-utf-8 4 ?u
1013  "UTF-8 encoding for Emacs-supported Unicode characters.
1014 It supports Unicode characters of these ranges:
1015     U+0000..U+33FF, U+E000..U+FFFF.
1016 They correspond to these Emacs character sets:
1017     ascii, latin-iso8859-1, mule-unicode-0100-24ff,
1018     mule-unicode-2500-33ff, mule-unicode-e000-ffff
1019
1020 On decoding (e.g. reading a file), Unicode characters not in the above
1021 ranges are decoded into sequences of eight-bit-control and
1022 eight-bit-graphic characters to preserve their byte sequences.  The
1023 byte sequence is preserved on i/o for valid utf-8, but not necessarily
1024 for invalid utf-8.
1025
1026 On encoding (e.g. writing a file), Emacs characters not belonging to
1027 any of the character sets listed above are encoded into the UTF-8 byte
1028 sequence representing U+FFFD (REPLACEMENT CHARACTER)."
1029
1030  '(ccl-decode-mule-utf-8 . ccl-encode-mule-utf-8)
1031  `((safe-charsets
1032     ascii
1033     eight-bit-control
1034     eight-bit-graphic
1035     latin-iso8859-1
1036     mule-unicode-0100-24ff
1037     mule-unicode-2500-33ff
1038     mule-unicode-e000-ffff
1039     ,@(if utf-translate-cjk-mode
1040           utf-translate-cjk-charsets))
1041    (mime-charset . utf-8)
1042    (coding-category . coding-category-utf-8)
1043    (valid-codes (0 . 255))
1044    (pre-write-conversion . utf-8-pre-write-conversion)
1045    (post-read-conversion . utf-8-post-read-conversion)
1046    (translation-table-for-encode . utf-translation-table-for-encode)
1047    (dependency unify-8859-on-encoding-mode
1048                unify-8859-on-decoding-mode
1049                utf-fragment-on-decoding
1050                utf-translate-cjk-mode)))
1051
1052 (define-coding-system-alias 'utf-8 'mule-utf-8)
1053
1054 ;; I think this needs special private charsets defined for the
1055 ;; untranslated sequences, if it's going to work well.
1056
1057 ;;; (defun utf-8-compose-function (pos to pattern &optional string)
1058 ;;;   (let* ((prop (get-char-property pos 'composition string))
1059 ;;;      (l (and prop (- (cadr prop) (car prop)))))
1060 ;;;     (cond ((and l (> l (- to pos)))
1061 ;;;        (delete-region pos to))
1062 ;;;       ((and (> (char-after pos) 224)
1063 ;;;             (< (char-after pos) 256)
1064 ;;;             (save-restriction
1065 ;;;               (narrow-to-region pos to)
1066 ;;;               (utf-8-compose)))
1067 ;;;        t))))
1068
1069 ;;; (dotimes (i 96)
1070 ;;;   (aset composition-function-table
1071 ;;;     (+ 128 i)
1072 ;;;     `((,(string-as-multibyte "[\200-\237\240-\377]")
1073 ;;;        . utf-8-compose-function))))
1074
1075 ;;; arch-tag: b08735b7-753b-4ae6-b754-0f3efe4515c5
1076 ;;; utf-8.el ends here