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