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